Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Chapters/Chap_DIA.tex
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Chapters/Chap_DIA.tex (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Chapters/Chap_DIA.tex (revision 5214)
@@ -74,5 +74,5 @@
The second functionality targets output performance when running in parallel (\key{mpp\_mpi}). Iomput provides the possibility to specify N dedicated I/O processes (in addition to the NEMO processes) to collect and write the outputs. With an appropriate choice of N by the user, the bottleneck associated with the writing of the output files can be greatly reduced.
-Since version 3.5, the iom\_put interface depends on an external code called \href{http://forge.ipsl.jussieu.fr/ioserver}{XIOS}. This new IO server can take advantage of the parallel I/O functionality of NetCDF4 to create a single output file and therefore to bypass the rebuilding phase. Note that writing in parallel into the same NetCDF files requires that your NetCDF4 library is linked to an HDF5 library that has been correctly compiled (i.e. with the configure option $--$enable-parallel). Note that the files created by iomput through XIOS are incompatible with NetCDF3. All post-processsing and visualization tools must therefore be compatible with NetCDF4 and not only NetCDF3.
+In version 3.6, the iom\_put interface depends on an external code called \href{https://forge.ipsl.jussieu.fr/ioserver/browser/XIOS/branchs/xios-1.0}{XIOS-1.0}. This new IO server can take advantage of the parallel I/O functionality of NetCDF4 to create a single output file and therefore to bypass the rebuilding phase. Note that writing in parallel into the same NetCDF files requires that your NetCDF4 library is linked to an HDF5 library that has been correctly compiled (i.e. with the configure option $--$enable-parallel). Note that the files created by iomput through XIOS are incompatible with NetCDF3. All post-processsing and visualization tools must therefore be compatible with NetCDF4 and not only NetCDF3.
Even if not using the parallel I/O functionality of NetCDF4, using N dedicated I/O servers, where N is typically much less than the number of NEMO processors, will reduce the number of output files created. This can greatly reduce the post-processing burden usually associated with using large numbers of NEMO processors. Note that for smaller configurations, the rebuilding phase can be avoided, even without a parallel-enabled NetCDF4 library, simply by employing only one dedicated I/O server.
@@ -543,6 +543,136 @@
\end{tabular}
+\subsubsection{Advanced use of XIOS functionalities}
\subsection{XML reference tables}
+
+(1) Simple computation: directly define the computation when refering to the variable in the file definition.
+
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+ sst + 273.15
+ taum * taum
+ qt - qsr - qns
+\end{verbatim}
+}}\end{alltt}
+
+(2) Simple computation: define a new variable and use it in the file definition.
+
+in field\_definition:
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+ sst * sst
+\end{verbatim}
+}}\end{alltt}
+in file\_definition:
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+ sst2
+\end{verbatim}
+}}\end{alltt}
+Note that in this case, the following syntaxe $<$field field\_ref="sst2" /$>$ is not working as sst2 won't be evaluated.
+
+(3) Change of variable precision:
+
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+
+
+
+
+\end{verbatim}
+}}\end{alltt}
+Note that, then the code is crashing, writting real4 variables forces a numerical convection from real8 to real4 which will create an internal error in NetCDF and will avoid the creation of the output files. Forcing double precision outputs with prec="8" (for example in the field\_definition) will avoid this problem.
+
+(4) add user defined attributes:
+
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+
+
+
+ blabla
+ 3
+ 5.0
+
+ blabla\_global
+
+
+\end{verbatim}
+}}\end{alltt}
+
+(5) use of the ``@'' function: example 1, weighted temporal average
+
+ - define a new variable in field\_definition
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+ toce * e3t
+\end{verbatim}
+}}\end{alltt}
+ - use it when defining your file.
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+
+
+ @toce\_e3t / @e3t
+
+
+\end{verbatim}
+}}\end{alltt}
+The freq\_op="5d" attribute is used to define the operation frequency of the ``@'' function: here 5 day. The temporal operation done by the ``@'' is the one defined in the field definition: here we use the default, average. So, in the above case, @toce\_e3t will do the 5-day mean of toce*e3t. Operation="instant" refers to the temporal operation to be performed on the field''@toce\_e3t / @e3t'': here the temporal average is alreday done by the ``@'' function so we just use instant to do the ratio of the 2 mean values. field\_ref="toce" means that attributes not explicitely defined, are inherited from toce field. Note that in this case, freq\_op must be equal to the file output\_freq.
+
+(6) use of the ``@'' function: example 2, monthly SSH standard deviation
+
+ - define a new variable in field\_definition
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+ ssh * ssh
+\end{verbatim}
+}}\end{alltt}
+ - use it when defining your file.
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+
+
+ sqrt( @ssh2 - @ssh * @ssh )
+
+
+\end{verbatim}
+}}\end{alltt}
+The freq\_op="1m" attribute is used to define the operation frequency of the ``@'' function: here 1 month. The temporal operation done by the ``@'' is the one defined in the field definition: here we use the default, average. So, in the above case, @ssh2 will do the monthly mean of ssh*ssh. Operation="instant" refers to the temporal operation to be performed on the field ''sqrt( @ssh2 - @ssh * @ssh )'': here the temporal average is alreday done by the ``@'' function so we just use instant. field\_ref="ssh" means that attributes not explicitely defined, are inherited from ssh field. Note that in this case, freq\_op must be equal to the file output\_freq.
+
+(7) use of the ``@'' function: example 3, monthly average of SST diurnal cycle
+
+ - define 2 new variables in field\_definition
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+
+
+\end{verbatim}
+}}\end{alltt}
+ - use these 2 new variables when defining your file.
+\vspace{-20pt}
+\begin{alltt} {{\scriptsize
+\begin{verbatim}
+
+
+ @sstmax - @sstmin
+
+
+\end{verbatim}
+}}\end{alltt}
+The freq\_op="1d" attribute is used to define the operation frequency of the ``@'' function: here 1 day. The temporal operation done by the ``@'' is the one defined in the field definition: here maximum for sstmax and minimum for sstmin. So, in the above case, @sstmax will do the daily max and @sstmin the daily min. Operation="average" refers to the temporal operation to be performed on the field ``@sstmax - @sstmin'': here monthly mean (of daily max - daily min of the sst). field\_ref="sst" means that attributes not explicitely defined, are inherited from sst field.
+
+
\subsubsection{Tag list}
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Chapters/Chap_TRA.tex
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Chapters/Chap_TRA.tex (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Chapters/Chap_TRA.tex (revision 5214)
@@ -1077,6 +1077,5 @@
correctly set ($i.e.$ that $T_o$ and $S_o$ are provided in input files and read
using \mdl{fldread}, see \S\ref{SBC_fldread}).
-The restoring coefficient $\gamma$ is a three-dimensional array initialized by the
-user in routine \rou{dtacof} also located in module \mdl{tradmp}.
+The restoring coefficient $\gamma$ is a three-dimensional array read in during the \rou{tra\_dmp\_init} routine. The file name is specified by the namelist variable \np{cn\_resto}. The DMP\_TOOLS tool is provided to allow users to generate the netcdf file.
The two main cases in which \eqref{Eq_tra_dmp} is used are \textit{(a)}
@@ -1092,23 +1091,5 @@
diagnostic method \citep{Sarmiento1982}. It allows us to find the velocity
field consistent with the model dynamics whilst having a $T$, $S$ field
-close to a given climatological field ($T_o$, $S_o$). The time scale
-associated with $S_o$ is generally not a constant but spatially varying
-in order to respect other properties. For example, it is usually set to zero
-in the mixed layer (defined either on a density or $S_o$ criterion)
-\citep{Madec_al_JPO96} and in the equatorial region
-\citep{Reverdin1991, Fujio1991, Marti_PhD92} since these two regions
-have a short time scale of adjustment; while smaller $\gamma$ are used
-in the deep ocean where the typical time scale is long \citep{Sarmiento1982}.
-In addition the time scale is reduced (even to zero) along the western
-boundary to allow the model to reconstruct its own western boundary
-structure in equilibrium with its physics.
-The choice of the shape of the Newtonian damping is controlled by two
-namelist parameters \np{nn\_hdmp} and \np{nn\_zdmp}. The former allows us to specify: the
-width of the equatorial band in which no damping is applied; a decrease
-in the vicinity of the coast; and a damping everywhere in the Red and Med Seas.
-The latter sets whether damping should act in the mixed layer or not.
-The time scale associated with the damping depends on the depth as
-a hyperbolic tangent, with \np{rn\_surf} as surface value, \np{rn\_bot} as
-bottom value and a transition depth of \np{rn\_dep}.
+close to a given climatological field ($T_o$, $S_o$).
The robust diagnostic method is very efficient in preventing temperature
@@ -1118,9 +1099,19 @@
by stabilising the water column too much.
-An example of the computation of $\gamma$ for a robust diagnostic experiment
-with the ORCA2 model is provided in the \mdl{tradmp} module
-(subroutines \rou{dtacof} and \rou{cofdis} which compute the coefficient
-and the distance to the bathymetry, respectively). These routines are
-provided as examples and can be customised by the user.
+The namelist parameter \np{nn\_zdmp} sets whether the damping should be applied in the whole water column or only below the mixed layer (defined either on a density or $S_o$ criterion). It is common to set the damping to zero in the mixed layer as the adjustment time scale is short here \citep{Madec_al_JPO96}.
+
+\subsection[DMP\_TOOLS]{Generating resto.nc using DMP\_TOOLS}
+
+DMP\_TOOLS can be used to generate a netcdf file containing the restoration coefficient $\gamma$. Note that in order to maintain bit comparison with previous NEMO versions DMP\_TOOLS must be compiled and run on the same machine as the NEMO model. A mesh\_mask.nc file for the model configuration is required as an input. This can be generated by carrying out a short model run with the namelist parameter \np{nn\_msh} set to 1. The namelist parameter \np{ln\_tradmp} will also need to be set to .false. for this to work. The \nl{nam\_dmp\_create} namelist in the DMP\_TOOLS directory is used to specify options for the restoration coefficient.
+
+%--------------------------------------------nam_dmp_create-------------------------------------------------
+\namdisplay{nam_dmp_create}
+%-------------------------------------------------------------------------------------------------------
+
+\np{cp\_cfg}, \np{cp\_cpz}, \np{jp\_cfg} and \np{jperio} specify the model configuration being used and should be the same as specified in \nl{namcfg}. The variable \nl{lzoom} is used to specify that the damping is being used as in case \textit{a} above to provide boundary conditions to a zoom configuration. In the case of the arctic or antarctic zoom configurations this includes some specific treatment. Otherwise damping is applied to the 6 grid points along the ocean boundaries. The open boundaries are specified by the variables \np{lzoom\_n}, \np{lzoom\_e}, \np{lzoom\_s}, \np{lzoom\_w} in the \nl{nam\_zoom\_dmp} name list.
+
+The remaining switch namelist variables determine the spatial variation of the restoration coefficient in non-zoom configurations. \np{ln\_full\_field} specifies that newtonian damping should be applied to the whole model domain. \np{ln\_med\_red\_seas} specifies grid specific restoration coefficients in the Mediterranean Sea for the ORCA4, ORCA2 and ORCA05 configurations. If \np{ln\_old\_31\_lev\_code} is set then the depth variation of the coeffients will be specified as a function of the model number. This option is included to allow backwards compatability of the ORCA2 reference configurations with previous model versions. \np{ln\_coast} specifies that the restoration coefficient should be reduced near to coastlines. This option only has an effect if \np{ln\_full\_field} is true. \np{ln\_zero\_top\_layer} specifies that the restoration coefficient should be zero in the surface layer. Finally \np{ln\_custom} specifies that the custom module will be called. This module is contained in the file custom.F90 and can be edited by users. For example damping could be applied in a specific region.
+
+The restoration coefficient can be set to zero in equatorial regions by specifying a positive value of \np{nn\_hdmp}. Equatorward of this latitude the restoration coefficient will be zero with a smooth transition to the full values of a 10$^{\circ}$ latitud band. This is often used because of the short adjustment time scale in the equatorial region \citep{Reverdin1991, Fujio1991, Marti_PhD92}. The time scale associated with the damping depends on the depth as a hyperbolic tangent, with \np{rn\_surf} as surface value, \np{rn\_bot} as bottom value and a transition depth of \np{rn\_dep}.
% ================================================================
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Namelist/nam_dmp_create
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Namelist/nam_dmp_create (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Namelist/nam_dmp_create (revision 5214)
@@ -0,0 +1,23 @@
+&nam_dmp_create
+ cp_cfg = 'orca' ! Name of model grid (orca and C1D have special options
+ ! otherwise ignored)
+ cp_cfz = 'antarctic' ! Name of zoom configuration (arctic and antarctic have
+ ! some special treatment if lzoom=.true.)
+ jp_cfg = 2 ! Resolution of the model (used for med_red_seas damping)
+ lzoom = .false. ! Zoom configuration or not
+ ln_full_field = .false. ! Calculate coefficient over whole of domain
+ ln_med_red_seas = .true. ! Damping in Med/Red Seas
+ ! (or local modifications here if ln_full_field=.true.)
+ ln_old_31_lev_code = .true. ! Replicate behaviour of old online code for 31 level model
+ ! (Med/Red seas damping based on level number instead of depth)
+ ln_coast = .true. ! Reduce near to coastlines
+ ln_zero_top_layer = .true. ! No damping in top layer
+ ln_custom = .false. ! Call "custom" module to apply user modifications to the
+ ! damping coefficient field
+ pn_surf = 0.25 ! Surface Relaxation timescale (days)
+ pn_bot = 0.25 ! Bottom relaxation timescale (days)
+ pn_dep = 1000 ! Transition depth from upper to deep ocean
+ nn_hdmp = 10 ! Damp poleward of this latitude (smooth transition up to maximum damping)
+ jperio = 2 ! Lateral boundary condition (as specified in namelist_cfg for model run).
+/
+
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Namelist/namtra_dmp
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Namelist/namtra_dmp (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/DOC/TexFiles/Namelist/namtra_dmp (revision 5214)
@@ -2,14 +2,9 @@
&namtra_dmp ! tracer: T & S newtonian damping
!-----------------------------------------------------------------------
- ln_tradmp = .true. ! add a damping termn (T) or not (F)
- nn_hdmp = -1 ! horizontal shape =-1, damping in Med and Red Seas only
- ! =XX, damping poleward of XX degrees (XX>0)
- ! + F(distance-to-coast) + Red and Med Seas
- nn_zdmp = 0 ! vertical shape =0 damping throughout the water column
- ! =1 no damping in the mixing layer (kz criteria)
- ! =2 no damping in the mixed layer (rho crieria)
- rn_surf = 50. ! surface time scale of damping [days]
- rn_bot = 360. ! bottom time scale of damping [days]
- rn_dep = 800. ! depth of transition between rn_surf and rn_bot [meters]
- nn_file = 0 ! create a damping.coeff NetCDF file (=1) or not (=0)
+ ln_tradmp = .true. ! add a damping termn (T) or not (F)
+ nn_zdmp = 0 ! vertical shape =0 damping throughout the water column
+ ! =1 no damping in the mixing layer (kz criteria)
+ ! =2 no damping in the mixed layer (rho crieria)
+ cn_resto = 'resto.nc' ! Name of file containing restoration coefficient field (use dmp_tools to create this)
+
/
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/INGV/arch-IBM_EKMAN_INGV.fcm
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/INGV/arch-IBM_EKMAN_INGV.fcm (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/INGV/arch-IBM_EKMAN_INGV.fcm (revision 5214)
@@ -18,12 +18,12 @@
%NCDF_INC -I/srv/lib/netcdf-x/include
%NCDF_LIB -L/srv/lib/netcdf-x/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lcurl -lstdc++
-%XIOS_ROOT /home/delrosso/XIOS_447/trunk
+%XIOS_ROOT /home/delrosso/XIOS_482/XIOS
%MPI_INTEL -I/srv/intel/impi/4.1.0.024/include
%CPP cpp
%FC mpiifort
-%FCFLAGS -r8 -O3 -g -traceback
+%FCFLAGS -r8 -O1 -g -traceback -fp-model precise
%FFLAGS %FCFLAGS
%LD mpiifort
-%LDFLAGS
+%LDFLAGS
%FPPFLAGS -P -C -traditional
%AR ar
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/OLD/arch-ifort_linux.fcm
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/OLD/arch-ifort_linux.fcm (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/OLD/arch-ifort_linux.fcm (revision 5214)
@@ -17,5 +17,5 @@
%NCDF_INC -I/usr/local/netcdf/include
%NCDF_LIB -L /usr/local/netcdf/lib -lnetcdf
-%FC ifort
+%FC ifort
%FCFLAGS -r8 -O3 -traceback
%FFLAGS -r8 -O3 -traceback
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/arch-PW7_METO.fcm
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/arch-PW7_METO.fcm (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/arch-PW7_METO.fcm (revision 5214)
@@ -19,6 +19,6 @@
%NCDF_INC -I/home/cr/ocean/hadcv/netcdf/4.1.3_seq/include
%NCDF_LIB -L/home/cr/ocean/hadcv/netcdf/4.1.3_seq/lib -lnetcdf -lnetcdff -lhdf5 -lhdf5_hl -lhdf5_fortran -lz
-%XIOS_INC -I/data/nwp/ofrd/share/NEMO/xios_lib/seq/xios_r451/inc
-%XIOS_LIB -L/data/nwp/ofrd/share/NEMO/xios_lib/seq/xios_r451/lib -lxios
+%XIOS_INC -I/home/cr/ocean/hadcv/xios_lib/par/r521/xios/inc
+%XIOS_LIB -L/home/cr/ocean/hadcv/xios_lib/par/r521/xios/lib -lxios
%CPP cpp
%FC mpxlf90_r
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/arch-PW7_MONSOON.fcm
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/arch-PW7_MONSOON.fcm (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/ARCH/arch-PW7_MONSOON.fcm (revision 5214)
@@ -0,0 +1,33 @@
+# IBM POWER7 UKMO
+# NCDF_INC netcdf include file
+# NCDF_LIB netcdf library
+# XIOS_INC XIOS include files
+# XIOS_LIB XIOS library
+# FC Fortran compiler command
+# FCFLAGS Fortran compiler flags
+# FFLAGS Fortran 77 compiler flags
+# LD linker
+# LDFLAGS linker flags, e.g. -L if you have libraries in a
+# FPPFLAGS pre-processing flags
+# AR assembler
+# ARFLAGS assembler flags
+# MK make
+# USER_INC additional include files for the compiler, e.g. -I
+# USER_LIB additional libraries to pass to the linker, e.g. -l
+
+%NCDF_INC -I/home/dcalve/netcdf/4.1.3_seq/include
+%NCDF_LIB -L/home/dcalve/netcdf/4.1.3_seq/lib -lnetcdf -lnetcdff -lhdf5 -lhdf5_hl -lhdf5_fortran -lz
+%XIOS_INC -I/home/dstork/xios_lib/par/r521/xios/inc
+%XIOS_LIB -L/home/dstork/xios_lib/par/r521/xios/lib -lxios
+%CPP cpp
+%FC mpxlf90_r
+%FCFLAGS -qrealsize=8 -qextname -qsuffix=f=f90 -qarch=pwr7 -qtune=pwr7 -g -O2 -qstrict -qinitauto=7FBFFFFF
+%FFLAGS -qrealsize=8 -qextname -qarch=pwr7 -qtune=pwr7 -g -O2 -qstrict -qinitauto=7FBFFFFF -qfixed
+%LD mpCC_r
+%LDFLAGS -lxlf90 -L/projects/um1/lib -lsig -O2 -L MASS
+%FPPFLAGS -E -P -traditional -I/opt/ibmhpc/pecurrent/ppe.poe/include -I/usr/lpp/ppe.poe/include/thread64
+%AR ar
+%ARFLAGS rs
+%MK gmake
+%USER_INC %NCDF_INC %XIOS_INC
+%USER_LIB %NCDF_LIB %XIOS_LIB
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/AMM12/EXP00/iodef.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/AMM12/EXP00/iodef.xml (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/AMM12/EXP00/iodef.xml (revision 5214)
@@ -40,9 +40,9 @@
-
+
-
+
@@ -70,5 +70,5 @@
-
+
@@ -76,5 +76,5 @@
-
+
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/C1D_PAPA/EXP00/namelist_cfg
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/C1D_PAPA/EXP00/namelist_cfg (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/C1D_PAPA/EXP00/namelist_cfg (revision 5214)
@@ -241,6 +241,4 @@
!-----------------------------------------------------------------------
ln_tradmp = .false. ! add a damping termn (T) or not (F)
- nn_zdmp = -1 ! vertical shape =0 damping throughout the water column
- nn_file = 1 ! create a damping.coeff NetCDF file (=1) or not (=0)
/
!-----------------------------------------------------------------------
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE/EXP00/namelist_cfg
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE/EXP00/namelist_cfg (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE/EXP00/namelist_cfg (revision 5214)
@@ -245,6 +245,4 @@
!-----------------------------------------------------------------------
ln_tradmp = .false. ! add a damping termn (T) or not (F)
- nn_zdmp = 1 ! vertical shape =0 damping throughout the water column
- nn_file = 1 ! create a damping.coeff NetCDF file (=1) or not (=0)
/
!-----------------------------------------------------------------------
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE_BFM/EXP00/namelist_cfg
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE_BFM/EXP00/namelist_cfg (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE_BFM/EXP00/namelist_cfg (revision 5214)
@@ -244,6 +244,4 @@
!-----------------------------------------------------------------------
ln_tradmp = .false. ! add a damping termn (T) or not (F)
- nn_zdmp = 1 ! vertical shape =0 damping throughout the water column
- nn_file = 1 ! create a damping.coeff NetCDF file (=1) or not (=0)
/
!-----------------------------------------------------------------------
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE_PISCES/EXP00/namelist_cfg
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE_PISCES/EXP00/namelist_cfg (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE_PISCES/EXP00/namelist_cfg (revision 5214)
@@ -155,6 +155,4 @@
!-----------------------------------------------------------------------
ln_tradmp = .false. ! add a damping termn (T) or not (F)
- nn_zdmp = 1 ! vertical shape =0 damping throughout the water column
- nn_file = 1 ! create a damping.coeff NetCDF file (=1) or not (=0)
/
!-----------------------------------------------------------------------
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE_XIOS/EXP00/namelist_cfg
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE_XIOS/EXP00/namelist_cfg (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/GYRE_XIOS/EXP00/namelist_cfg (revision 5214)
@@ -216,6 +216,4 @@
!-----------------------------------------------------------------------
ln_tradmp = .false. ! add a damping termn (T) or not (F)
- nn_zdmp = 1 ! vertical shape =0 damping throughout the water column
- nn_file = 1 ! create a damping.coeff NetCDF file (=1) or not (=0)
/
!-----------------------------------------------------------------------
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef.xml (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef.xml (revision 5214)
@@ -35,25 +35,30 @@
+
+ @toce_e3t / @e3t
+ @soce_e3t / @e3t
-
-
-
-
+ sqrt( @sst2 - @sst * @sst )
+ sqrt( @ssh2 - @ssh * @ssh )
+ @sstmax - @sstmin
+ @mldr10_1max - @mldr10_1min
-
-
-
+
+
+
+
-
-
+
+
+ @uoce_e3u / @e3u
- 5000000
+ 50000000
2
0
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef_ar5.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef_ar5.xml (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef_ar5.xml (revision 5214)
@@ -49,6 +49,6 @@
-
-
+
+
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef_crs.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef_crs.xml (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef_crs.xml (revision 5214)
@@ -40,9 +40,9 @@
-
+
-
+
@@ -71,5 +71,5 @@
-
+
@@ -77,5 +77,5 @@
-
+
Index: anches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef_default.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/iodef_default.xml (revision 5213)
+++ (revision )
@@ -1,170 +1,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- 5000000
- 2
- 0
- false
- false
- oceanx
-
-
-
-
-
-
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef.xml (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef.xml (revision 5214)
@@ -38,15 +38,19 @@
+
+ @toce_e3t / @e3t
+ @soce_e3t / @e3t
-
-
-
-
+ sqrt( @sst2 - @sst * @sst )
+ sqrt( @ssh2 - @ssh * @ssh )
+ @sstmax - @sstmin
-
-
+ @mldr10_1max - @mldr10_1min
+
+
+
@@ -72,6 +76,7 @@
+
-
+ @uoce_e3u / @e3u
@@ -82,6 +87,7 @@
+
-
+ @voce_e3v / @e3v
@@ -92,5 +98,6 @@
-
+
+ @woce_e3w / @e3w
@@ -323,5 +330,5 @@
We must have buffer_size > jpi*jpj*jpk*8 (with jpi and jpj the subdomain size)
-->
- 5000000
+ 50000000
2
0
Index: anches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef_ar5.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef_ar5.xml (revision 5213)
+++ (revision )
@@ -1,288 +1,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- 25000000
- 2
- 0
- false
- false
- oceanx
-
-
-
-
-
-
-
Index: anches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef_default.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef_default.xml (revision 5213)
+++ (revision )
@@ -1,336 +1,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- 5000000
- 2
- 0
- true
- false
- oceanx
-
-
-
-
-
-
Index: anches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef_demo.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef_demo.xml (revision 5213)
+++ (revision )
@@ -1,125 +1,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- 25000000
- 2
- 0
- false
- false
- oceanx
-
-
-
-
-
-
Index: anches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef_oldstyle.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef_oldstyle.xml (revision 5213)
+++ (revision )
@@ -1,153 +1,0 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- 25000000
- 2
- 0
- false
- false
- oceanx
-
-
-
-
-
-
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM_CFC_C14b/EXP00/iodef.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM_CFC_C14b/EXP00/iodef.xml (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM_CFC_C14b/EXP00/iodef.xml (revision 5214)
@@ -53,5 +53,5 @@
-
+
@@ -59,5 +59,5 @@
-
+
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM_PISCES/EXP00/iodef.xml
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM_PISCES/EXP00/iodef.xml (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/ORCA2_LIM_PISCES/EXP00/iodef.xml (revision 5214)
@@ -40,9 +40,9 @@
-
+
-
+
@@ -86,5 +86,5 @@
-
+
@@ -57,5 +74,4 @@
-
@@ -145,9 +161,9 @@
-
+
-
+
@@ -169,6 +185,6 @@
-
-
+
+
@@ -202,5 +218,5 @@
-
+
@@ -259,5 +275,5 @@
-
+
@@ -268,11 +284,11 @@
-
-
+
+
-
-
+
+
@@ -314,9 +330,9 @@
-
+
-
+
@@ -325,25 +341,28 @@
-
-
-
-
+
+
+
+ uoce * e3u
+
+
+
-
+
-
+
-
-
+
+
-
+
-
-
-
-
-
+
+
+
+
+
@@ -351,25 +370,28 @@
-
-
-
-
+
+
+
+ voce * e3v
+
+
+
-
+
-
+
-
-
+
+
-
+
-
-
-
-
-
+
+
+
+
+
@@ -377,5 +399,7 @@
+
+ woce * e3w
@@ -430,12 +454,12 @@
-
-
-
-
-
+
+
+
+
+
-
+
@@ -466,9 +490,9 @@
-
-
-
-
-
+
+
+
+
+
@@ -479,5 +503,5 @@
-
+
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/SHARED/namelist_ref
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/SHARED/namelist_ref (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/SHARED/namelist_ref (revision 5214)
@@ -794,14 +794,8 @@
!-----------------------------------------------------------------------
ln_tradmp = .true. ! add a damping termn (T) or not (F)
- nn_hdmp = -1 ! horizontal shape =-1, damping in Med and Red Seas only
- ! =XX, damping poleward of XX degrees (XX>0)
- ! + F(distance-to-coast) + Red and Med Seas
nn_zdmp = 0 ! vertical shape =0 damping throughout the water column
! =1 no damping in the mixing layer (kz criteria)
! =2 no damping in the mixed layer (rho crieria)
- rn_surf = 50. ! surface time scale of damping [days]
- rn_bot = 360. ! bottom time scale of damping [days]
- rn_dep = 800. ! depth of transition between rn_surf and rn_bot [meters]
- nn_file = 0 ! create a damping.coeff NetCDF file (=1) or not (=0)
+ cn_resto = 'resto.nc' ! Name of file containing restoration coefficient field (use dmp_tools to create this)
/
@@ -845,4 +839,5 @@
ln_dynvor_mix = .false. ! mixed scheme
ln_dynvor_een = .true. ! energy & enstrophy scheme
+ ln_dynvor_een_old = .false. ! energy & enstrophy scheme - original formulation
/
!-----------------------------------------------------------------------
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/SHARED/namelist_top_ref
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/SHARED/namelist_top_ref (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/SHARED/namelist_top_ref (revision 5214)
@@ -76,14 +76,8 @@
&namtrc_dmp ! passive tracer newtonian damping
!-----------------------------------------------------------------------
- nn_hdmp_tr = -1 ! horizontal shape =-1, damping in Med and Red Seas only
- ! =XX, damping poleward of XX degrees (XX>0)
- ! + F(distance-to-coast) + Red and Med Seas
nn_zdmp_tr = 1 ! vertical shape =0 damping throughout the water column
! =1 no damping in the mixing layer (kz criteria)
! =2 no damping in the mixed layer (rho crieria)
- rn_surf_tr = 50. ! surface time scale of damping [days]
- rn_bot_tr = 360. ! bottom time scale of damping [days]
- rn_dep_tr = 800. ! depth of transition between rn_surf and rn_bot [meters]
- nn_file_tr = 0 ! create a damping.coeff NetCDF file (=1) or not (=0)
+ cn_resto_tr = 'resto_tr.nc' ! create a damping.coeff NetCDF file (=1) or not (=0)
/
!-----------------------------------------------------------------------
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/makenemo
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/makenemo (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/CONFIG/makenemo (revision 5214)
@@ -200,11 +200,11 @@
;;
add_key)
- list_add_key=$2
- export ${list_add_key}
+ # Checking void argument
+ [ ! -z $2 ] && { list_add_key=$2; export ${list_add_key}; }
shift
;;
del_key)
- list_del_key=$2
- export ${list_del_key}
+ # Checking void argument
+ [ ! -z $2 ] && { list_del_key=$2; export ${list_del_key}; }
shift
;;
@@ -316,13 +316,7 @@
fi
-#- At this stage new configuration has been added,
-#- We add or remove keys
-if [ ${#list_add_key} -ne 0 ] ; then
- . ${COMPIL_DIR}/Fadd_keys.sh ${NEW_CONF} add_key ${list_add_key}
-fi
-
-if [ ${#list_del_key} -ne 0 ] ; then
- . ${COMPIL_DIR}/Fdel_keys.sh ${NEW_CONF} del_key ${list_del_key}
-fi
+#- At this stage new configuration has been added, we add or remove keys
+[ ! -z ${list_add_key} ] && { . ${COMPIL_DIR}/Fadd_keys.sh ${NEW_CONF} add_key ${list_add_key}; }
+[ ! -z ${list_del_key} ] && { . ${COMPIL_DIR}/Fdel_keys.sh ${NEW_CONF} del_key ${list_del_key}; }
#- check that all keys are really existing...
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_2/ice_2.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_2/ice_2.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/LIM_SRC_2/ice_2.F90 (revision 5214)
@@ -59,4 +59,7 @@
REAL(wp), PUBLIC :: sangvg, cangvg !: sin and cos of the turning angle for ocean stress
REAL(wp), PUBLIC :: pstarh !: pstar / 2.0
+
+ ! !!** switch for presence of ice or not
+ REAL(wp), PUBLIC :: rswitch
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahiu , ahiv !: hor. diffusivity coeff. at ocean U- and V-points (m2/s)
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90 (revision 5214)
@@ -46,5 +46,5 @@
USE timing ! Timing
USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)
- USE lbcnfd, ONLY: isendto, nsndto
+ USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges
USE trc
@@ -594,5 +594,6 @@
!!----------------------------------------------------------------------
!! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE)
- !! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC)
+ !! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S.
+ !Mocavero, CMCC)
!!----------------------------------------------------------------------
@@ -617,27 +618,38 @@
!loop over the other north-fold processes to find the processes
!managing the points belonging to the sxT-dxT range
- DO jn = jpnij - jpni +1, jpnij
- IF ( njmppt(jn) == njmppmax ) THEN
+
+ DO jn = 1, jpni
!sxT is the first point (in the global domain) of the jn
!process
- sxT = nimppt(jn)
+ sxT = nfiimpp(jn, jpnj)
!dxT is the last point (in the global domain) of the jn
!process
- dxT = nimppt(jn) + nlcit(jn) - 1
+ dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1
IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN
nsndto = nsndto + 1
- isendto(nsndto) = jn
- ELSEIF ((sxM .le. sxT) .AND. (dxM .gt. dxT)) THEN
+ isendto(nsndto) = jn
+ ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN
nsndto = nsndto + 1
- isendto(nsndto) = jn
+ isendto(nsndto) = jn
ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN
nsndto = nsndto + 1
- isendto(nsndto) = jn
+ isendto(nsndto) = jn
END IF
- END IF
END DO
+ nfsloop = 1
+ nfeloop = nlci
+ DO jn = 2,jpni-1
+ IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN
+ IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN
+ nfsloop = nldi
+ ENDIF
+ IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN
+ nfeloop = nlei
+ ENDIF
+ ENDIF
+ END DO
+
ENDIF
l_north_nogather = .TRUE.
-
END SUBROUTINE nemo_northcomms
#else
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90 (revision 5214)
@@ -125,7 +125,7 @@
IF(lwp) WRITE(numout,*) ' Number of tidal components to read: ', nb_harmo
IF(lwp) THEN
- WRITE(numout,*) ' Tidal cpt name - Phase speed (deg/hr)'
+ WRITE(numout,*) ' Tidal components: '
DO itide = 1, nb_harmo
- WRITE(numout,*) ' ', Wave(ntide(itide))%cname_tide, omega_tide(itide)
+ WRITE(numout,*) ' ', Wave(ntide(itide))%cname_tide
END DO
ENDIF
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/C1D/dyndmp.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/C1D/dyndmp.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/C1D/dyndmp.F90 (revision 5214)
@@ -3,6 +3,9 @@
!! *** MODULE dyndmp ***
!! Ocean dynamics: internal restoring trend on momentum (U and V current)
+ !! This should only be used for C1D case in current form
!!======================================================================
!! History : 3.5 ! 2013-08 (D. Calvert) Original code
+ !! 3.6 ! 2014-08 (T. Graham) Modified to use netcdf file of
+ !! restoration coefficients supplied to tradmp
!!----------------------------------------------------------------------
@@ -25,4 +28,5 @@
USE wrk_nemo ! Memory allocation
USE timing ! Timing
+ USE iom ! I/O manager
IMPLICIT NONE
@@ -73,4 +77,5 @@
NAMELIST/namc1d_dyndmp/ ln_dyndmp
INTEGER :: ios
+ INTEGER :: imask
!!----------------------------------------------------------------------
@@ -91,10 +96,7 @@
WRITE(numout,*) ' add a damping term or not ln_dyndmp = ', ln_dyndmp
WRITE(numout,*) ' Namelist namtra_dmp : Set damping parameters'
- WRITE(numout,*) ' horizontal damping option nn_hdmp = ', nn_hdmp
- WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp, '(non-C1D zoom: forced to 0)'
- WRITE(numout,*) ' surface time scale (days) rn_surf = ', rn_surf
- WRITE(numout,*) ' bottom time scale (days) rn_bot = ', rn_bot
- WRITE(numout,*) ' depth of transition (meters) rn_dep = ', rn_dep
- WRITE(numout,*) ' create a damping.coeff file nn_file = ', nn_file
+ WRITE(numout,*) ' Apply relaxation or not ln_tradmp = ', ln_tradmp
+ WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp
+ WRITE(numout,*) ' Damping file name cn_resto = ', cn_resto
WRITE(numout,*)
ENDIF
@@ -104,14 +106,4 @@
IF( dyn_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dyn_dmp_init: unable to allocate arrays' )
!
-#if ! defined key_c1d
- SELECT CASE ( nn_hdmp ) !== control print of horizontal option ==!
- CASE ( -1 ) ; IF(lwp) WRITE(numout,*) ' momentum damping in the Med & Red seas only'
- CASE ( 1:90 ) ; IF(lwp) WRITE(numout,*) ' momentum damping poleward of', nn_hdmp, ' degrees'
- CASE DEFAULT
- WRITE(ctmp1,*) ' bad flag value for nn_hdmp = ', nn_hdmp
- CALL ctl_stop(ctmp1)
- END SELECT
- !
-#endif
SELECT CASE ( nn_zdmp ) !== control print of vertical option ==!
CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' momentum damping throughout the water column'
@@ -130,13 +122,9 @@
utrdmp(:,:,:) = 0._wp ! internal damping trends
vtrdmp(:,:,:) = 0._wp
- ! !== Damping coefficients calculation: ==!
- ! !== use tradmp.F90 subroutines dtacof, dtacof_zoom and cofdis ==!
- ! !!! NOTE: these need to be altered for use in this module if
- ! !!! they are to be used outside the C1D context
- ! !!! (use of U,V grid variables)
- IF( lzoom .AND. .NOT. lk_c1d ) THEN ; CALL dtacof_zoom( resto_uv )
- ELSE ; CALL dtacof( nn_hdmp, rn_surf, rn_bot, rn_dep, nn_file, 'DYN', resto_uv )
- ENDIF
- !
+ !
+ !Read in mask from file
+ CALL iom_open ( cn_resto, imask)
+ CALL iom_get ( imask, jpdom_autoglo, 'resto', resto)
+ CALL iom_close( imask )
ENDIF
!
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90 (revision 5214)
@@ -82,6 +82,4 @@
CALL wrk_alloc( jpi , jpj , jpk , zrhd , zrhop )
CALL wrk_alloc( jpi , jpj , jpk , jpts , ztsn )
-
- CALL iom_put( 'cellthc', fse3t(:,:,:) )
zarea_ssh(:,:) = area(:,:) * sshn(:,:)
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90 (revision 5214)
@@ -142,85 +142,60 @@
ENDIF
- IF( lk_vvl ) THEN
- z3d(:,:,:) = tsn(:,:,:,jp_tem) * fse3t_n(:,:,:)
- CALL iom_put( "toce" , z3d ) ! heat content
+ IF( .NOT.lk_vvl ) THEN
+ CALL iom_put( "e3t" , fse3t_n(:,:,:) )
+ CALL iom_put( "e3u" , fse3u_n(:,:,:) )
+ CALL iom_put( "e3v" , fse3v_n(:,:,:) )
+ CALL iom_put( "e3w" , fse3w_n(:,:,:) )
+ ENDIF
+
+ CALL iom_put( "toce", tsn(:,:,:,jp_tem) ) ! 3D temperature
+ CALL iom_put( "sst", tsn(:,:,1,jp_tem) ) ! surface temperature
+ IF ( iom_use("sbt") ) THEN
DO jj = 1, jpj
DO ji = 1, jpi
- z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem) * fse3t_n(ji,jj,mikt(ji,jj))
- END DO
- END DO
- CALL iom_put( "sst" , z2d(:,:) ) ! sea surface heat content
+ z2d(ji,jj) = tsn(ji,jj,MAX(mbathy(ji,jj),1),jp_tem)
+ END DO
+ END DO
+ CALL iom_put( "sbt", z2d ) ! bottom temperature
+ ENDIF
+
+ CALL iom_put( "soce", tsn(:,:,:,jp_sal) ) ! 3D salinity
+ CALL iom_put( "sss", tsn(:,:,1,jp_sal) ) ! surface salinity
+ IF ( iom_use("sbs") ) THEN
DO jj = 1, jpj
DO ji = 1, jpi
- z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem)**2 * fse3t_n(ji,jj,mikt(ji,jj))
- END DO
- END DO
- CALL iom_put( "sst2" , z2d(:,:) ) ! sea surface content of squared temperature
- z3d(:,:,:) = tsn(:,:,:,jp_sal) * fse3t_n(:,:,:)
- CALL iom_put( "soce" , z3d ) ! salinity content
+ z2d(ji,jj) = tsn(ji,jj,MAX(mbathy(ji,jj),1),jp_sal)
+ END DO
+ END DO
+ CALL iom_put( "sbs", z2d ) ! bottom salinity
+ ENDIF
+
+ CALL iom_put( "uoce", un(:,:,:) ) ! 3D i-current
+ CALL iom_put( "ssu", un(:,:,1) ) ! surface i-current
+ IF ( iom_use("sbu") ) THEN
DO jj = 1, jpj
DO ji = 1, jpi
- z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * fse3t_n(ji,jj,mikt(ji,jj))
- END DO
- END DO
- CALL iom_put( "sss" , z2d(:,:) ) ! sea surface salinity content
+ z2d(ji,jj) = un(ji,jj,MAX(mbathy(ji,jj),1))
+ END DO
+ END DO
+ CALL iom_put( "sbu", z2d ) ! bottom i-current
+ ENDIF
+
+ CALL iom_put( "voce", vn(:,:,:) ) ! 3D j-current
+ CALL iom_put( "ssv", vn(:,:,1) ) ! surface j-current
+ IF ( iom_use("sbv") ) THEN
DO jj = 1, jpj
DO ji = 1, jpi
- z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal)**2 * fse3t_n(ji,jj,mikt(ji,jj))
- END DO
- END DO
- CALL iom_put( "sss2" , z2d(:,:) ) ! sea surface content of squared salinity
- ELSE
- CALL iom_put( "toce" , tsn(:,:,:,jp_tem) ) ! temperature
- IF ( iom_use("sst") ) THEN
- DO jj = 1, jpj
- DO ji = 1, jpi
- z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_tem)
- END DO
- END DO
- CALL iom_put( "sst" , z2d(:,:) ) ! sea surface temperature
- ENDIF
- IF ( iom_use("sst2") ) CALL iom_put( "sst2" , z2d(:,:) * z2d(:,:) ) ! square of sea surface temperature
- CALL iom_put( "soce" , tsn(:,:,:,jp_sal) ) ! salinity
- IF ( iom_use("sss") ) THEN
- DO jj = 1, jpj
- DO ji = 1, jpi
- z2d(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal)
- END DO
- END DO
- CALL iom_put( "sss" , z2d(:,:) ) ! sea surface salinity
- ENDIF
- CALL iom_put( "sss2" , z2d(:,:) * z2d(:,:) ) ! square of sea surface salinity
- END IF
- IF( lk_vvl .AND. (.NOT. ln_dynadv_vec) ) THEN
- CALL iom_put( "uoce" , umask(:,:,:) * un(:,:,:) * fse3u_n(:,:,:) ) ! i-transport
- CALL iom_put( "voce" , vmask(:,:,:) * vn(:,:,:) * fse3v_n(:,:,:) ) ! j-transport
- ELSE
- CALL iom_put( "uoce" , umask(:,:,:) * un(:,:,:) ) ! i-current
- CALL iom_put( "voce" , vmask(:,:,:) * vn(:,:,:) ) ! j-current
- IF ( iom_use("ssu") ) THEN
- DO jj = 1, jpj
- DO ji = 1, jpi
- z2d(ji,jj) = un(ji,jj,miku(ji,jj))
- END DO
- END DO
- CALL iom_put( "ssu" , z2d ) ! i-current
- ENDIF
- IF ( iom_use("ssv") ) THEN
- DO jj = 1, jpj
- DO ji = 1, jpi
- z2d(ji,jj) = vn(ji,jj,mikv(ji,jj))
- END DO
- END DO
- CALL iom_put( "ssv" , z2d ) ! j-current
- ENDIF
- ENDIF
- CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef.
- CALL iom_put( "avm" , avmu ) ! T vert. eddy visc. coef.
- IF( lk_zdfddm ) THEN
- CALL iom_put( "avs" , fsavs(:,:,:) ) ! S vert. eddy diff. coef.
- ENDIF
-
- IF ( iom_use("sstgrad2") .OR. iom_use("sstgrad2") ) THEN
+ z2d(ji,jj) = vn(ji,jj,MAX(mbathy(ji,jj),1))
+ END DO
+ END DO
+ CALL iom_put( "sbv", z2d ) ! bottom j-current
+ ENDIF
+
+ CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef.
+ CALL iom_put( "avm" , avmu ) ! T vert. eddy visc. coef.
+ CALL iom_put( "avs" , fsavs(:,:,:) ) ! S vert. eddy diff. coef. (useful only with key_zdfddm)
+
+ IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN
DO jj = 2, jpjm1 ! sst gradient
DO ji = fs_2, fs_jpim1 ! vector opt.
@@ -234,5 +209,4 @@
CALL lbc_lnk( z2d, 'T', 1. )
CALL iom_put( "sstgrad2", z2d ) ! square of module of sst gradient
- !CDIR NOVERRCHK<
z2d(:,:) = SQRT( z2d(:,:) )
CALL iom_put( "sstgrad" , z2d ) ! module of sst gradient
@@ -243,11 +217,10 @@
z2d(:,:) = 0._wp
DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
+ DO jj = 1, jpj
+ DO ji = 1, jpi
z2d(ji,jj) = z2d(ji,jj) + fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk)
END DO
END DO
END DO
- CALL lbc_lnk( z2d, 'T', 1. )
CALL iom_put( "heatc", (rau0 * rcp) * z2d ) ! vertically integrated heat content (J/m2)
ENDIF
@@ -256,11 +229,10 @@
z2d(:,:) = 0._wp
DO jk = 1, jpkm1
- DO jj = 2, jpjm1
- DO ji = fs_2, fs_jpim1 ! vector opt.
+ DO jj = 1, jpj
+ DO ji = 1, jpi
z2d(ji,jj) = z2d(ji,jj) + fse3t(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk)
END DO
END DO
END DO
- CALL lbc_lnk( z2d, 'T', 1. )
CALL iom_put( "saltc", rau0 * z2d ) ! vertically integrated salt content (PSU*kg/m2)
ENDIF
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90 (revision 5214)
@@ -588,11 +588,8 @@
INTEGER, INTENT( in ) :: kt ! time step
!! * Local declarations
- REAL(wp), POINTER, DIMENSION(:,:,:) :: z_e3t_def
INTEGER :: ji,jj,jk ! dummy loop indices
!!----------------------------------------------------------------------
IF( nn_timing == 1 ) CALL timing_start('dom_vvl_sf_swp')
- !
- CALL wrk_alloc( jpi, jpj, jpk, z_e3t_def )
!
IF( kt == nit000 ) THEN
@@ -679,14 +676,15 @@
! Write outputs
! =============
- z_e3t_def(:,:,:) = ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2
- CALL iom_put( "cellthc" , fse3t_n (:,:,:) )
+ CALL iom_put( "e3t" , fse3t_n (:,:,:) )
+ CALL iom_put( "e3u" , fse3u_n (:,:,:) )
+ CALL iom_put( "e3v" , fse3v_n (:,:,:) )
+ CALL iom_put( "e3w" , fse3w_n (:,:,:) )
CALL iom_put( "tpt_dep" , fsde3w_n (:,:,:) )
- CALL iom_put( "e3tdef" , z_e3t_def(:,:,:) )
+ IF( iom_use("e3tdef") ) &
+ CALL iom_put( "e3tdef" , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )
! write restart file
! ==================
IF( lrst_oce ) CALL dom_vvl_rst( kt, 'WRITE' )
- !
- CALL wrk_dealloc( jpi, jpj, jpk, z_e3t_def )
!
IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_sf_swp')
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90 (revision 5214)
@@ -365,16 +365,14 @@
INTEGER :: ji, jj, jl, jk ! dummy loop indices
INTEGER :: inum ! temporary logical unit
+ INTEGER :: ierror ! error flag
INTEGER :: ii_bump, ij_bump, ih ! bump center position
INTEGER :: ii0, ii1, ij0, ij1, ik ! local indices
REAL(wp) :: r_bump , h_bump , h_oce ! bump characteristics
REAL(wp) :: zi, zj, zh, zhmin ! local scalars
- INTEGER , POINTER, DIMENSION(:,:) :: idta ! global domain integer data
- REAL(wp), POINTER, DIMENSION(:,:) :: zdta ! global domain scalar data
+ INTEGER , ALLOCATABLE, DIMENSION(:,:) :: idta ! global domain integer data
+ REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdta ! global domain scalar data
!!----------------------------------------------------------------------
!
IF( nn_timing == 1 ) CALL timing_start('zgr_bat')
- !
- CALL wrk_alloc( jpidta, jpjdta, idta )
- CALL wrk_alloc( jpidta, jpjdta, zdta )
!
IF(lwp) WRITE(numout,*)
@@ -385,4 +383,9 @@
! ! ================== !
! ! global domain level and meter bathymetry (idta,zdta)
+ !
+ ALLOCATE( idta(jpidta,jpjdta), STAT=ierror )
+ IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'zgr_bat: unable to allocate idta array' )
+ ALLOCATE( zdta(jpidta,jpjdta), STAT=ierror )
+ IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'zgr_bat: unable to allocate zdta array' )
!
IF( ntopo == 0 ) THEN ! flat basin
@@ -489,4 +492,6 @@
WHERE( bathy(:,:) <= 0._wp ) risfdep(:,:) = 0._wp
END IF
+ !
+ DEALLOCATE( idta, zdta )
!
! ! ================ !
@@ -593,7 +598,4 @@
ENDIF
!
- CALL wrk_dealloc( jpidta, jpjdta, idta )
- CALL wrk_dealloc( jpidta, jpjdta, zdta )
- !
IF( nn_timing == 1 ) CALL timing_stop('zgr_bat')
!
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_ubs.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_ubs.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_ubs.F90 (revision 5214)
@@ -116,28 +116,25 @@
DO jj = 2, jpjm1 ! laplacian
DO ji = fs_2, fs_jpim1 ! vector opt.
- zlu_uu(ji,jj,jk,1) = ( ub (ji+1,jj,jk)-2.*ub (ji,jj,jk)+ub (ji-1,jj,jk) ) * umask(ji,jj,jk)
- zlv_vv(ji,jj,jk,1) = ( vb (ji,jj+1,jk)-2.*vb (ji,jj,jk)+vb (ji,jj-1,jk) ) * vmask(ji,jj,jk)
- zlu_uv(ji,jj,jk,1) = ( ub (ji,jj+1,jk)-2.*ub (ji,jj,jk)+ub (ji,jj-1,jk) ) * umask(ji,jj,jk)
- zlv_vu(ji,jj,jk,1) = ( vb (ji+1,jj,jk)-2.*vb (ji,jj,jk)+vb (ji-1,jj,jk) ) * vmask(ji,jj,jk)
- !
- zlu_uu(ji,jj,jk,2) = ( zfu(ji+1,jj,jk)-2.*zfu(ji,jj,jk)+zfu(ji-1,jj,jk) ) * umask(ji,jj,jk)
- zlv_vv(ji,jj,jk,2) = ( zfv(ji,jj+1,jk)-2.*zfv(ji,jj,jk)+zfv(ji,jj-1,jk) ) * vmask(ji,jj,jk)
- zlu_uv(ji,jj,jk,2) = ( zfu(ji,jj+1,jk)-2.*zfu(ji,jj,jk)+zfu(ji,jj-1,jk) ) * umask(ji,jj,jk)
- zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj,jk)-2.*zfv(ji,jj,jk)+zfv(ji-1,jj,jk) ) * vmask(ji,jj,jk)
- END DO
- END DO
- END DO
-!!gm BUG !!! just below this should be +1 in all the communications
-! CALL lbc_lnk( zlu_uu(:,:,:,1), 'U', -1.) ; CALL lbc_lnk( zlu_uv(:,:,:,1), 'U', -1.)
-! CALL lbc_lnk( zlu_uu(:,:,:,2), 'U', -1.) ; CALL lbc_lnk( zlu_uv(:,:,:,2), 'U', -1.)
-! CALL lbc_lnk( zlv_vv(:,:,:,1), 'V', -1.) ; CALL lbc_lnk( zlv_vu(:,:,:,1), 'V', -1.)
-! CALL lbc_lnk( zlv_vv(:,:,:,2), 'V', -1.) ; CALL lbc_lnk( zlv_vu(:,:,:,2), 'V', -1.)
-!
-!!gm corrected:
+ !
+ zlu_uu(ji,jj,jk,1) = ( ub (ji+1,jj ,jk) - 2.*ub (ji,jj,jk) + ub (ji-1,jj ,jk) ) * umask(ji,jj,jk)
+ zlv_vv(ji,jj,jk,1) = ( vb (ji ,jj+1,jk) - 2.*vb (ji,jj,jk) + vb (ji ,jj-1,jk) ) * vmask(ji,jj,jk)
+ zlu_uv(ji,jj,jk,1) = ( ub (ji ,jj+1,jk) - ub (ji ,jj ,jk) ) * fmask(ji ,jj ,jk) &
+ & - ( ub (ji ,jj ,jk) - ub (ji ,jj-1,jk) ) * fmask(ji ,jj-1,jk)
+ zlv_vu(ji,jj,jk,1) = ( vb (ji+1,jj ,jk) - vb (ji ,jj ,jk) ) * fmask(ji ,jj ,jk) &
+ & - ( vb (ji ,jj ,jk) - vb (ji-1,jj ,jk) ) * fmask(ji-1,jj ,jk)
+ !
+ zlu_uu(ji,jj,jk,2) = ( zfu(ji+1,jj ,jk) - 2.*zfu(ji,jj,jk) + zfu(ji-1,jj ,jk) ) * umask(ji,jj,jk)
+ zlv_vv(ji,jj,jk,2) = ( zfv(ji ,jj+1,jk) - 2.*zfv(ji,jj,jk) + zfv(ji ,jj-1,jk) ) * vmask(ji,jj,jk)
+ zlu_uv(ji,jj,jk,2) = ( zfu(ji ,jj+1,jk) - zfu(ji ,jj ,jk) ) * fmask(ji ,jj ,jk) &
+ & - ( zfu(ji ,jj ,jk) - zfu(ji ,jj-1,jk) ) * fmask(ji ,jj-1,jk)
+ zlv_vu(ji,jj,jk,2) = ( zfv(ji+1,jj ,jk) - zfv(ji ,jj ,jk) ) * fmask(ji ,jj ,jk) &
+ & - ( zfv(ji ,jj ,jk) - zfv(ji-1,jj ,jk) ) * fmask(ji-1,jj ,jk)
+ END DO
+ END DO
+ END DO
CALL lbc_lnk( zlu_uu(:,:,:,1), 'U', 1. ) ; CALL lbc_lnk( zlu_uv(:,:,:,1), 'U', 1. )
CALL lbc_lnk( zlu_uu(:,:,:,2), 'U', 1. ) ; CALL lbc_lnk( zlu_uv(:,:,:,2), 'U', 1. )
CALL lbc_lnk( zlv_vv(:,:,:,1), 'V', 1. ) ; CALL lbc_lnk( zlv_vu(:,:,:,1), 'V', 1. )
CALL lbc_lnk( zlv_vv(:,:,:,2), 'V', 1. ) ; CALL lbc_lnk( zlv_vu(:,:,:,2), 'V', 1. )
-!!gm end
! ! ====================== !
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90 (revision 5214)
@@ -97,6 +97,6 @@
ALLOCATE( wgtbtp1(3*nn_baro), wgtbtp2(3*nn_baro), zwz(jpi,jpj), STAT= ierr(2) )
- IF( ln_dynvor_een ) ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , &
- & ftsw(jpi,jpj) , ftse(jpi,jpj) , STAT=ierr(3) )
+ IF( ln_dynvor_een .or. ln_dynvor_een_old ) ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , &
+ & ftsw(jpi,jpj) , ftse(jpi,jpj) , STAT=ierr(3) )
dyn_spg_ts_alloc = MAXVAL(ierr(:))
@@ -218,5 +218,25 @@
!
IF ( kt == nit000 .OR. lk_vvl ) THEN
- IF ( ln_dynvor_een ) THEN
+ IF ( ln_dynvor_een_old ) THEN
+ DO jj = 1, jpjm1
+ DO ji = 1, jpim1
+ zwz(ji,jj) = ( ht(ji ,jj+1) + ht(ji+1,jj+1) + &
+ & ht(ji ,jj ) + ht(ji+1,jj ) ) / 4._wp
+ IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zwz(ji,jj)
+ END DO
+ END DO
+ CALL lbc_lnk( zwz, 'F', 1._wp )
+ zwz(:,:) = ff(:,:) * zwz(:,:)
+
+ ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp
+ DO jj = 2, jpj
+ DO ji = fs_2, jpi ! vector opt.
+ ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1)
+ ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj )
+ ftse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1)
+ ftsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj )
+ END DO
+ END DO
+ ELSE IF ( ln_dynvor_een ) THEN
DO jj = 1, jpjm1
DO ji = 1, jpim1
@@ -339,5 +359,5 @@
END DO
!
- ELSEIF ( ln_dynvor_een ) THEN ! enstrophy and energy conserving scheme
+ ELSEIF ( ln_dynvor_een .or. ln_dynvor_een_old ) THEN ! enstrophy and energy conserving scheme
DO jj = 2, jpjm1
DO ji = fs_2, fs_jpim1 ! vector opt.
@@ -687,5 +707,5 @@
END DO
!
- ELSEIF ( ln_dynvor_een ) THEN !== energy and enstrophy conserving scheme ==!
+ ELSEIF ( ln_dynvor_een .or. ln_dynvor_een_old ) THEN !== energy and enstrophy conserving scheme ==!
DO jj = 2, jpjm1
DO ji = fs_2, fs_jpim1 ! vector opt.
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90 (revision 5214)
@@ -51,4 +51,5 @@
LOGICAL, PUBLIC :: ln_dynvor_mix !: mixed scheme
LOGICAL, PUBLIC :: ln_dynvor_een !: energy and enstrophy conserving scheme
+ LOGICAL, PUBLIC :: ln_dynvor_een_old !: energy and enstrophy conserving scheme (original formulation)
INTEGER :: nvor = 0 ! type of vorticity trend used
@@ -596,15 +597,29 @@
IF( kt == nit000 .OR. lk_vvl ) THEN ! reciprocal of e3 at F-point (masked averaging of e3t over ocean points)
- DO jk = 1, jpk
- DO jj = 1, jpjm1
- DO ji = 1, jpim1
- ze3 = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) &
- & + fse3t(ji,jj ,jk)*tmask(ji,jj ,jk) + fse3t(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) )
- zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
- & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) )
- IF( ze3 /= 0._wp ) ze3f(ji,jj,jk) = zmsk / ze3
- END DO
- END DO
- END DO
+
+ IF( ln_dynvor_een_old ) THEN ! original formulation
+ DO jk = 1, jpk
+ DO jj = 1, jpjm1
+ DO ji = 1, jpim1
+ ze3 = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) &
+ & + fse3t(ji,jj ,jk)*tmask(ji,jj ,jk) + fse3t(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) )
+ IF( ze3 /= 0._wp ) ze3f(ji,jj,jk) = 4.0_wp / ze3
+ END DO
+ END DO
+ END DO
+ ELSE ! new formulation from NEMO 3.6
+ DO jk = 1, jpk
+ DO jj = 1, jpjm1
+ DO ji = 1, jpim1
+ ze3 = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) &
+ & + fse3t(ji,jj ,jk)*tmask(ji,jj ,jk) + fse3t(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) )
+ zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
+ & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) )
+ IF( ze3 /= 0._wp ) ze3f(ji,jj,jk) = zmsk / ze3
+ END DO
+ END DO
+ END DO
+ ENDIF
+
CALL lbc_lnk( ze3f, 'F', 1. )
ENDIF
@@ -705,5 +720,5 @@
INTEGER :: ios ! Local integer output status for namelist read
!!
- NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_mix, ln_dynvor_een
+ NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_mix, ln_dynvor_een, ln_dynvor_een_old
!!----------------------------------------------------------------------
@@ -726,4 +741,5 @@
WRITE(numout,*) ' mixed enstrophy/energy conserving scheme ln_dynvor_mix = ', ln_dynvor_mix
WRITE(numout,*) ' enstrophy and energy conserving scheme ln_dynvor_een = ', ln_dynvor_een
+ WRITE(numout,*) ' enstrophy and energy conserving scheme (old) ln_dynvor_een_old= ', ln_dynvor_een_old
ENDIF
@@ -749,4 +765,5 @@
IF( ln_dynvor_mix ) ioptio = ioptio + 1
IF( ln_dynvor_een ) ioptio = ioptio + 1
+ IF( ln_dynvor_een_old ) ioptio = ioptio + 1
IF( lk_esopa ) ioptio = 1
@@ -757,5 +774,5 @@
IF( ln_dynvor_ens ) nvor = 1
IF( ln_dynvor_mix ) nvor = 2
- IF( ln_dynvor_een ) nvor = 3
+ IF( ln_dynvor_een .or. ln_dynvor_een_old ) nvor = 3
IF( lk_esopa ) nvor = -1
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90 (revision 5214)
@@ -1202,5 +1202,5 @@
CASE('T') ; zmask(:,:,:) = tmask(:,:,:)
CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( zmask, 'U', 1. )
- CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpi,:) ; CALL lbc_lnk( zmask, 'V', 1. )
+ CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( zmask, 'V', 1. )
CASE('W') ; zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) ; zmask(:,:,1) = tmask(:,:,1)
END SELECT
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90 (revision 5214)
@@ -164,10 +164,12 @@
ENDIF
- IF ( clinfo3 == 'tra' ) THEN
- zvctl1 = t_ctll(jn)
- zvctl2 = s_ctll(jn)
- ELSEIF ( clinfo3 == 'dyn' ) THEN
- zvctl1 = u_ctll(jn)
- zvctl2 = v_ctll(jn)
+ IF( PRESENT(clinfo3)) THEN
+ IF ( clinfo3 == 'tra' ) THEN
+ zvctl1 = t_ctll(jn)
+ zvctl2 = s_ctll(jn)
+ ELSEIF ( clinfo3 == 'dyn' ) THEN
+ zvctl1 = u_ctll(jn)
+ zvctl2 = v_ctll(jn)
+ ENDIF
ENDIF
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c2d.h90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c2d.h90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c2d.h90 (revision 5214)
@@ -146,13 +146,12 @@
INTEGER :: inum, iim, ijm ! local integers
INTEGER :: ifreq, il1, il2, ij, ii
- INTEGER :: ijpt0,ijpt1
+ INTEGER :: ijpt0,ijpt1, ierror
REAL(wp) :: zahmeq, zcoft, zcoff, zmsk
CHARACTER (len=15) :: clexp
- INTEGER, POINTER, DIMENSION(:,:) :: icof
- INTEGER, POINTER, DIMENSION(:,:) :: idata
+ INTEGER, POINTER, DIMENSION(:,:) :: icof
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: idata
!!----------------------------------------------------------------------
!
CALL wrk_alloc( jpi , jpj , icof )
- CALL wrk_alloc( jpidta, jpjdta, idata )
!
IF(lwp) WRITE(numout,*)
@@ -234,4 +233,7 @@
! ===================== equatorial strip (20N-20S) defined at t-points
+ ALLOCATE( idata(jpidta,jpjdta), STAT=ierror )
+ IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_c2d_orca: unable to allocate idata array' )
+ !
CALL ctl_opn( inum, 'ahmcoef', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp )
READ(inum,9101) clexp, iim, ijm
@@ -269,5 +271,6 @@
9201 FORMAT(3x,13(i3,12x))
9202 FORMAT(i3,41i3)
-
+
+ DEALLOCATE(idata)
! Set ahm1 and ahm2 ( T- and F- points) (used for laplacian operator)
@@ -346,5 +349,4 @@
!
CALL wrk_dealloc( jpi , jpj , icof )
- CALL wrk_dealloc( jpidta, jpjdta, idata )
!
END SUBROUTINE ldf_dyn_c2d_orca
@@ -374,13 +376,12 @@
INTEGER :: iim, ijm
INTEGER :: ifreq, il1, il2, ij, ii
- INTEGER :: ijpt0,ijpt1
+ INTEGER :: ijpt0,ijpt1, ierror
REAL(wp) :: zahmeq, zcoft, zcoff, zmsk, zam20s
CHARACTER (len=15) :: clexp
- INTEGER, POINTER, DIMENSION(:,:) :: icof
- INTEGER, POINTER, DIMENSION(:,:) :: idata
+ INTEGER, POINTER, DIMENSION(:,:) :: icof
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: idata
!!----------------------------------------------------------------------
!
CALL wrk_alloc( jpi , jpj , icof )
- CALL wrk_alloc( jpidta, jpjdta, idata )
!
@@ -464,4 +465,7 @@
! ===================== equatorial strip (20N-20S) defined at t-points
+ ALLOCATE( idata(jpidta,jpjdta), STAT=ierror )
+ IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'ldf_dyn_c2d_orca_R1: unable to allocate idata array' )
+ !
CALL ctl_opn( inum, 'ahmcoef', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', &
& 1, numout, lwp )
@@ -501,5 +505,6 @@
9201 FORMAT(3x,13(i3,12x))
9202 FORMAT(i3,41i3)
-
+
+ DEALLOCATE(idata)
! Set ahm1 and ahm2 ( T- and F- points) (used for laplacian operator)
@@ -583,5 +588,4 @@
!
CALL wrk_dealloc( jpi , jpj , icof )
- CALL wrk_dealloc( jpidta, jpjdta, idata )
!
END SUBROUTINE ldf_dyn_c2d_orca_R1
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90 (revision 5214)
@@ -848,5 +848,5 @@
rgt33 = 0.5_wp + SIGN( 0.5_wp, (zw10 - 33._wp) ) ! If zw10 < 33. => 0, else => 1
cd_neutral_10m = 1.e-3 * ( &
- & (rgt33 + 1._wp)*( 2.7_wp/zw10 + 0.142_wp + zw10/13.09_wp - 3.14807E-10*zw10**6) & ! zw10< 33.
+ & (1._wp - rgt33)*( 2.7_wp/zw10 + 0.142_wp + zw10/13.09_wp - 3.14807E-10*zw10**6) & ! zw10< 33.
& + rgt33 * 2.34 ) ! zw10 >= 33.
!
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90 (revision 5214)
@@ -21,7 +21,4 @@
!! tra_dmp : update the tracer trend with the internal damping
!! tra_dmp_init : initialization, namlist read, parameters control
- !! dtacof_zoom : restoring coefficient for zoom domain
- !! dtacof : restoring coefficient for global domain
- !! cofdis : compute the distance to the coastline
!!----------------------------------------------------------------------
USE oce ! ocean: variables
@@ -39,4 +36,5 @@
USE wrk_nemo ! Memory allocation
USE timing ! Timing
+ USE iom
IMPLICIT NONE
@@ -45,17 +43,12 @@
PUBLIC tra_dmp ! routine called by step.F90
PUBLIC tra_dmp_init ! routine called by opa.F90
- PUBLIC dtacof ! routine called by tradmp.F90, trcdmp.F90 and dyndmp.F90
- PUBLIC dtacof_zoom ! routine called by tradmp.F90, trcdmp.F90 and dyndmp.F90
-
-!!gm why all namelist variable public???? only ln_tradmp should be sufficient
! !!* Namelist namtra_dmp : T & S newtonian damping *
+ ! nn_zdmp and cn_resto are public as they are used by C1D/dyndmp.F90
LOGICAL , PUBLIC :: ln_tradmp !: internal damping flag
- INTEGER , PUBLIC :: nn_hdmp ! = 0/-1/'latitude' for damping over T and S
INTEGER , PUBLIC :: nn_zdmp ! = 0/1/2 flag for damping in the mixed layer
- REAL(wp), PUBLIC :: rn_surf ! surface time scale for internal damping [days]
- REAL(wp), PUBLIC :: rn_bot ! bottom time scale for internal damping [days]
- REAL(wp), PUBLIC :: rn_dep ! depth of transition between rn_surf and rn_bot [meters]
- INTEGER , PUBLIC :: nn_file ! = 1 create a damping.coeff NetCDF file
+ CHARACTER(LEN=200) , PUBLIC :: cn_resto ! name of netcdf file containing restoration coefficient field
+ !
+
REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: strdmp !: damping salinity trend (psu/s)
@@ -197,623 +190,60 @@
!! ** Method : read the namtra_dmp namelist and check the parameters
!!----------------------------------------------------------------------
- INTEGER :: ios ! Local integer output status for namelist read
- !!
- NAMELIST/namtra_dmp/ ln_tradmp, nn_hdmp, nn_zdmp, rn_surf, rn_bot, rn_dep, nn_file
- !!----------------------------------------------------------------------
- !
- REWIND( numnam_ref ) ! Namelist namtra_dmp in reference namelist : Temperature and salinity damping term
+ NAMELIST/namtra_dmp/ ln_tradmp, nn_zdmp, cn_resto
+ INTEGER :: ios ! Local integer for output status of namelist read
+ INTEGER :: imask ! File handle
+ !!
+ !!----------------------------------------------------------------------
+ !
+ REWIND( numnam_ref ) ! Namelist namtra_dmp in reference namelist : T & S relaxation
READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901)
901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist', lwp )
!
- REWIND( numnam_cfg ) ! Namelist namtra_dmp in configuration namelist : Temperature and salinity damping term
+ REWIND( numnam_cfg ) ! Namelist namtra_dmp in configuration namelist : T & S relaxation
READ ( numnam_cfg, namtra_dmp, IOSTAT = ios, ERR = 902 )
902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in configuration namelist', lwp )
IF(lwm) WRITE ( numond, namtra_dmp )
-
- IF( lzoom .AND. .NOT. lk_c1d ) nn_zdmp = 0 ! restoring to climatology at closed north or south boundaries
-
- IF(lwp) THEN ! Namelist print
+
+ IF(lwp) THEN !Namelist print
WRITE(numout,*)
- WRITE(numout,*) 'tra_dmp_init : T and S newtonian damping'
+ WRITE(numout,*) 'tra_dmp_init : T and S newtonian relaxation'
WRITE(numout,*) '~~~~~~~'
- WRITE(numout,*) ' Namelist namtra_dmp : set damping parameter'
- WRITE(numout,*) ' add a damping term or not ln_tradmp = ', ln_tradmp
- WRITE(numout,*) ' T and S damping option nn_hdmp = ', nn_hdmp
- WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp, '(non-C1D zoom: forced to 0)'
- WRITE(numout,*) ' surface time scale (days) rn_surf = ', rn_surf
- WRITE(numout,*) ' bottom time scale (days) rn_bot = ', rn_bot
- WRITE(numout,*) ' depth of transition (meters) rn_dep = ', rn_dep
- WRITE(numout,*) ' create a damping.coeff file nn_file = ', nn_file
+ WRITE(numout,*) ' Namelist namtra_dmp : set relaxation parameters'
+ WRITE(numout,*) ' Apply relaxation or not ln_tradmp = ', ln_tradmp
+ WRITE(numout,*) ' mixed layer damping option nn_zdmp = ', nn_zdmp
+ WRITE(numout,*) ' Damping file name cn_resto = ', cn_resto
WRITE(numout,*)
ENDIF
- IF( ln_tradmp ) THEN ! initialization for T-S damping
- !
+ IF( ln_tradmp) THEN
+ !
+ !Allocate arrays
IF( tra_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'tra_dmp_init: unable to allocate arrays' )
- !
-!!gm I don't understand the specificities of c1d case......
-!!gm to be check with the autor of these lines
-
-#if ! defined key_c1d
- SELECT CASE ( nn_hdmp )
- CASE ( -1 ) ; IF(lwp) WRITE(numout,*) ' tracer damping in the Med & Red seas only'
- CASE ( 1:90 ) ; IF(lwp) WRITE(numout,*) ' tracer damping poleward of', nn_hdmp, ' degrees'
- CASE DEFAULT
- WRITE(ctmp1,*) ' bad flag value for nn_hdmp = ', nn_hdmp
- CALL ctl_stop(ctmp1)
+
+ !Check values of nn_zdmp
+ SELECT CASE (nn_zdmp)
+ CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' tracer damping as specified by mask'
+ CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the turbocline'
+ CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixed layer'
END SELECT
- !
-#endif
- SELECT CASE ( nn_zdmp )
- CASE ( 0 ) ; IF(lwp) WRITE(numout,*) ' tracer damping throughout the water column'
- CASE ( 1 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the turbocline (avt > 5 cm2/s)'
- CASE ( 2 ) ; IF(lwp) WRITE(numout,*) ' no tracer damping in the mixed layer'
- CASE DEFAULT
- WRITE(ctmp1,*) 'bad flag value for nn_zdmp = ', nn_zdmp
- CALL ctl_stop(ctmp1)
- END SELECT
- !
+
+ !TG: Initialisation of dtatsd - Would it be better to have dmpdta routine
+ !so can damp to something other than intitial conditions files?
IF( .NOT.ln_tsd_tradmp ) THEN
CALL ctl_warn( 'tra_dmp_init: read T-S data not initialized, we force ln_tsd_tradmp=T' )
CALL dta_tsd_init( ld_tradmp=ln_tradmp ) ! forces the initialisation of T-S data
ENDIF
- !
- strdmp(:,:,:) = 0._wp ! internal damping salinity trend (used in asmtrj)
+
+ !initialise arrays - Are these actually used anywhere else?
+ strdmp(:,:,:) = 0._wp
ttrdmp(:,:,:) = 0._wp
- ! ! Damping coefficients initialization
- IF( lzoom .AND. .NOT. lk_c1d ) THEN ; CALL dtacof_zoom( resto )
- ELSE ; CALL dtacof( nn_hdmp, rn_surf, rn_bot, rn_dep, nn_file, 'TRA', resto )
- ENDIF
- !
- ENDIF
- !
+
+ !Read in mask from file
+ CALL iom_open ( cn_resto, imask)
+ CALL iom_get ( imask, jpdom_autoglo, 'resto', resto)
+ CALL iom_close( imask )
+ ENDIF
+
END SUBROUTINE tra_dmp_init
-
- SUBROUTINE dtacof_zoom( presto )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dtacof_zoom ***
- !!
- !! ** Purpose : Compute the damping coefficient for zoom domain
- !!
- !! ** Method : - set along closed boundary due to zoom a damping over
- !! 6 points with a max time scale of 5 days.
- !! - ORCA arctic/antarctic zoom: set the damping along
- !! south/north boundary over a latitude strip.
- !!
- !! ** Action : - resto, the damping coeff. for T and S
- !!----------------------------------------------------------------------
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: presto ! restoring coeff. (s-1)
- !
- INTEGER :: ji, jj, jk, jn ! dummy loop indices
- REAL(wp) :: zlat, zlat0, zlat1, zlat2, z1_5d ! local scalar
- REAL(wp), DIMENSION(6) :: zfact ! 1Dworkspace
- !!----------------------------------------------------------------------
- !
- IF( nn_timing == 1 ) CALL timing_start( 'dtacof_zoom')
- !
-
- zfact(1) = 1._wp
- zfact(2) = 1._wp
- zfact(3) = 11._wp / 12._wp
- zfact(4) = 8._wp / 12._wp
- zfact(5) = 4._wp / 12._wp
- zfact(6) = 1._wp / 12._wp
- zfact(:) = zfact(:) / ( 5._wp * rday ) ! 5 days max restoring time scale
-
- presto(:,:,:) = 0._wp
-
- ! damping along the forced closed boundary over 6 grid-points
- DO jn = 1, 6
- IF( lzoom_w ) presto( mi0(jn+jpizoom):mi1(jn+jpizoom), : , : ) = zfact(jn) ! west closed
- IF( lzoom_s ) presto( : , mj0(jn+jpjzoom):mj1(jn+jpjzoom), : ) = zfact(jn) ! south closed
- IF( lzoom_e ) presto( mi0(jpiglo+jpizoom-1-jn):mi1(jpiglo+jpizoom-1-jn) , : , : ) = zfact(jn) ! east closed
- IF( lzoom_n ) presto( : , mj0(jpjglo+jpjzoom-1-jn):mj1(jpjglo+jpjzoom-1-jn) , : ) = zfact(jn) ! north closed
- END DO
-
- ! ! ====================================================
- IF( cp_cfz == "arctic" .OR. cp_cfz == "antarctic" ) THEN ! ORCA configuration : arctic or antarctic zoom
- ! ! ====================================================
- IF(lwp) WRITE(numout,*)
- IF(lwp .AND. cp_cfz == "arctic" ) WRITE(numout,*) ' dtacof_zoom : ORCA Arctic zoom'
- IF(lwp .AND. cp_cfz == "antarctic" ) WRITE(numout,*) ' dtacof_zoom : ORCA Antarctic zoom'
- IF(lwp) WRITE(numout,*)
- !
- ! ! Initialization :
- presto(:,:,:) = 0._wp
- zlat0 = 10._wp ! zlat0 : latitude strip where resto decreases
- zlat1 = 30._wp ! zlat1 : resto = 1 before zlat1
- zlat2 = zlat1 + zlat0 ! zlat2 : resto decreases from 1 to 0 between zlat1 and zlat2
- z1_5d = 1._wp / ( 5._wp * rday ) ! z1_5d : 1 / 5days
-
- DO jk = 2, jpkm1 ! Compute arrays resto ; value for internal damping : 5 days
- DO jj = 1, jpj
- DO ji = 1, jpi
- zlat = ABS( gphit(ji,jj) )
- IF( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN
- presto(ji,jj,jk) = 0.5_wp * z1_5d * ( 1._wp - COS( rpi*(zlat2-zlat)/zlat0 ) )
- ELSEIF( zlat < zlat1 ) THEN
- presto(ji,jj,jk) = z1_5d
- ENDIF
- END DO
- END DO
- END DO
- !
- ENDIF
- ! ! Mask resto array
- presto(:,:,:) = presto(:,:,:) * tmask(:,:,:)
- !
- IF( nn_timing == 1 ) CALL timing_stop( 'dtacof_zoom')
- !
- END SUBROUTINE dtacof_zoom
-
-
- SUBROUTINE dtacof( kn_hdmp, pn_surf, pn_bot, pn_dep, &
- & kn_file, cdtype , presto )
- !!----------------------------------------------------------------------
- !! *** ROUTINE dtacof ***
- !!
- !! ** Purpose : Compute the damping coefficient
- !!
- !! ** Method : Arrays defining the damping are computed for each grid
- !! point for temperature and salinity (resto)
- !! Damping depends on distance to coast, depth and latitude
- !!
- !! ** Action : - resto, the damping coeff. for T and S
- !!----------------------------------------------------------------------
- USE iom
- USE ioipsl
- !!
- INTEGER , INTENT(in ) :: kn_hdmp ! damping option
- REAL(wp) , INTENT(in ) :: pn_surf ! surface time scale (days)
- REAL(wp) , INTENT(in ) :: pn_bot ! bottom time scale (days)
- REAL(wp) , INTENT(in ) :: pn_dep ! depth of transition (meters)
- INTEGER , INTENT(in ) :: kn_file ! save the damping coef on a file or not
- CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA, TRC or DYN (tracer/dynamics indicator)
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: presto ! restoring coeff. (s-1)
- !
- INTEGER :: ji, jj, jk ! dummy loop indices
- INTEGER :: ii0, ii1, ij0, ij1 ! local integers
- INTEGER :: inum0, icot ! - -
- REAL(wp) :: zinfl, zlon ! local scalars
- REAL(wp) :: zlat, zlat0, zlat1, zlat2 ! - -
- REAL(wp) :: zsdmp, zbdmp ! - -
- CHARACTER(len=20) :: cfile
- REAL(wp), POINTER, DIMENSION(: ) :: zhfac
- REAL(wp), POINTER, DIMENSION(:,: ) :: zmrs
- REAL(wp), POINTER, DIMENSION(:,:,:) :: zdct
- !!----------------------------------------------------------------------
- !
- IF( nn_timing == 1 ) CALL timing_start('dtacof')
- !
- CALL wrk_alloc( jpk, zhfac )
- CALL wrk_alloc( jpi, jpj, zmrs )
- CALL wrk_alloc( jpi, jpj, jpk, zdct )
-#if defined key_c1d
- ! ! ====================
- ! ! C1D configuration : local domain
- ! ! ====================
- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) ' dtacof : C1D 3x3 local domain'
- IF(lwp) WRITE(numout,*) ' -----------------------------'
- !
- presto(:,:,:) = 0._wp
- !
- zsdmp = 1._wp / ( pn_surf * rday )
- zbdmp = 1._wp / ( pn_bot * rday )
- DO jk = 2, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- ! ONLY vertical variation from zsdmp (sea surface) to zbdmp (bottom)
- presto(ji,jj,jk) = zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(ji,jj,jk)/pn_dep)
- END DO
- END DO
- END DO
- !
- presto(:,:, : ) = presto(:,:,:) * tmask(:,:,:)
-#else
- ! ! ====================
- ! ! ORCA configuration : global domain
- ! ! ====================
- !
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) ' dtacof : Global domain of ORCA'
- IF(lwp) WRITE(numout,*) ' ------------------------------'
- !
- presto(:,:,:) = 0._wp
- !
- IF( kn_hdmp > 0 ) THEN ! Damping poleward of 'nn_hdmp' degrees !
- ! !-----------------------------------------!
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) ' Damping poleward of ', kn_hdmp, ' deg.'
- !
- CALL iom_open ( 'dist.coast.nc', icot, ldstop = .FALSE. )
- !
- IF( icot > 0 ) THEN ! distance-to-coast read in file
- CALL iom_get ( icot, jpdom_data, 'Tcoast', zdct )
- CALL iom_close( icot )
- ELSE ! distance-to-coast computed and saved in file (output in zdct)
- CALL cofdis( zdct )
- ENDIF
-
- ! ! Compute arrays resto
- zinfl = 1000.e3_wp ! distance of influence for damping term
- zlat0 = 10._wp ! latitude strip where resto decreases
- zlat1 = REAL( kn_hdmp ) ! resto = 0 between -zlat1 and zlat1
- zlat2 = zlat1 + zlat0 ! resto increases from 0 to 1 between |zlat1| and |zlat2|
-
- DO jj = 1, jpj
- DO ji = 1, jpi
- zlat = ABS( gphit(ji,jj) )
- IF ( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN
- presto(ji,jj,1) = 0.5_wp * ( 1._wp - COS( rpi*(zlat-zlat1)/zlat0 ) )
- ELSEIF ( zlat > zlat2 ) THEN
- presto(ji,jj,1) = 1._wp
- ENDIF
- END DO
- END DO
-
- IF ( kn_hdmp == 20 ) THEN ! North Indian ocean (20N/30N x 45E/100E) : resto=0
- DO jj = 1, jpj
- DO ji = 1, jpi
- zlat = gphit(ji,jj)
- zlon = MOD( glamt(ji,jj), 360._wp )
- IF ( zlat1 < zlat .AND. zlat < zlat2 .AND. 45._wp < zlon .AND. zlon < 100._wp ) THEN
- presto(ji,jj,1) = 0._wp
- ENDIF
- END DO
- END DO
- ENDIF
-
- zsdmp = 1._wp / ( pn_surf * rday )
- zbdmp = 1._wp / ( pn_bot * rday )
- DO jk = 2, jpkm1
- DO jj = 1, jpj
- DO ji = 1, jpi
- zdct(ji,jj,jk) = MIN( zinfl, zdct(ji,jj,jk) )
- ! ... Decrease the value in the vicinity of the coast
- presto(ji,jj,jk) = presto(ji,jj,1 ) * 0.5_wp * ( 1._wp - COS( rpi*zdct(ji,jj,jk)/zinfl) )
- ! ... Vertical variation from zsdmp (sea surface) to zbdmp (bottom)
- presto(ji,jj,jk) = presto(ji,jj,jk) * ( zbdmp + (zsdmp-zbdmp) * EXP(-fsdept(ji,jj,jk)/pn_dep) )
- END DO
- END DO
- END DO
- !
- ENDIF
-
- ! ! =========================
- ! ! Med and Red Sea damping (ORCA configuration only)
- ! ! =========================
- IF( cp_cfg == "orca" .AND. ( kn_hdmp > 0 .OR. kn_hdmp == -1 ) ) THEN
- IF(lwp)WRITE(numout,*)
- IF(lwp)WRITE(numout,*) ' ORCA configuration: Damping in Med and Red Seas'
- !
- zmrs(:,:) = 0._wp
- !
- SELECT CASE ( jp_cfg )
- ! ! =======================
- CASE ( 4 ) ! ORCA_R4 configuration
- ! ! =======================
- ij0 = 50 ; ij1 = 56 ! Mediterranean Sea
-
- ii0 = 81 ; ii1 = 91 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- ij0 = 50 ; ij1 = 55
- ii0 = 75 ; ii1 = 80 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- ij0 = 52 ; ij1 = 53
- ii0 = 70 ; ii1 = 74 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- ! Smooth transition from 0 at surface to 1./rday at the 18th level in Med and Red Sea
- DO jk = 1, 17
- zhfac (jk) = 0.5_wp * ( 1._wp - COS( rpi * REAL(jk-1,wp) / 16._wp ) ) / rday
- END DO
- DO jk = 18, jpkm1
- zhfac (jk) = 1._wp / rday
- END DO
- ! ! =======================
- CASE ( 2 ) ! ORCA_R2 configuration
- ! ! =======================
- ij0 = 96 ; ij1 = 110 ! Mediterranean Sea
- ii0 = 157 ; ii1 = 181 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- ij0 = 100 ; ij1 = 110
- ii0 = 144 ; ii1 = 156 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- ij0 = 100 ; ij1 = 103
- ii0 = 139 ; ii1 = 143 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- !
- ij0 = 101 ; ij1 = 102 ! Decrease before Gibraltar Strait
- ii0 = 139 ; ii1 = 141 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0._wp
- ii0 = 142 ; ii1 = 142 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp
- ii0 = 143 ; ii1 = 143 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp
- ii0 = 144 ; ii1 = 144 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.75_wp
- !
- ij0 = 87 ; ij1 = 96 ! Red Sea
- ii0 = 147 ; ii1 = 163 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- !
- ij0 = 91 ; ij1 = 91 ! Decrease before Bab el Mandeb Strait
- ii0 = 153 ; ii1 = 160 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.80_wp
- ij0 = 90 ; ij1 = 90
- ii0 = 153 ; ii1 = 160 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp
- ij0 = 89 ; ij1 = 89
- ii0 = 158 ; ii1 = 160 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp
- ij0 = 88 ; ij1 = 88
- ii0 = 160 ; ii1 = 163 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0._wp
- ! Smooth transition from 0 at surface to 1./rday at the 18th level in Med and Red Sea
- DO jk = 1, 17
- zhfac (jk) = 0.5_wp * ( 1._wp - COS( rpi * REAL(jk-1,wp) / 16._wp ) ) / rday
- END DO
- DO jk = 18, jpkm1
- zhfac (jk) = 1._wp / rday
- END DO
- ! ! =======================
- CASE ( 05 ) ! ORCA_R05 configuration
- ! ! =======================
- ii0 = 568 ; ii1 = 574 ! Mediterranean Sea
- ij0 = 324 ; ij1 = 333 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- ii0 = 575 ; ii1 = 658
- ij0 = 314 ; ij1 = 366 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- !
- ii0 = 641 ; ii1 = 651 ! Black Sea (remaining part
- ij0 = 367 ; ij1 = 372 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- !
- ij0 = 324 ; ij1 = 333 ! Decrease before Gibraltar Strait
- ii0 = 565 ; ii1 = 565 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp / 90._wp
- ii0 = 566 ; ii1 = 566 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.40_wp
- ii0 = 567 ; ii1 = 567 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.75_wp
- !
- ii0 = 641 ; ii1 = 665 ! Red Sea
- ij0 = 270 ; ij1 = 310 ; zmrs( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1._wp
- !
- ii0 = 666 ; ii1 = 675 ! Decrease before Bab el Mandeb Strait
- ij0 = 270 ; ij1 = 290
- DO ji = mi0(ii0), mi1(ii1)
- zmrs( ji , mj0(ij0):mj1(ij1) ) = 0.1_wp * ABS( FLOAT(ji - mi1(ii1)) )
- END DO
- zsdmp = 1._wp / ( pn_surf * rday )
- zbdmp = 1._wp / ( pn_bot * rday )
- DO jk = 1, jpk
- zhfac(jk) = ( zbdmp + (zsdmp-zbdmp) * EXP( -fsdept(1,1,jk)/pn_dep ) )
- END DO
- ! ! ========================
- CASE ( 025 ) ! ORCA_R025 configuration
- ! ! ========================
- CALL ctl_stop( ' Not yet implemented in ORCA_R025' )
- !
- END SELECT
-
- DO jk = 1, jpkm1
- presto(:,:,jk) = zmrs(:,:) * zhfac(jk) + ( 1._wp - zmrs(:,:) ) * presto(:,:,jk)
- END DO
-
- ! Mask resto array and set to 0 first and last levels
- presto(:,:, : ) = presto(:,:,:) * tmask(:,:,:)
- presto(:,:, 1 ) = 0._wp
- presto(:,:,jpk) = 0._wp
- ! !--------------------!
- ELSE ! No damping !
- ! !--------------------!
- CALL ctl_stop( 'Choose a correct value of nn_hdmp or put ln_tradmp to FALSE' )
- ENDIF
-#endif
-
- ! !--------------------------------!
- IF( kn_file == 1 ) THEN ! save damping coef. in a file !
- ! !--------------------------------!
- IF(lwp) WRITE(numout,*) ' create damping.coeff.nc file'
- IF( cdtype == 'TRA' ) cfile = 'damping.coeff'
- IF( cdtype == 'TRC' ) cfile = 'damping.coeff.trc'
- IF( cdtype == 'DYN' ) cfile = 'damping.coeff.dyn'
- cfile = TRIM( cfile )
- CALL iom_open ( cfile, inum0, ldwrt = .TRUE., kiolib = jprstlib )
- CALL iom_rstput( 0, 0, inum0, 'Resto', presto )
- CALL iom_close ( inum0 )
- ENDIF
- !
- CALL wrk_dealloc( jpk, zhfac)
- CALL wrk_dealloc( jpi, jpj, zmrs )
- CALL wrk_dealloc( jpi, jpj, jpk, zdct )
- !
- IF( nn_timing == 1 ) CALL timing_stop('dtacof')
- !
- END SUBROUTINE dtacof
-
-
- SUBROUTINE cofdis( pdct )
- !!----------------------------------------------------------------------
- !! *** ROUTINE cofdis ***
- !!
- !! ** Purpose : Compute the distance between ocean T-points and the
- !! ocean model coastlines. Save the distance in a NetCDF file.
- !!
- !! ** Method : For each model level, the distance-to-coast is
- !! computed as follows :
- !! - The coastline is defined as the serie of U-,V-,F-points
- !! that are at the ocean-land bound.
- !! - For each ocean T-point, the distance-to-coast is then
- !! computed as the smallest distance (on the sphere) between the
- !! T-point and all the coastline points.
- !! - For land T-points, the distance-to-coast is set to zero.
- !! C A U T I O N : Computation not yet implemented in mpp case.
- !!
- !! ** Action : - pdct, distance to the coastline (argument)
- !! - NetCDF file 'dist.coast.nc'
- !!----------------------------------------------------------------------
- USE ioipsl ! IOipsl librairy
- !!
- REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out ) :: pdct ! distance to the coastline
- !!
- INTEGER :: ji, jj, jk, jl ! dummy loop indices
- INTEGER :: iju, ijt, icoast, itime, ierr, icot ! local integers
- CHARACTER (len=32) :: clname ! local name
- REAL(wp) :: zdate0 ! local scalar
- REAL(wp), POINTER, DIMENSION(:,:) :: zxt, zyt, zzt, zmask
- REAL(wp), POINTER, DIMENSION(: ) :: zxc, zyc, zzc, zdis ! temporary workspace
- LOGICAL , ALLOCATABLE, DIMENSION(:,:) :: llcotu, llcotv, llcotf ! 2D logical workspace
- !!----------------------------------------------------------------------
- !
- IF( nn_timing == 1 ) CALL timing_start('cofdis')
- !
- CALL wrk_alloc( jpi, jpj , zxt, zyt, zzt, zmask )
- CALL wrk_alloc( 3*jpi*jpj, zxc, zyc, zzc, zdis )
- ALLOCATE( llcotu(jpi,jpj), llcotv(jpi,jpj), llcotf(jpi,jpj) )
- !
- IF( lk_mpp ) CALL mpp_sum( ierr )
- IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'cofdis: requested local arrays unavailable')
-
- ! 0. Initialization
- ! -----------------
- IF(lwp) WRITE(numout,*)
- IF(lwp) WRITE(numout,*) 'cofdis : compute the distance to coastline'
- IF(lwp) WRITE(numout,*) '~~~~~~'
- IF(lwp) WRITE(numout,*)
- IF( lk_mpp ) &
- & CALL ctl_stop(' Computation not yet implemented with key_mpp_...', &
- & ' Rerun the code on another computer or ', &
- & ' create the "dist.coast.nc" file using IDL' )
-
- pdct(:,:,:) = 0._wp
- zxt(:,:) = COS( rad * gphit(:,:) ) * COS( rad * glamt(:,:) )
- zyt(:,:) = COS( rad * gphit(:,:) ) * SIN( rad * glamt(:,:) )
- zzt(:,:) = SIN( rad * gphit(:,:) )
-
-
- ! 1. Loop on vertical levels
- ! --------------------------
- ! ! ===============
- DO jk = 1, jpkm1 ! Horizontal slab
- ! ! ===============
- ! Define the coastline points (U, V and F)
- DO jj = 2, jpjm1
- DO ji = 2, jpim1
- zmask(ji,jj) = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) &
- & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) )
- llcotu(ji,jj) = ( tmask(ji,jj, jk) + tmask(ji+1,jj ,jk) == 1._wp )
- llcotv(ji,jj) = ( tmask(ji,jj ,jk) + tmask(ji ,jj+1,jk) == 1._wp )
- llcotf(ji,jj) = ( zmask(ji,jj) > 0._wp ) .AND. ( zmask(ji,jj) < 4._wp )
- END DO
- END DO
-
- ! Lateral boundaries conditions
- llcotu(:, 1 ) = umask(:, 2 ,jk) == 1
- llcotu(:,jpj) = umask(:,jpjm1,jk) == 1
- llcotv(:, 1 ) = vmask(:, 2 ,jk) == 1
- llcotv(:,jpj) = vmask(:,jpjm1,jk) == 1
- llcotf(:, 1 ) = fmask(:, 2 ,jk) == 1
- llcotf(:,jpj) = fmask(:,jpjm1,jk) == 1
-
- IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN
- llcotu( 1 ,:) = llcotu(jpim1,:)
- llcotu(jpi,:) = llcotu( 2 ,:)
- llcotv( 1 ,:) = llcotv(jpim1,:)
- llcotv(jpi,:) = llcotv( 2 ,:)
- llcotf( 1 ,:) = llcotf(jpim1,:)
- llcotf(jpi,:) = llcotf( 2 ,:)
- ELSE
- llcotu( 1 ,:) = umask( 2 ,:,jk) == 1
- llcotu(jpi,:) = umask(jpim1,:,jk) == 1
- llcotv( 1 ,:) = vmask( 2 ,:,jk) == 1
- llcotv(jpi,:) = vmask(jpim1,:,jk) == 1
- llcotf( 1 ,:) = fmask( 2 ,:,jk) == 1
- llcotf(jpi,:) = fmask(jpim1,:,jk) == 1
- ENDIF
- IF( nperio == 3 .OR. nperio == 4 ) THEN
- DO ji = 1, jpim1
- iju = jpi - ji + 1
- llcotu(ji,jpj ) = llcotu(iju,jpj-2)
- llcotf(ji,jpjm1) = llcotf(iju,jpj-2)
- llcotf(ji,jpj ) = llcotf(iju,jpj-3)
- END DO
- DO ji = jpi/2, jpim1
- iju = jpi - ji + 1
- llcotu(ji,jpjm1) = llcotu(iju,jpjm1)
- END DO
- DO ji = 2, jpi
- ijt = jpi - ji + 2
- llcotv(ji,jpjm1) = llcotv(ijt,jpj-2)
- llcotv(ji,jpj ) = llcotv(ijt,jpj-3)
- END DO
- ENDIF
- IF( nperio == 5 .OR. nperio == 6 ) THEN
- DO ji = 1, jpim1
- iju = jpi - ji
- llcotu(ji,jpj ) = llcotu(iju,jpjm1)
- llcotf(ji,jpj ) = llcotf(iju,jpj-2)
- END DO
- DO ji = jpi/2, jpim1
- iju = jpi - ji
- llcotf(ji,jpjm1) = llcotf(iju,jpjm1)
- END DO
- DO ji = 1, jpi
- ijt = jpi - ji + 1
- llcotv(ji,jpj ) = llcotv(ijt,jpjm1)
- END DO
- DO ji = jpi/2+1, jpi
- ijt = jpi - ji + 1
- llcotv(ji,jpjm1) = llcotv(ijt,jpjm1)
- END DO
- ENDIF
-
- ! Compute cartesian coordinates of coastline points
- ! and the number of coastline points
- icoast = 0
- DO jj = 1, jpj
- DO ji = 1, jpi
- IF( llcotf(ji,jj) ) THEN
- icoast = icoast + 1
- zxc(icoast) = COS( rad*gphif(ji,jj) ) * COS( rad*glamf(ji,jj) )
- zyc(icoast) = COS( rad*gphif(ji,jj) ) * SIN( rad*glamf(ji,jj) )
- zzc(icoast) = SIN( rad*gphif(ji,jj) )
- ENDIF
- IF( llcotu(ji,jj) ) THEN
- icoast = icoast+1
- zxc(icoast) = COS( rad*gphiu(ji,jj) ) * COS( rad*glamu(ji,jj) )
- zyc(icoast) = COS( rad*gphiu(ji,jj) ) * SIN( rad*glamu(ji,jj) )
- zzc(icoast) = SIN( rad*gphiu(ji,jj) )
- ENDIF
- IF( llcotv(ji,jj) ) THEN
- icoast = icoast+1
- zxc(icoast) = COS( rad*gphiv(ji,jj) ) * COS( rad*glamv(ji,jj) )
- zyc(icoast) = COS( rad*gphiv(ji,jj) ) * SIN( rad*glamv(ji,jj) )
- zzc(icoast) = SIN( rad*gphiv(ji,jj) )
- ENDIF
- END DO
- END DO
-
- ! Distance for the T-points
- DO jj = 1, jpj
- DO ji = 1, jpi
- IF( tmask(ji,jj,jk) == 0._wp ) THEN
- pdct(ji,jj,jk) = 0._wp
- ELSE
- DO jl = 1, icoast
- zdis(jl) = ( zxt(ji,jj) - zxc(jl) )**2 &
- & + ( zyt(ji,jj) - zyc(jl) )**2 &
- & + ( zzt(ji,jj) - zzc(jl) )**2
- END DO
- pdct(ji,jj,jk) = ra * SQRT( MINVAL( zdis(1:icoast) ) )
- ENDIF
- END DO
- END DO
- ! ! ===============
- END DO ! End of slab
- ! ! ===============
-
-
- ! 2. Create the distance to the coast file in NetCDF format
- ! ----------------------------------------------------------
- clname = 'dist.coast'
- itime = 0
- CALL ymds2ju( 0 , 1 , 1 , 0._wp , zdate0 )
- CALL restini( 'NONE', jpi , jpj , glamt, gphit , &
- & jpk , gdept_1d, clname, itime, zdate0, &
- & rdt , icot )
- CALL restput( icot, 'Tcoast', jpi, jpj, jpk, 0, pdct )
- CALL restclo( icot )
- !
- CALL wrk_dealloc( jpi, jpj , zxt, zyt, zzt, zmask )
- CALL wrk_dealloc( 3*jpi*jpj, zxc, zyc, zzc, zdis )
- DEALLOCATE( llcotu, llcotv, llcotf )
- !
- IF( nn_timing == 1 ) CALL timing_stop('cofdis')
- !
- END SUBROUTINE cofdis
- !!======================================================================
END MODULE tradmp
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90 (revision 5214)
@@ -24,4 +24,5 @@
USE trdtra
USE trd_oce
+ USE iom
IMPLICIT NONE
@@ -302,13 +303,8 @@
!!----------------------------------------------------------------------
!
+ INTEGER :: imask !local file handle
+
IF( nn_timing == 1 ) CALL timing_start('trc_dmp_init')
!
- SELECT CASE ( nn_hdmp_tr )
- CASE ( -1 ) ; IF(lwp) WRITE(numout,*) ' tracer damping in the Med & Red seas only'
- CASE ( 1:90 ) ; IF(lwp) WRITE(numout,*) ' tracer damping poleward of', nn_hdmp_tr, ' degrees'
- CASE DEFAULT
- WRITE(ctmp1,*) ' bad flag value for nn_hdmp_tr = ', nn_hdmp_tr
- CALL ctl_stop(ctmp1)
- END SELECT
IF( lzoom ) nn_zdmp_tr = 0 ! restoring to climatology at closed north or south boundaries
@@ -325,9 +321,9 @@
& CALL ctl_stop( 'passive trace damping need key_tradmp to compute damping coef.' )
!
- ! ! Damping coefficients initialization
- IF( lzoom ) THEN ; CALL dtacof_zoom( restotr )
- ELSE ; CALL dtacof( nn_hdmp_tr, rn_surf_tr, rn_bot_tr, rn_dep_tr, &
- & nn_file_tr, 'TRC' , restotr )
- ENDIF
+ ! ! Read damping coefficients from file
+ !Read in mask from file
+ CALL iom_open ( cn_resto_tr, imask)
+ CALL iom_get ( imask, jpdom_autoglo, 'resto', restotr)
+ CALL iom_close( imask )
!
IF( nn_timing == 1 ) CALL timing_stop('trc_dmp_init')
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90 (revision 5214)
@@ -51,10 +51,6 @@
! !!: ** newtonian damping namelist (nam_trcdmp) **
! !!* Namelist namtrc_dmp : passive tracer newtonian damping *
- INTEGER , PUBLIC :: nn_hdmp_tr ! = 0/-1/'latitude' for damping over passive tracer
INTEGER , PUBLIC :: nn_zdmp_tr ! = 0/1/2 flag for damping in the mixed layer
- REAL(wp), PUBLIC :: rn_surf_tr ! surface time scale for internal damping [days]
- REAL(wp), PUBLIC :: rn_bot_tr ! bottom time scale for internal damping [days]
- REAL(wp), PUBLIC :: rn_dep_tr ! depth of transition between rn_surf and rn_bot [meters]
- INTEGER , PUBLIC :: nn_file_tr ! = 1 create a damping.coeff NetCDF file
+ CHARACTER(LEN=200) , PUBLIC :: cn_resto_tr !File containing restoration coefficient
!!----------------------------------------------------------------------
@@ -82,6 +78,5 @@
NAMELIST/namtrc_zdf/ ln_trczdf_exp , nn_trczdf_exp
NAMELIST/namtrc_rad/ ln_trcrad
- NAMELIST/namtrc_dmp/ nn_hdmp_tr, nn_zdmp_tr, rn_surf_tr, &
- & rn_bot_tr , rn_dep_tr , nn_file_tr
+ NAMELIST/namtrc_dmp/ nn_zdmp_tr , cn_resto_tr
!!----------------------------------------------------------------------
@@ -184,10 +179,6 @@
WRITE(numout,*) '~~~~~~~'
WRITE(numout,*) ' Namelist namtrc_dmp : set damping parameter'
- WRITE(numout,*) ' tracer damping option nn_hdmp_tr = ', nn_hdmp_tr
WRITE(numout,*) ' mixed layer damping option nn_zdmp_tr = ', nn_zdmp_tr, '(zoom: forced to 0)'
- WRITE(numout,*) ' surface time scale (days) rn_surf_tr = ', rn_surf_tr
- WRITE(numout,*) ' bottom time scale (days) rn_bot_tr = ', rn_bot_tr
- WRITE(numout,*) ' depth of transition (meters) rn_dep_tr = ', rn_dep_tr
- WRITE(numout,*) ' create a damping.coeff file nn_file_tr = ', nn_file_tr
+ WRITE(numout,*) ' Restoration coeff file cn_resto_tr = ', cn_resto_tr
ENDIF
!
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/SETTE/BATCH_TEMPLATE/batch-PW7_MONSOON
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/SETTE/BATCH_TEMPLATE/batch-PW7_MONSOON (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/SETTE/BATCH_TEMPLATE/batch-PW7_MONSOON (revision 5214)
@@ -0,0 +1,89 @@
+#!/bin/bash
+#!
+# @ shell = /usr/bin/ksh
+# @ job_name = MPI_config
+# @ output = out.$(job_name).$(jobid)
+# @ error = err.$(job_name).$(jobid)
+# @ job_type = parallel
+# @ total_tasks = NPROCS
+# @ wall_clock_limit = 0:30:00
+# @ resources = ConsumableMemory(1562mb)
+# @ class = parallel
+# @ node_usage = shared
+# @ notification = error
+# @ task_affinity = core
+# @ queue
+
+ulimit -c unlimited
+ulimit -s unlimited
+#
+# Test specific settings. Do not hand edit these lines; the fcm_job.sh script will set these
+# (via sed operating on this template job file).
+#
+ OCEANCORES=NPROCS
+ export SETTE_DIR=DEF_SETTE_DIR
+
+###############################################################
+#
+# set up mpp computing environment
+#
+# Local settings for machine IBM Power7 (hpc2e at UK Met Office)
+#
+export MPIRUN="poe -pgmodel $MP_PGMMODEL -n $OCEANCORES -cmdfile"
+
+#
+# load sette functions (only post_test_tidyup needed)
+#
+ . ${SETTE_DIR}/all_functions.sh
+
+# Don't remove neither change the following comment line
+# BODY
+
+
+#
+# These variables are needed by post_test_tidyup function in all_functions.sh
+#
+ export EXE_DIR=DEF_EXE_DIR
+ export INPUT_DIR=DEF_INPUT_DIR
+ export CONFIG_DIR=DEF_CONFIG_DIR
+ export NEMO_VALIDATION_DIR=DEF_NEMO_VALIDATION
+ export NEW_CONF=DEF_NEW_CONF
+ export CMP_NAM=DEF_CMP_NAM
+ export TEST_NAME=DEF_TEST_NAME
+#
+# end of set up
+
+
+###############################################################
+#
+# change to the working directory
+#
+cd ${EXE_DIR}
+
+ echo Running on host `hostname`
+ echo Time is `date`
+ echo Directory is `pwd`
+#
+# Run the parallel MPI executable
+#
+ if [ MPI_FLAG == "yes" ]; then
+ n=1
+ echo "./opa" > ./alltasks
+ while [ $n -lt $OCEANCORES ]
+ do
+ echo "./opa" >> ./alltasks
+ n=$(( $n + 1 ))
+ done
+ time ${MPIRUN} ./alltasks
+ else
+ time ./opa
+ fi
+
+
+#
+ post_test_tidyup
+
+# END_BODY
+# Don't remove neither change the previous comment line
+
+ exit
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/README
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/README (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/README (revision 5214)
@@ -0,0 +1,5 @@
+DMP_TOOLS should be used to create a netcdf file called resto.nc containing restoration coefficients for use with the tra_dmp module in NEMO. Further instructions for it's use are available in the NEMO users guide.
+
+The tool can be compiled using the maketools script in the NEMOGCM/TOOLS directory as follows:
+./maketools -m $ARCH -n DMP_TOOLS
+where $ARCH indicates the arch file to be used from the directory NEMOGCM/ARCH. For example to use NEMOGCM/ARCH/arch-PW7_MONSOON.fcm, $ARCH would be PW7_MONSOON.
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/namelist
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/namelist (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/namelist (revision 5214)
@@ -0,0 +1,24 @@
+&nam_dmp_create
+ cp_cfg = 'orca' ! Name of model grid (orca and C1D have special options - otherwise ignored)
+ cp_cfz = 'antarctic' ! Name of zoom configuration (arctic and antarctic have some special treatment if lzoom=.true.)
+ jp_cfg = 2 ! Resolution of the model (used for med_red_seas damping)
+ lzoom = .false. ! Zoom configuration or not
+ ln_full_field = .false. ! Calculate coefficient over whole of domain
+ ln_med_red_seas = .true. ! Damping in Med/Red Seas (or local modifications here if ln_full_field=.true.)
+ ln_old_31_lev_code = .true. ! Replicate behaviour of old online code for 31 level model (Med/Red seas damping based on level number instead of depth)
+ ln_coast = .true. ! Reduce near to coastlines
+ ln_zero_top_layer = .true. ! No damping in top layer
+ ln_custom = .false. ! Call "custom" module to apply user modifications to the damping coefficient field
+ nn_hdmp = 10 ! Damp poleward of this latitude (smooth transition up to maximum damping)
+ pn_surf = 0.25 ! Surface Relaxation timescale (days)
+ pn_bot = 0.25 ! Bottom relaxation timescale (days)
+ pn_dep = 1000 ! Transition depth from upper to deep ocean
+ jperio = 2 ! Lateral boundary condition (as specified in namelist_cfg for model run).
+/
+
+&nam_zoom_dmp
+ lzoom_n = .false. ! Open boundary had northern edge?
+ lzoom_e = .false. ! Open boundary at eastern edge?
+ lzoom_w = .false. ! Open boundary at western edge?
+ lzoom_s = .false. ! Open boundary at southern edge?
+/
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/coast_dist.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/coast_dist.F90 (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/coast_dist.F90 (revision 5214)
@@ -0,0 +1,220 @@
+MODULE coastdist
+
+ USE utils
+ USE netcdf
+
+ IMPLICIT NONE
+ PUBLIC
+
+ CONTAINS
+
+ SUBROUTINE coast_dist_weight( presto )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE coast_dist_weight ***
+ !!
+ !! ** Purpose: Weight restoration coefficient by distance to coast
+ !!
+ !! ** Method: 1) Calculate distance to coast
+ !! 2) Reduce resto with 1000km of coast
+ !!
+ IMPLICIT NONE
+ REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: presto
+ REAL(wp), DIMENSION(jpi,jpj) :: zdct
+ REAL(wp) :: zinfl = 1000.e3_wp ! Distance of influence of coast line (could be
+ ! a namelist setting)
+ INTEGER :: jj, ji ! dummy loop indices
+
+
+ CALL cofdis( zdct )
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ zdct(ji,jj) = MIN( zinfl, zdct(ji,jj) )
+ presto(ji,jj) = presto(ji, jj) * 0.5_wp * ( 1._wp - COS( rpi*zdct(ji,jj)/zinfl) )
+ END DO
+ END DO
+
+ END SUBROUTINE coast_dist_weight
+
+
+ SUBROUTINE cofdis( pdct )
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE cofdis ***
+ !!
+ !! ** Purpose : Compute the distance between ocean T-points and the
+ !! ocean model coastlines.
+ !!
+ !! ** Method : For each model level, the distance-to-coast is
+ !! computed as follows :
+ !! - The coastline is defined as the serie of U-,V-,F-points
+ !! that are at the ocean-land bound.
+ !! - For each ocean T-point, the distance-to-coast is then
+ !! computed as the smallest distance (on the sphere) between the
+ !! T-point and all the coastline points.
+ !! - For land T-points, the distance-to-coast is set to zero.
+ !!
+ !! ** Action : - pdct, distance to the coastline (argument)
+ !! - NetCDF file 'dist.coast.nc'
+ !!----------------------------------------------------------------------
+ !!
+ REAL(wp), DIMENSION(jpi,jpj), INTENT( out ) :: pdct ! distance to the coastline
+ !!
+ INTEGER :: ji, jj, jl ! dummy loop indices
+ INTEGER :: iju, ijt, icoast, itime, ierr, icot ! local integers
+ CHARACTER (len=32) :: clname ! local name
+ REAL(wp) :: zdate0 ! local scalar
+ REAL(wp), POINTER, DIMENSION(:,:) :: zxt, zyt, zzt, zmask
+ REAL(wp), POINTER, DIMENSION(: ) :: zxc, zyc, zzc, zdis ! temporary workspace
+ LOGICAL , ALLOCATABLE, DIMENSION(:,:) :: llcotu, llcotv, llcotf ! 2D logical workspace
+
+ !!----------------------------------------------------------------------
+ !
+ ALLOCATE( zxt(jpi,jpj) , zyt(jpi,jpj) , zzt(jpi,jpj) , zmask(jpi,jpj) )
+ ALLOCATE(zxc(3*jpi*jpj), zyc(3*jpi*jpj), zzc(3*jpi*jpj), zdis(3*jpi*jpj) )
+ ALLOCATE( llcotu(jpi,jpj), llcotv(jpi,jpj), llcotf(jpi,jpj) )
+ ALLOCATE( gphiu(jpi,jpj), gphiv(jpi,jpj), gphif(jpi,jpj) )
+ ALLOCATE( glamu(jpi,jpj), glamv(jpi,jpj), glamf(jpi,jpj), glamt(jpi,jpj) )
+ ALLOCATE( umask(jpi,jpj), vmask(jpi,jpj), fmask(jpi,jpj) )
+ !
+
+ CALL check_nf90( nf90_get_var( ncin, gphit_id, gphit, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, gphiu_id, gphiu, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, gphiv_id, gphiv, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, gphif_id, gphif, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, glamt_id, glamt, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, glamu_id, glamu, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, glamv_id, glamv, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, glamf_id, glamf, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, tmask_id, tmask, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, umask_id, umask, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, vmask_id, vmask, (/ 1,1 /), (/ jpi, jpj /) ) )
+ CALL check_nf90( nf90_get_var( ncin, fmask_id, fmask, (/ 1,1 /), (/ jpi, jpj /) ) )
+
+ pdct(:,:) = 0._wp
+ zxt(:,:) = COS( rad * gphit(:,:) ) * COS( rad * glamt(:,:) )
+ zyt(:,:) = COS( rad * gphit(:,:) ) * SIN( rad * glamt(:,:) )
+ zzt(:,:) = SIN( rad * gphit(:,:) )
+
+
+ ! Define the coastline points (U, V and F)
+ DO jj = 2, jpj-1
+ DO ji = 2, jpi-1
+ zmask(ji,jj) = ( tmask(ji,jj+1) + tmask(ji+1,jj+1) &
+ & + tmask(ji,jj ) + tmask(ji+1,jj ) )
+ llcotu(ji,jj) = ( tmask(ji,jj ) + tmask(ji+1,jj ) == 1._wp )
+ llcotv(ji,jj) = ( tmask(ji,jj ) + tmask(ji ,jj+1) == 1._wp )
+ llcotf(ji,jj) = ( zmask(ji,jj) > 0._wp ) .AND. ( zmask(ji,jj) < 4._wp )
+ END DO
+ END DO
+
+ ! Lateral boundaries conditions
+ llcotu(:, 1 ) = umask(:, 2 ) == 1
+ llcotu(:,jpj) = umask(:,jpj-1) == 1
+ llcotv(:, 1 ) = vmask(:, 2 ) == 1
+ llcotv(:,jpj) = vmask(:,jpj-1) == 1
+ llcotf(:, 1 ) = fmask(:, 2 ) == 1
+ llcotf(:,jpj) = fmask(:,jpj-1) == 1
+
+ IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN
+ llcotu( 1 ,:) = llcotu(jpi-1,:)
+ llcotu(jpi,:) = llcotu( 2 ,:)
+ llcotv( 1 ,:) = llcotv(jpi-1,:)
+ llcotv(jpi,:) = llcotv( 2 ,:)
+ llcotf( 1 ,:) = llcotf(jpi-1,:)
+ llcotf(jpi,:) = llcotf( 2 ,:)
+ ELSE
+ llcotu( 1 ,:) = umask( 2 ,:) == 1
+ llcotu(jpi,:) = umask(jpi-1,:) == 1
+ llcotv( 1 ,:) = vmask( 2 ,:) == 1
+ llcotv(jpi,:) = vmask(jpi-1,:) == 1
+ llcotf( 1 ,:) = fmask( 2 ,:) == 1
+ llcotf(jpi,:) = fmask(jpi-1,:) == 1
+ ENDIF
+ IF( jperio == 3 .OR. jperio == 4 ) THEN
+ DO ji = 1, jpi-1
+ iju = jpi - ji + 1
+ llcotu(ji,jpj ) = llcotu(iju,jpj-2)
+ llcotf(ji,jpj-1) = llcotf(iju,jpj-2)
+ llcotf(ji,jpj ) = llcotf(iju,jpj-3)
+ END DO
+ DO ji = jpi/2, jpi-1
+ iju = jpi - ji + 1
+ llcotu(ji,jpj-1) = llcotu(iju,jpj-1)
+ END DO
+ DO ji = 2, jpi
+ ijt = jpi - ji + 2
+ llcotv(ji,jpj-1) = llcotv(ijt,jpj-2)
+ llcotv(ji,jpj ) = llcotv(ijt,jpj-3)
+ END DO
+ ENDIF
+ IF( jperio == 5 .OR. jperio == 6 ) THEN
+ DO ji = 1, jpi-1
+ iju = jpi - ji
+ llcotu(ji,jpj ) = llcotu(iju,jpj-1)
+ llcotf(ji,jpj ) = llcotf(iju,jpj-2)
+ END DO
+ DO ji = jpi/2, jpi-1
+ iju = jpi - ji
+ llcotf(ji,jpj-1) = llcotf(iju,jpj-1)
+ END DO
+ DO ji = 1, jpi
+ ijt = jpi - ji + 1
+ llcotv(ji,jpj ) = llcotv(ijt,jpj-1)
+ END DO
+ DO ji = jpi/2+1, jpi
+ ijt = jpi - ji + 1
+ llcotv(ji,jpj-1) = llcotv(ijt,jpj-1)
+ END DO
+ ENDIF
+
+ ! Compute cartesian coordinates of coastline points
+ ! and the number of coastline points
+ icoast = 0
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ IF( llcotf(ji,jj) ) THEN
+ icoast = icoast + 1
+ zxc(icoast) = COS( rad*gphif(ji,jj) ) * COS( rad*glamf(ji,jj) )
+ zyc(icoast) = COS( rad*gphif(ji,jj) ) * SIN( rad*glamf(ji,jj) )
+ zzc(icoast) = SIN( rad*gphif(ji,jj) )
+ ENDIF
+ IF( llcotu(ji,jj) ) THEN
+ icoast = icoast+1
+ zxc(icoast) = COS( rad*gphiu(ji,jj) ) * COS( rad*glamu(ji,jj) )
+ zyc(icoast) = COS( rad*gphiu(ji,jj) ) * SIN( rad*glamu(ji,jj) )
+ zzc(icoast) = SIN( rad*gphiu(ji,jj) )
+ ENDIF
+ IF( llcotv(ji,jj) ) THEN
+ icoast = icoast+1
+ zxc(icoast) = COS( rad*gphiv(ji,jj) ) * COS( rad*glamv(ji,jj) )
+ zyc(icoast) = COS( rad*gphiv(ji,jj) ) * SIN( rad*glamv(ji,jj) )
+ zzc(icoast) = SIN( rad*gphiv(ji,jj) )
+ ENDIF
+ END DO
+ END DO
+
+ ! Distance for the T-points
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ IF( tmask(ji,jj) == 0._wp ) THEN
+ pdct(ji,jj) = 0._wp
+ ELSE
+ DO jl = 1, icoast
+ zdis(jl) = ( zxt(ji,jj) - zxc(jl) )**2 &
+ & + ( zyt(ji,jj) - zyc(jl) )**2 &
+ & + ( zzt(ji,jj) - zzc(jl) )**2
+ END DO
+ pdct(ji,jj) = ra * SQRT( MINVAL( zdis(1:icoast) ) )
+ ENDIF
+ END DO
+ END DO
+
+ DEALLOCATE( zxt , zyt , zzt , zmask )
+ DEALLOCATE(zxc, zyc, zzc, zdis )
+ DEALLOCATE( llcotu, llcotv, llcotf )
+ DEALLOCATE( gphiu, gphiv, gphif )
+ DEALLOCATE( glamu, glamv, glamf, glamt )
+ DEALLOCATE( umask, vmask, fmask )
+
+ END SUBROUTINE cofdis
+
+END MODULE coastdist
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/custom.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/custom.F90 (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/custom.F90 (revision 5214)
@@ -0,0 +1,22 @@
+MODULE custom
+
+ USE utils
+
+ IMPLICIT NONE
+ PUBLIC
+
+ CONTAINS
+
+ SUBROUTINE custom_resto( presto )
+ !!---------------------------------
+ !! **ROUTINE: custom_resto
+ !!
+ !! ** Purpose: Module to be edited by users to create custom restoration
+ !! coefficient files (e.g. regional damping).
+ !!
+ !!-------------------------------------
+ REAL(wp), DIMENSION(jpi,jpk), INTENT(inout) :: presto
+
+ END SUBROUTINE custom_resto
+
+END MODULE custom
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/make_dmp_file.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/make_dmp_file.F90 (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/make_dmp_file.F90 (revision 5214)
@@ -0,0 +1,123 @@
+PROGRAM make_dmp_file
+ !================================================================================
+ ! *** PROGRAM make_dmp_file ****
+ !================================================================================
+ !
+ ! Purpose: Create a file containing a spacially varying
+ ! restoration coefficient to be used by TRADMP
+ !
+ ! Method: 1) Read in tmask from mesh_mask file to use as a template
+ ! 2) Calculate restoration coefficients according to options
+ ! specified in the namelist. The user may modify custom.F90 to
+ ! specify specific damping options e.g. to mask certain regions only).
+ ! 3) Write the array to output file
+ !
+ ! History: Original code: Tim Graham (Jul 2014) - some code moved from
+ ! old tradmp.F90 module to this tool (as part of NEMO
+ ! simplification process).
+ !-------------------------------------------------------------------------------
+
+ ! Declare variables
+ USE netcdf
+ USE utils
+ USE coastdist
+ USE med_red_seas
+ USE zoom
+ USE custom
+
+ IMPLICIT NONE
+ INTEGER :: ji, jj, jk ! dummpy loop variables
+ REAL(wp) :: zsdmp, zbdmp ! Surface and bottom damping coeff
+ CHARACTER(LEN=200) :: meshfile = 'mesh_mask.nc' ! mesh file
+ CHARACTER(LEN=200) :: outfile = 'resto.nc' ! output file
+ REAL(wp) :: zlat, zlat2, zlat0
+
+ ! Read namelist
+ OPEN( UNIT=numnam, FILE='namelist', FORM='FORMATTED', STATUS='OLD' )
+ READ( numnam, nam_dmp_create )
+ CLOSE( numnam )
+
+ IF ( ln_full_field .AND. lzoom ) THEN
+ WRITE(numerr,*) 'Only one of ln_full_field and lzoom can be .true.'
+ STOP
+ ENDIF
+
+ CALL grid_info(meshfile)
+ WRITE(numout, *) 'jpi = ',jpi
+ WRITE(numout, *) 'jpj = ',jpj
+ WRITE(numout, *) 'jpk = ',jpk
+
+ ALLOCATE( resto(jpi, jpj) )
+
+ !Create output file
+ CALL make_outfile( outfile )
+
+ CALL check_nf90( nf90_get_var( ncin, gphit_id, gphit, (/ 1,1 /), (/ jpi, jpj /) ) )
+
+ !Calculate surface and bottom damping coefficients
+ zsdmp = 1._wp / ( pn_surf * rday )
+ zbdmp = 1._wp / ( pn_bot * rday )
+
+ !Loop through levels and read in tmask for each level as starting point for
+ !coefficient array
+ DO jk = 1, jpk-1
+ resto(:,:) = 0._wp
+
+ IF (.NOT. (jk == 1 .AND. ln_zero_top_layer) ) THEN
+ !Read in tmask depth for this level
+ CALL check_nf90( nf90_get_var( ncin, tmask_id, tmask, (/ 1,1,jk /), (/ jpi, jpj,1 /) ) )
+ CALL check_nf90( nf90_get_var( ncin, gdept_id, gdept, (/ 1,1,jk /), (/ jpi, jpj,1 /) ) )
+
+
+ IF ( ln_full_field ) THEN
+ !Set basic value of resto
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ resto(ji,jj) = tmask(ji, jj) * (zbdmp + (zsdmp-zbdmp) * EXP(-gdept(ji,jj)/pn_dep))
+ END DO
+ END DO
+ IF ((nn_hdmp > 0)) THEN
+ zlat0 = 10. !width of latitude strip where resto decreases
+ zlat2 = nn_hdmp + zlat0
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ zlat = ABS(gphit(ji,jj))
+ IF ( nn_hdmp <= zlat .AND. zlat <= zlat2 ) THEN
+ resto(ji,jj) = resto(ji,jj) * 0.5_wp * ( 1._wp - COS( rpi*(zlat-nn_hdmp)/zlat0 ) )
+ ELSE IF ( zlat < nn_hdmp ) THEN
+ resto(ji,jj) = 0._wp
+ ENDIF
+ END DO
+ END DO
+ ENDIF
+
+ IF (ln_coast) THEN
+ ! Reduce damping in vicinity of coastlines
+ CALL coast_dist_weight(resto)
+ ENDIF
+ ENDIF
+
+ ! Damping in Med/Red Seas (or local modifications if full field is set)
+ IF (ln_med_red_seas .AND. (cp_cfg == 'orca') .AND. (.NOT. lzoom)) THEN
+ CALL med_red_dmp(resto, jk, ln_old_31_lev_code)
+ ENDIF
+
+ IF ( lzoom ) THEN
+ CALL dtacof_zoom(resto, tmask)
+ ENDIF
+
+ !Any user modifications can be added in the custom module
+ IF ( ln_custom ) THEN
+ CALL custom_resto( resto )
+ ENDIF
+ ENDIF
+
+ ! Write out resto for this level
+ CALL check_nf90( nf90_put_var( ncout, resto_id, resto, (/ 1,1,jk /), (/ jpi, jpj,1 /) ) )
+
+ END DO
+
+ ! Close the output file
+ CALL check_nf90( nf90_close(ncout) )
+
+END PROGRAM make_dmp_file
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/med_red_seas.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/med_red_seas.F90 (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/med_red_seas.F90 (revision 5214)
@@ -0,0 +1,135 @@
+MODULE med_red_seas
+
+ USE utils
+
+ IMPLICIT NONE
+ PUBLIC
+
+ CONTAINS
+
+ SUBROUTINE med_red_dmp(presto, jk, ln_31_lev)
+ !!------------------------------------
+ !! **ROUTINE: med_red_dmp
+ !!
+ !! **Purpose: Apply specific modifications to damping coefficients on ORCA
+ !! grids in Med and Red Seas
+ !!
+ !!-----------------------------------
+ INTEGER :: ij0,ij1,ii0,ii1,ji,jj
+ INTEGER, INTENT(in) :: jk
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zmrs
+ REAL(wp) :: zhfac, zsdmp, zbdmp
+ REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: presto
+ LOGICAL, INTENT(in), OPTIONAL :: ln_31_lev
+ LOGICAL :: l_31_lev
+
+ WRITE(numout,*) 'ORCA Med and Red Seas Damping'
+
+ IF ( PRESENT(ln_31_lev)) THEN
+ l_31_lev = ln_31_lev
+ ELSE
+ l_31_lev = .false.
+ ENDIF
+
+ ALLOCATE( zmrs(jpi, jpj) )
+ !
+ zmrs(:,:) = 0._wp
+ !
+ SELECT CASE ( jp_cfg )
+ ! ! =======================
+ CASE ( 4 ) ! ORCA_R4 configuration
+ ! ! =======================
+ ij0 = 50 ; ij1 = 56 ! Mediterranean Sea
+
+ ii0 = 81 ; ii1 = 91 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1.
+ ij0 = 50 ; ij1 = 55
+ ii0 = 75 ; ii1 = 80 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1.
+ ij0 = 52 ; ij1 = 53
+ ii0 = 70 ; ii1 = 74 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1.
+ !
+ ! ! =======================
+ CASE ( 2 ) ! ORCA_R2 configuration
+ ! ! =======================
+ ij0 = 96 ; ij1 = 110 ! Mediterranean Sea
+ ii0 = 157 ; ii1 = 181 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp
+ ij0 = 100 ; ij1 = 110
+ ii0 = 144 ; ii1 = 156 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp
+ ij0 = 100 ; ij1 = 103
+ ii0 = 139 ; ii1 = 143 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp
+ !
+ ij0 = 101 ; ij1 = 102 ! Decrease before Gibraltar Strait
+ ii0 = 139 ; ii1 = 141 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0._wp
+ ii0 = 142 ; ii1 = 142 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp / 90._wp
+ ii0 = 143 ; ii1 = 143 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.40_wp
+ ii0 = 144 ; ii1 = 144 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.75_wp
+ !
+ ij0 = 87 ; ij1 = 96 ! Red Sea
+ ii0 = 147 ; ii1 = 163 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp
+ !
+ ij0 = 91 ; ij1 = 91 ! Decrease before Bab el Mandeb Strait
+ ii0 = 153 ; ii1 = 160 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.80_wp
+ ij0 = 90 ; ij1 = 90
+ ii0 = 153 ; ii1 = 160 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.40_wp
+ ij0 = 89 ; ij1 = 89
+ ii0 = 158 ; ii1 = 160 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp / 90._wp
+ ij0 = 88 ; ij1 = 88
+ ii0 = 160 ; ii1 = 163 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0._wp
+ !
+ ! ! =======================
+ CASE ( 05 ) ! ORCA_R05 configuration
+ ! ! =======================
+ ii0 = 568 ; ii1 = 574 ! Mediterranean Sea
+ ij0 = 324 ; ij1 = 333 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp
+ ii0 = 575 ; ii1 = 658
+ ij0 = 314 ; ij1 = 366 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp
+ !
+ ii0 = 641 ; ii1 = 651 ! Black Sea (remaining part
+ ij0 = 367 ; ij1 = 372 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp
+ !
+ ij0 = 324 ; ij1 = 333 ! Decrease before Gibraltar Strait
+ ii0 = 565 ; ii1 = 565 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp / 90._wp
+ ii0 = 566 ; ii1 = 566 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.40_wp
+ ii0 = 567 ; ii1 = 567 ; zmrs( ii0:ii1 , ij0:ij1 ) = 0.75_wp
+ !
+ ii0 = 641 ; ii1 = 665 ! Red Sea
+ ij0 = 270 ; ij1 = 310 ; zmrs( ii0:ii1 , ij0:ij1 ) = 1._wp
+ !
+ ii0 = 666 ; ii1 = 675 ! Decrease before Bab el Mandeb Strait
+ ij0 = 270 ; ij1 = 290
+ DO ji = ii0, ii1
+ zmrs( ji , ij0:ij1 ) = 0.1_wp * ABS( FLOAT(ji - ii1) )
+ END DO
+ ! ! ========================
+ CASE ( 025 ) ! ORCA_R025 configuration
+ ! ! ========================
+ WRITE(numerr,*) ' Mediterranean and Red Sea damping option not implemented for ORCA_R025'
+ WRITE(numerr,*) ' Set ln_med_red = .false.'
+ STOP
+ !
+ END SELECT
+
+ zsdmp = 1._wp / ( pn_surf * rday )
+ zbdmp = 1._wp / ( pn_bot * rday )
+
+ ! The l_31_lev option is used to reproduce the old behaviour of
+ ! defining the restoration coefficient based on the level number.
+ ! This is included to allow damping coefficients for reference
+ ! configurations to be kept the same.
+ IF (l_31_lev) THEN
+ IF (jk <= 17) THEN
+ zhfac = 0.5_wp * ( 1. - COS( rpi * REAL(jk-1,wp) / 16._wp ) ) / rday
+ ELSE
+ zhfac = 1._wp / rday
+ ENDIF
+ ELSE
+ zhfac = ( zbdmp + (zsdmp-zbdmp) * EXP( -gdept(1,1)/pn_dep ) )
+ ENDIF
+
+ presto(:,:) = zmrs(:,:) * zhfac + ( 1._wp - zmrs(:,:) ) * presto(:,:)
+
+ DEALLOCATE( zmrs )
+
+ END SUBROUTINE med_red_dmp
+
+
+END MODULE med_red_seas
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/utils.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/utils.F90 (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/utils.F90 (revision 5214)
@@ -0,0 +1,130 @@
+MODULE utils
+
+ USE netcdf
+
+ IMPLICIT NONE
+ PUBLIC
+
+ INTEGER, PUBLIC, PARAMETER :: dp=8 , sp=4, wp=dp
+ INTEGER :: tmask_id, umask_id, vmask_id, fmask_id
+ INTEGER :: gdept_id
+ INTEGER :: gphit_id, gphiv_id, gphiu_id, gphif_id ! Variable ids
+ INTEGER :: glamt_id, glamv_id, glamu_id, glamf_id ! Variable ids
+ INTEGER :: resto_id ! Variable ID for output
+ INTEGER :: jpi, jpj, jpk ! Size of domain
+ INTEGER :: ncin, ncout ! File handles for netCDF files
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphit, glamt
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphiu, glamu
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphiv, glamv
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gphif, glamf
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tmask, umask, vmask, fmask
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: gdept
+ REAL(wp), DIMENSION(:,:), ALLOCATABLE :: resto
+
+ INTEGER,PARAMETER :: numout = 6
+ INTEGER,PARAMETER :: numerr = 0
+ INTEGER,PARAMETER :: numnam = 11
+ REAL(wp),PARAMETER :: rday = 86400 ! seconds in a day
+ REAL(wp),PARAMETER :: rpi = 3.141592653589793
+ REAL(wp),PARAMETER :: rad = 3.141592653589793/180.
+ REAL(wp),PARAMETER :: ra = 6371229.
+
+ ! Namelist variables
+ CHARACTER(LEN=30) :: cp_cfg = 'ORCA'
+ CHARACTER(LEN=30) :: cp_cfz = 'No zoom'
+ INTEGER :: jp_cfg = 2
+ REAL(KIND=8) :: pn_surf = 1
+ REAL(KIND=8) :: pn_bot = 1
+ REAL(KIND=8) :: pn_dep = 1000
+ INTEGER :: nn_hdmp = 0 ! damping option
+ INTEGER :: jperio = 0 ! damping option
+ LOGICAL :: lzoom = .false.
+ LOGICAL :: ln_coast = .false.
+ LOGICAL :: ln_full_field = .true.
+ LOGICAL :: ln_med_red_seas = .false.
+ LOGICAL :: ln_old_31_lev_code = .false.
+ LOGICAL :: ln_zero_top_layer = .false.
+ LOGICAL :: ln_custom = .false.
+
+ NAMELIST/nam_dmp_create/cp_cfg, cp_cfz, jp_cfg, lzoom, ln_full_field, &
+ ln_med_red_seas, ln_old_31_lev_code, ln_coast, &
+ ln_zero_top_layer, ln_custom, &
+ pn_surf, pn_bot, pn_dep, nn_hdmp, jperio
+
+ CONTAINS
+
+ SUBROUTINE grid_info(mesh)
+ CHARACTER(LEN=*),INTENT(in) :: mesh
+
+ ! Open meshfile
+ CALL check_nf90( nf90_open(mesh, NF90_NOWRITE, ncin), 'Error opening mesh_mask file' )
+
+ ! Get size of grid from meshfile
+ CALL dimlen( ncin, 'x', jpi )
+ CALL dimlen( ncin, 'y', jpj )
+ CALL dimlen( ncin, 'z', jpk )
+
+ ALLOCATE( tmask(jpi, jpj), gdept(jpi, jpj), gphit(jpi,jpj) )
+
+ !Get ID of tmask in meshfile
+ CALL check_nf90( nf90_inq_varid( ncin, 'tmask', tmask_id ), 'Cannot get variable ID for tmask')
+ CALL check_nf90( nf90_inq_varid( ncin, 'umask', umask_id ), 'Cannot get variable ID for umask')
+ CALL check_nf90( nf90_inq_varid( ncin, 'vmask', vmask_id ), 'Cannot get variable ID for vmask')
+ CALL check_nf90( nf90_inq_varid( ncin, 'fmask', fmask_id ), 'Cannot get variable ID for fmask')
+ CALL check_nf90( nf90_inq_varid( ncin, 'gdept_0', gdept_id ), 'Cannot get variable ID for gdept_0')
+ CALL check_nf90( nf90_inq_varid( ncin, 'gphit', gphit_id ), 'Cannot get variable ID for gphit')
+ CALL check_nf90( nf90_inq_varid( ncin, 'gphiu', gphiu_id ), 'Cannot get variable ID for gphiu')
+ CALL check_nf90( nf90_inq_varid( ncin, 'gphiv', gphiv_id ), 'Cannot get variable ID for gphiv')
+ CALL check_nf90( nf90_inq_varid( ncin, 'gphif', gphif_id ), 'Cannot get variable ID for gphif')
+ CALL check_nf90( nf90_inq_varid( ncin, 'glamt', glamt_id ), 'Cannot get variable ID for glamt')
+ CALL check_nf90( nf90_inq_varid( ncin, 'glamu', glamu_id ), 'Cannot get variable ID for glamu')
+ CALL check_nf90( nf90_inq_varid( ncin, 'glamv', glamv_id ), 'Cannot get variable ID for glamv')
+ CALL check_nf90( nf90_inq_varid( ncin, 'glamf', glamf_id ), 'Cannot get variable ID for glamf')
+
+ END SUBROUTINE grid_info
+
+ SUBROUTINE dimlen( ncid, dimname, len )
+ ! Determine the length of dimension dimname
+ INTEGER, INTENT(in) :: ncid
+ CHARACTER(LEN=*), INTENT(in) :: dimname
+ INTEGER, INTENT(out) :: len
+ ! Local variables
+ INTEGER :: id_var, istatus
+
+ id_var = 1
+ CALL check_nf90( nf90_inq_dimid(ncid, dimname, id_var), 'Dimension not found in file')
+ CALL check_nf90( nf90_inquire_dimension(ncid,id_var,len=len))
+
+ END SUBROUTINE dimlen
+
+ SUBROUTINE make_outfile( filename )
+ ! Create the output file
+ ! Define dimensions and resto variable
+ CHARACTER(LEN=*), INTENT(in) :: filename
+ INTEGER :: id_x, id_y, id_z
+
+ CALL check_nf90( nf90_create(filename, NF90_CLOBBER, ncout), 'Could not create output file')
+ CALL check_nf90( nf90_def_dim(ncout, 'x', jpi, id_x) )
+ CALL check_nf90( nf90_def_dim(ncout, 'y', jpj, id_y) )
+ CALL check_nf90( nf90_def_dim(ncout, 'z', jpk, id_z) )
+
+ CALL check_nf90( nf90_def_var(ncout, 'resto', nf90_double, (/id_x,id_y,id_z/), resto_id ) )
+ CALL check_nf90( nf90_enddef(ncout) )
+
+ END SUBROUTINE make_outfile
+
+
+ SUBROUTINE check_nf90( istat, message )
+ !Check for netcdf errors
+ INTEGER, INTENT(in) :: istat
+ CHARACTER(LEN=*), INTENT(in), OPTIONAL :: message
+
+ IF (istat /= nf90_noerr) THEN
+ WRITE(numerr,*) 'ERROR! : '//TRIM(nf90_strerror(istat))
+ IF ( PRESENT(message) ) THEN ; WRITE(numerr,*) message ; ENDIF
+ STOP
+ ENDIF
+
+ END SUBROUTINE check_nf90
+
+END MODULE utils
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/zoom.F90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/zoom.F90 (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/DMP_TOOLS/src/zoom.F90 (revision 5214)
@@ -0,0 +1,90 @@
+MODULE zoom
+
+ USE utils
+
+ CONTAINS
+
+ SUBROUTINE dtacof_zoom( presto, mask)
+ !!----------------------------------------------------------------------
+ !! *** ROUTINE dtacof_zoom ***
+ !!
+ !! ** Purpose : Compute the damping coefficient for zoom domain
+ !!
+ !! ** Method : - set along closed boundary due to zoom a damping over
+ !! 6 points with a max time scale of 5 days.
+ !! - ORCA arctic/antarctic zoom: set the damping along
+ !! south/north boundary over a latitude strip.
+ !!
+ !! ** Action : - resto, the damping coeff. for T and S
+ !!----------------------------------------------------------------------
+ REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: presto ! restoring coeff. (s-1)
+ REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: mask ! restoring coeff. (s-1)
+ !
+ INTEGER :: ji, jj, jn ! dummy loop indices
+ REAL(wp) :: zlat, zlat0, zlat1, zlat2, z1_5d ! local scalar
+ REAL(wp), DIMENSION(6) :: zfact ! 1Dworkspace
+
+ !Namelist variables
+ LOGICAL :: lzoom_w, lzoom_e, lzoom_n, lzoom_s
+ NAMELIST/nam_zoom_dmp/lzoom_n,lzoom_e,lzoom_w,lzoom_s
+ !!----------------------------------------------------------------------
+ !
+ IF( nn_timing == 1 ) CALL timing_start( 'dtacof_zoom')
+ !
+
+ ! Read namelist
+ OPEN( UNIT=numnam, FILE='namelist', FORM='FORMATTED', STATUS='OLD' )
+ READ( numnam, nam_dmp_create )
+ CLOSE( numnam )
+
+ zfact(1) = 1._wp
+ zfact(2) = 1._wp
+ zfact(3) = 11._wp / 12._wp
+ zfact(4) = 8._wp / 12._wp
+ zfact(5) = 4._wp / 12._wp
+ zfact(6) = 1._wp / 12._wp
+ zfact(:) = zfact(:) / ( 5._wp * rday ) ! 5 days max restoring time scale
+
+ presto(:,:) = 0._wp
+
+ ! damping along the forced closed boundary over 6 grid-points
+ DO jn = 1, 6
+ IF( lzoom_w ) presto( jn, : ) = zfact(jn) ! west closed
+ IF( lzoom_s ) presto( : , jn ) = zfact(jn) ! south closed
+ IF( lzoom_e ) presto( jpi+1-jn , : ) = zfact(jn) ! east closed
+ IF( lzoom_n ) presto( : , jpj+1-jn ) = zfact(jn) ! north closed
+ END DO
+
+ ! ! ====================================================
+ IF( cp_cfz == "arctic" .OR. cp_cfz == "antarctic" ) THEN ! ORCA configuration : arctic or antarctic zoom
+ ! ! ====================================================
+ WRITE(numout,*)
+ IF(cp_cfz == "arctic" ) WRITE(numout,*) ' dtacof_zoom : ORCA Arctic zoom'
+ IF(cp_cfz == "antarctic" ) WRITE(numout,*) ' dtacof_zoom : ORCA Antarctic zoom'
+ WRITE(numout,*)
+ !
+ ! ! Initialization :
+ presto(:,:) = 0._wp
+ zlat0 = 10._wp ! zlat0 : latitude strip where resto decreases
+ zlat1 = 30._wp ! zlat1 : resto = 1 before zlat1
+ zlat2 = zlat1 + zlat0 ! zlat2 : resto decreases from 1 to 0 between zlat1 and zlat2
+ z1_5d = 1._wp / ( 5._wp * rday ) ! z1_5d : 1 / 5days
+
+ DO jj = 1, jpj
+ DO ji = 1, jpi
+ zlat = ABS( gphit(ji,jj) )
+ IF( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN
+ presto(ji,jj) = 0.5_wp * z1_5d * ( 1._wp - COS( rpi*(zlat2-zlat)/zlat0 ) )
+ ELSEIF( zlat < zlat1 ) THEN
+ presto(ji,jj) = z1_5d
+ ENDIF
+ END DO
+ END DO
+ !
+ ENDIF
+ ! ! Mask resto array
+ presto(:,:) = presto(:,:) * mask(:,:)
+
+ END SUBROUTINE dtacof_zoom
+
+END MODULE zoom
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/README
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/README (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/README (revision 5214)
@@ -1,10 +1,14 @@
- This is a first draft of the CONFIGURATION MANAGER demonstrator.
- Unfortunately, there are still bugs in those tools.
- I will continue to work on it next year, to fix those bugs and add some
- improvement as handle north fold...
+This is a first release of SIREN.
- '''WARNING : there are still bugs to fix in those tools!! '''
+To create SIREN documentation, go to ./src and run doxygen
+(http://www.stack.nl/~dimitri/doxygen/index.html version 1.8.3.1 or upper)
+then
+ open ../doc/index.html
+or
+ run ../doc/latex/gmake and open refman.pdf
- ''''''
+
+templates of namelists could be find in templates directory.
+read documentation for more information.
1- program to create coordinate file :
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/cfg/variable.cfg
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/cfg/variable.cfg (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/cfg/variable.cfg (revision 5214)
@@ -1,37 +1,73 @@
-# name | units | axis | point | standard name | long name | interpolation
-X | 1 | X | | projection_x_coordinate | |
-Y | 1 | Y | | projection_y_coordinate | |
-Z | 1 | Z | | projection_z_coordinate | |
-T | 1 | T | | projection_t_coordinate | |
-nav_lon | degrees_east | XY | T | longitude | Longitude | cubic
-nav_lat | degrees_north | XY | T | latitude | Latitude | cubic
-nav_lev | model_levels | Z | T | | Model levels | cubic
-deptht | m | Z | T | depth | Vertical T levels |
-time_counter | | T | | time | Time axis |
-Bathymetry | m | XY | T | bathymetry | Bathymetry | cubic
-votemper | degree_Celsius | XYZT | T | sea_water_potential_temperature | Temperature | cubic
-vozocrtx | m s-1 | XYZT | U | | Zonal velocity | cubic
-vomecrty | m s-1 | XYZT | V | | Meridional velocity| cubic
-vosaline | PSU | XYZT | T | sea_water_salinity | Salinity | cubic
-sossheig | m | XYT | T | sea_surface_height | Sea Surface Height | cubic
-glamt | degrees_east | XY | T | | Longitude_T | cubic
-glamu | degrees_east | XY | U | | Longitude_U | cubic
-glamv | degrees_east | XY | V | | Longitude_V | cubic
-glamf | degrees_east | XY | F | | Longitude_F | cubic
-gphit | degrees_north | XY | T | | Latitude_T | cubic
-gphiu | degrees_north | XY | U | | Latitude_U | cubic
-gphiv | degrees_north | XY | V | | Latitude_V | cubic
-gphif | degrees_north | XY | F | | Latitude_F | cubic
-e1t | m | XY | T | | | cubic/rhoi
-e1u | m | XY | U | | | cubic/rhoi
-e1v | m | XY | V | | | cubic/rhoi
-e1f | m | XY | F | | | cubic/rhoi
-e2t | m | XY | T | | | cubic/rhoj
-e2u | m | XY | U | | | cubic/rhoj
-e2v | m | XY | V | | | cubic/rhoj
-e2f | m | XY | F | | | cubic/rhoj
-tmask | | XYZ | T | | | nearest
-umask | | XYZ | U | | | nearest
-vmask | | XYZ | V | | | nearest
-fmask | | XYZ | F | | | nearest
-weight | | XY | T | | |
+# name | units | axis | point | standard name | long name | interpolation
+X | 1 | X | | projection_x_coordinate | |
+Y | 1 | Y | | projection_y_coordinate | |
+Z | 1 | Z | | projection_z_coordinate | |
+T | 1 | T | | projection_t_coordinate | |
+nav_lon | degrees_east | XY | T | longitude | Longitude | cubic
+nav_lat | degrees_north | XY | T | latitude | Latitude | cubic
+nav_lev | model_levels | Z | T | | Model levels | cubic
+deptht | m | Z | T | depth | Vertical T levels |
+time_counter | | T | | time | Time axis |
+Bathymetry | m | XY | T | bathymetry | Bathymetry | cubic
+votemper | degree_Celsius | XYZT | T | sea_water_potential_temperature | Temperature | cubic
+vozocrtx | m s-1 | XYZT | U | | Zonal velocity | cubic
+vomecrty | m s-1 | XYZT | V | | Meridional velocity| cubic
+vosaline | PSU | XYZT | T | sea_water_salinity | Salinity | cubic
+sossheig | m | XYT | T | sea_surface_height | Sea Surface Height | cubic
+glamt | degrees_east | XY | T | | Longitude_T | cubic
+glamu | degrees_east | XY | U | | Longitude_U | cubic
+glamv | degrees_east | XY | V | | Longitude_V | cubic
+glamf | degrees_east | XY | F | | Longitude_F | cubic
+gphit | degrees_north | XY | T | | Latitude_T | cubic
+gphiu | degrees_north | XY | U | | Latitude_U | cubic
+gphiv | degrees_north | XY | V | | Latitude_V | cubic
+gphif | degrees_north | XY | F | | Latitude_F | cubic
+e1t | m | XY | T | | | cubic/rhoi
+e1u | m | XY | U | | | cubic/rhoi
+e1v | m | XY | V | | | cubic/rhoi
+e1f | m | XY | F | | | cubic/rhoi
+e2t | m | XY | T | | | cubic/rhoj
+e2u | m | XY | U | | | cubic/rhoj
+e2v | m | XY | V | | | cubic/rhoj
+e2f | m | XY | F | | | cubic/rhoj
+tmask | | XYZ | T | | | nearest
+umask | | XYZ | U | | | nearest
+vmask | | XYZ | V | | | nearest
+fmask | | XYZ | F | | | nearest
+weight | | XY | T | | |
+kt | | | | | |
+ndastp | | | | | |
+adatrj | | | | | |
+kt | | | | | |
+rdt | | | | | |
+rdttra1 | | | | | |
+utau_b | | XYT | U |surface_downward_eastward_stress | |
+vtau_b | | XYT | V |surface_downward_northward_stress | |
+qns_b | | XYT | T | | |
+emp_b | | XYT | T | | |
+sfx_b | | XYT | T | | |
+en | | XYZT | T | | |
+avt | | XYZT | T | | |
+avm | | XYZT | T | | |
+avmu | | XYZT | T | | |
+avmv | | XYZT | T | | |
+dissl | | XYZT | T | | |
+sbc_hc_b | | XYT | T | | |
+sbc_sc_b | | XYT | T | | |
+gcx | | XYT | T | | |
+gcxb | | XYT | T | | |
+ub | | XYZT | U | | |
+vb | | XYZT | V | | |
+tb | | XYZT | T | | |
+sb | | XYZT | T | | |
+rotb | | XYZT | T | | |
+hdivb | | XYZT | T | | |
+sshb | | XYT | T | | |
+un | | XYZT | U | | |
+vn | | XYZT | V | | |
+tn | | XYZT | T | | |
+sn | | XYZT | T | | |
+rotn | | XYZT | T | | |
+hdivn | | XYZT | T | | |
+sshn | | XYT | T | | |
+rhop | | XYZT | T | | |
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/Doxyfile
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/Doxyfile (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/Doxyfile (revision 5214)
@@ -1,13 +1,16 @@
-# Doxyfile 1.6.1
+# Doxyfile 1.8.8
# This file describes the settings to be used by the documentation system
-# doxygen (www.doxygen.org) for a project
-#
-# All text after a hash (#) is considered a comment and will be ignored
+# doxygen (www.doxygen.org) for a project.
+#
+# All text after a double hash (##) is considered a comment and is placed in
+# front of the TAG it is preceding.
+#
+# All text after a single hash (#) is considered a comment and will be ignored.
# The format is:
-# TAG = value [value, ...]
-# For lists items can also be appended using:
-# TAG += value [value, ...]
-# Values that contain spaces should be placed between quotes (" ")
+# TAG = value [value, ...]
+# For lists, items can also be appended using:
+# TAG += value [value, ...]
+# Values that contain spaces should be placed between quotes (\" \").
#---------------------------------------------------------------------------
@@ -16,80 +19,110 @@
# This tag specifies the encoding used for all characters in the config file
-# that follow. The default is UTF-8 which is also the encoding used for all
-# text before the first occurrence of this tag. Doxygen uses libiconv (or the
-# iconv built into libc) for the transcoding. See
-# http://www.gnu.org/software/libiconv for the list of possible encodings.
+# that follow. The default is UTF-8 which is also the encoding used for all text
+# before the first occurrence of this tag. Doxygen uses libiconv (or the iconv
+# built into libc) for the transcoding. See http://www.gnu.org/software/libiconv
+# for the list of possible encodings.
+# The default value is: UTF-8.
DOXYFILE_ENCODING = UTF-8
-# The PROJECT_NAME tag is a single word (or a sequence of words surrounded
-# by quotes) that should identify the project.
-
-PROJECT_NAME = Doxygen Fortran Example
-
-# The PROJECT_NUMBER tag can be used to enter a project or revision number.
-# This could be handy for archiving the generated documentation or
-# if some version control system is used.
-
-PROJECT_NUMBER =
-
-# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute)
-# base path where the generated documentation will be put.
-# If a relative path is entered, it will be relative to the location
-# where doxygen was started. If left blank the current directory will be used.
-
-OUTPUT_DIRECTORY =
-
-# If the CREATE_SUBDIRS tag is set to YES, then doxygen will create
-# 4096 sub-directories (in 2 levels) under the output directory of each output
-# format and will distribute the generated files over these directories.
-# Enabling this option can be useful when feeding doxygen a huge amount of
-# source files, where putting all generated files in the same directory would
-# otherwise cause performance problems for the file system.
+# The PROJECT_NAME tag is a single word (or a sequence of words surrounded by
+# double-quotes, unless you are using Doxywizard) that should identify the
+# project for which the documentation is generated. This name is used in the
+# title of most generated pages and in a few other places.
+# The default value is: My Project.
+
+PROJECT_NAME = "SIREN"
+
+# The PROJECT_NUMBER tag can be used to enter a project or revision number. This
+# could be handy for archiving the generated documentation or if some version
+# control system is used.
+
+PROJECT_NUMBER = "NEMO 3.6"
+
+# Using the PROJECT_BRIEF tag one can provide an optional one line description
+# for a project that appears at the top of each page and should give viewer a
+# quick idea about the purpose of the project. Keep the description short.
+
+PROJECT_BRIEF = "System and Interface for oceanic RElocable Nesting"
+
+# With the PROJECT_LOGO tag one can specify an logo or icon that is included in
+# the documentation. The maximum height of the logo should not exceed 55 pixels
+# and the maximum width should not exceed 200 pixels. Doxygen will copy the logo
+# to the output directory.
+
+PROJECT_LOGO = ./docsrc/Image/logoSirenNemo.png
+
+# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path
+# into which the generated documentation will be written. If a relative path is
+# entered, it will be relative to the location where doxygen was started. If
+# left blank the current directory will be used.
+
+OUTPUT_DIRECTORY = ../doc
+
+# If the CREATE_SUBDIRS tag is set to YES, then doxygen will create 4096 sub-
+# directories (in 2 levels) under the output directory of each output format and
+# will distribute the generated files over these directories. Enabling this
+# option can be useful when feeding doxygen a huge amount of source files, where
+# putting all generated files in the same directory would otherwise causes
+# performance problems for the file system.
+# The default value is: NO.
CREATE_SUBDIRS = NO
+
+# If the ALLOW_UNICODE_NAMES tag is set to YES, doxygen will allow non-ASCII
+# characters to appear in the names of generated files. If set to NO, non-ASCII
+# characters will be escaped, for example _xE3_x81_x84 will be used for Unicode
+# U+3044.
+# The default value is: NO.
+
+ALLOW_UNICODE_NAMES = NO
# The OUTPUT_LANGUAGE tag is used to specify the language in which all
# documentation generated by doxygen is written. Doxygen will use this
# information to generate all constant output in the proper language.
-# The default language is English, other supported languages are:
-# Afrikaans, Arabic, Brazilian, Catalan, Chinese, Chinese-Traditional,
-# Croatian, Czech, Danish, Dutch, Esperanto, Farsi, Finnish, French, German,
-# Greek, Hungarian, Italian, Japanese, Japanese-en (Japanese with English
-# messages), Korean, Korean-en, Lithuanian, Norwegian, Macedonian, Persian,
-# Polish, Portuguese, Romanian, Russian, Serbian, Serbian-Cyrilic, Slovak,
-# Slovene, Spanish, Swedish, Ukrainian, and Vietnamese.
+# Possible values are: Afrikaans, Arabic, Armenian, Brazilian, Catalan, Chinese,
+# Chinese-Traditional, Croatian, Czech, Danish, Dutch, English (United States),
+# Esperanto, Farsi (Persian), Finnish, French, German, Greek, Hungarian,
+# Indonesian, Italian, Japanese, Japanese-en (Japanese with English messages),
+# Korean, Korean-en (Korean with English messages), Latvian, Lithuanian,
+# Macedonian, Norwegian, Persian (Farsi), Polish, Portuguese, Romanian, Russian,
+# Serbian, Serbian-Cyrillic, Slovak, Slovene, Spanish, Swedish, Turkish,
+# Ukrainian and Vietnamese.
+# The default value is: English.
OUTPUT_LANGUAGE = English
-# If the BRIEF_MEMBER_DESC tag is set to YES (the default) Doxygen will
-# include brief member descriptions after the members that are listed in
-# the file and class documentation (similar to JavaDoc).
-# Set to NO to disable this.
+# If the BRIEF_MEMBER_DESC tag is set to YES doxygen will include brief member
+# descriptions after the members that are listed in the file and class
+# documentation (similar to Javadoc). Set to NO to disable this.
+# The default value is: YES.
BRIEF_MEMBER_DESC = YES
-# If the REPEAT_BRIEF tag is set to YES (the default) Doxygen will prepend
-# the brief description of a member or function before the detailed description.
-# Note: if both HIDE_UNDOC_MEMBERS and BRIEF_MEMBER_DESC are set to NO, the
+# If the REPEAT_BRIEF tag is set to YES doxygen will prepend the brief
+# description of a member or function before the detailed description
+#
+# Note: If both HIDE_UNDOC_MEMBERS and BRIEF_MEMBER_DESC are set to NO, the
# brief descriptions will be completely suppressed.
+# The default value is: YES.
REPEAT_BRIEF = YES
-# This tag implements a quasi-intelligent brief description abbreviator
-# that is used to form the text in various listings. Each string
-# in this list, if found as the leading text of the brief description, will be
-# stripped from the text and the result after processing the whole list, is
-# used as the annotated text. Otherwise, the brief description is used as-is.
-# If left blank, the following values are used ("$name" is automatically
-# replaced with the name of the entity): "The $name class" "The $name widget"
-# "The $name file" "is" "provides" "specifies" "contains"
-# "represents" "a" "an" "the"
+# This tag implements a quasi-intelligent brief description abbreviator that is
+# used to form the text in various listings. Each string in this list, if found
+# as the leading text of the brief description, will be stripped from the text
+# and the result, after processing the whole list, is used as the annotated
+# text. Otherwise, the brief description is used as-is. If left blank, the
+# following values are used ($name is automatically replaced with the name of
+# the entity):The $name class, The $name widget, The $name file, is, provides,
+# specifies, contains, represents, a, an and the.
ABBREVIATE_BRIEF =
# If the ALWAYS_DETAILED_SEC and REPEAT_BRIEF tags are both set to YES then
-# Doxygen will generate a detailed section even if there is only a brief
+# doxygen will generate a detailed section even if there is only a brief
# description.
+# The default value is: NO.
ALWAYS_DETAILED_SEC = NO
@@ -99,130 +132,181 @@
# members were ordinary class members. Constructors, destructors and assignment
# operators of the base classes will not be shown.
+# The default value is: NO.
INLINE_INHERITED_MEMB = NO
-# If the FULL_PATH_NAMES tag is set to YES then Doxygen will prepend the full
-# path before files name in the file list and in the header files. If set
-# to NO the shortest path that makes the file name unique will be used.
+# If the FULL_PATH_NAMES tag is set to YES doxygen will prepend the full path
+# before files name in the file list and in the header files. If set to NO the
+# shortest path that makes the file name unique will be used
+# The default value is: YES.
FULL_PATH_NAMES = YES
-# If the FULL_PATH_NAMES tag is set to YES then the STRIP_FROM_PATH tag
-# can be used to strip a user-defined part of the path. Stripping is
-# only done if one of the specified strings matches the left-hand part of
-# the path. The tag can be used to show relative paths in the file list.
-# If left blank the directory from which doxygen is run is used as the
-# path to strip.
+# The STRIP_FROM_PATH tag can be used to strip a user-defined part of the path.
+# Stripping is only done if one of the specified strings matches the left-hand
+# part of the path. The tag can be used to show relative paths in the file list.
+# If left blank the directory from which doxygen is run is used as the path to
+# strip.
+#
+# Note that you can specify absolute paths here, but also relative paths, which
+# will be relative from the directory where doxygen is started.
+# This tag requires that the tag FULL_PATH_NAMES is set to YES.
STRIP_FROM_PATH =
-# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of
-# the path mentioned in the documentation of a class, which tells
-# the reader which header file to include in order to use a class.
-# If left blank only the name of the header file containing the class
-# definition is used. Otherwise one should specify the include paths that
-# are normally passed to the compiler using the -I flag.
+# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the
+# path mentioned in the documentation of a class, which tells the reader which
+# header file to include in order to use a class. If left blank only the name of
+# the header file containing the class definition is used. Otherwise one should
+# specify the list of include paths that are normally passed to the compiler
+# using the -I flag.
STRIP_FROM_INC_PATH =
-# If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter
-# (but less readable) file names. This can be useful is your file systems
-# doesn't support long names like on DOS, Mac, or CD-ROM.
+# If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter (but
+# less readable) file names. This can be useful is your file systems doesn't
+# support long names like on DOS, Mac, or CD-ROM.
+# The default value is: NO.
SHORT_NAMES = NO
-# If the JAVADOC_AUTOBRIEF tag is set to YES then Doxygen
-# will interpret the first line (until the first dot) of a JavaDoc-style
-# comment as the brief description. If set to NO, the JavaDoc
-# comments will behave just like regular Qt-style comments
-# (thus requiring an explicit @brief command for a brief description.)
+# If the JAVADOC_AUTOBRIEF tag is set to YES then doxygen will interpret the
+# first line (until the first dot) of a Javadoc-style comment as the brief
+# description. If set to NO, the Javadoc-style will behave just like regular Qt-
+# style comments (thus requiring an explicit @brief command for a brief
+# description.)
+# The default value is: NO.
JAVADOC_AUTOBRIEF = NO
-# If the QT_AUTOBRIEF tag is set to YES then Doxygen will
-# interpret the first line (until the first dot) of a Qt-style
-# comment as the brief description. If set to NO, the comments
-# will behave just like regular Qt-style comments (thus requiring
-# an explicit \brief command for a brief description.)
+# If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first
+# line (until the first dot) of a Qt-style comment as the brief description. If
+# set to NO, the Qt-style will behave just like regular Qt-style comments (thus
+# requiring an explicit \brief command for a brief description.)
+# The default value is: NO.
QT_AUTOBRIEF = NO
-# The MULTILINE_CPP_IS_BRIEF tag can be set to YES to make Doxygen
-# treat a multi-line C++ special comment block (i.e. a block of //! or ///
-# comments) as a brief description. This used to be the default behaviour.
-# The new default is to treat a multi-line C++ comment block as a detailed
-# description. Set this tag to YES if you prefer the old behaviour instead.
+# The MULTILINE_CPP_IS_BRIEF tag can be set to YES to make doxygen treat a
+# multi-line C++ special comment block (i.e. a block of //! or /// comments) as
+# a brief description. This used to be the default behavior. The new default is
+# to treat a multi-line C++ comment block as a detailed description. Set this
+# tag to YES if you prefer the old behavior instead.
+#
+# Note that setting this tag to YES also means that rational rose comments are
+# not recognized any more.
+# The default value is: NO.
MULTILINE_CPP_IS_BRIEF = NO
-# If the INHERIT_DOCS tag is set to YES (the default) then an undocumented
-# member inherits the documentation from any documented member that it
-# re-implements.
+# If the INHERIT_DOCS tag is set to YES then an undocumented member inherits the
+# documentation from any documented member that it re-implements.
+# The default value is: YES.
INHERIT_DOCS = YES
-# If the SEPARATE_MEMBER_PAGES tag is set to YES, then doxygen will produce
-# a new page for each member. If set to NO, the documentation of a member will
-# be part of the file/class/namespace that contains it.
+# If the SEPARATE_MEMBER_PAGES tag is set to YES, then doxygen will produce a
+# new page for each member. If set to NO, the documentation of a member will be
+# part of the file/class/namespace that contains it.
+# The default value is: NO.
SEPARATE_MEMBER_PAGES = NO
-# The TAB_SIZE tag can be used to set the number of spaces in a tab.
-# Doxygen uses this value to replace tabs by spaces in code fragments.
-
-TAB_SIZE = 8
-
-# This tag can be used to specify a number of aliases that acts
-# as commands in the documentation. An alias has the form "name=value".
-# For example adding "sideeffect=\par Side Effects:\n" will allow you to
-# put the command \sideeffect (or @sideeffect) in the documentation, which
-# will result in a user-defined paragraph with heading "Side Effects:".
-# You can put \n's in the value part of an alias to insert newlines.
+# The TAB_SIZE tag can be used to set the number of spaces in a tab. Doxygen
+# uses this value to replace tabs by spaces in code fragments.
+# Minimum value: 1, maximum value: 16, default value: 4.
+
+TAB_SIZE = 3
+
+# This tag can be used to specify a number of aliases that act as commands in
+# the documentation. An alias has the form:
+# name=value
+# For example adding
+# "sideeffect=@par Side Effects:\n"
+# will allow you to put the command \sideeffect (or @sideeffect) in the
+# documentation, which will result in a user-defined paragraph with heading
+# "Side Effects:". You can put \n's in the value part of an alias to insert
+# newlines.
ALIASES =
-# Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C
-# sources only. Doxygen will then generate output that is more tailored for C.
-# For instance, some of the names that are used will be different. The list
-# of all members will be omitted, etc.
+# This tag can be used to specify a number of word-keyword mappings (TCL only).
+# A mapping has the form "name=value". For example adding "class=itcl::class"
+# will allow you to use the command class in the itcl::class meaning.
+
+TCL_SUBST =
+
+# Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources
+# only. Doxygen will then generate output that is more tailored for C. For
+# instance, some of the names that are used will be different. The list of all
+# members will be omitted, etc.
+# The default value is: NO.
OPTIMIZE_OUTPUT_FOR_C = NO
-# Set the OPTIMIZE_OUTPUT_JAVA tag to YES if your project consists of Java
-# sources only. Doxygen will then generate output that is more tailored for
-# Java. For instance, namespaces will be presented as packages, qualified
-# scopes will look different, etc.
+# Set the OPTIMIZE_OUTPUT_JAVA tag to YES if your project consists of Java or
+# Python sources only. Doxygen will then generate output that is more tailored
+# for that language. For instance, namespaces will be presented as packages,
+# qualified scopes will look different, etc.
+# The default value is: NO.
OPTIMIZE_OUTPUT_JAVA = NO
# Set the OPTIMIZE_FOR_FORTRAN tag to YES if your project consists of Fortran
-# sources only. Doxygen will then generate output that is more tailored for
-# Fortran.
-
-OPTIMIZE_FOR_FORTRAN = YES
+# sources. Doxygen will then generate output that is tailored for Fortran.
+# The default value is: NO.
+
+OPTIMIZE_FOR_FORTRAN = NO
# Set the OPTIMIZE_OUTPUT_VHDL tag to YES if your project consists of VHDL
-# sources. Doxygen will then generate output that is tailored for
-# VHDL.
+# sources. Doxygen will then generate output that is tailored for VHDL.
+# The default value is: NO.
OPTIMIZE_OUTPUT_VHDL = NO
-# Doxygen selects the parser to use depending on the extension of the files it parses.
-# With this tag you can assign which parser to use for a given extension.
-# Doxygen has a built-in mapping, but you can override or extend it using this tag.
-# The format is ext=language, where ext is a file extension, and language is one of
-# the parsers supported by doxygen: IDL, Java, Javascript, C#, C, C++, D, PHP,
-# Objective-C, Python, Fortran, VHDL, C, C++. For instance to make doxygen treat
-# .inc files as Fortran files (default is PHP), and .f files as C (default is Fortran),
-# use: inc=Fortran f=C. Note that for custom extensions you also need to set FILE_PATTERNS otherwise the files are not read by doxygen.
-
-EXTENSION_MAPPING =
+# Doxygen selects the parser to use depending on the extension of the files it
+# parses. With this tag you can assign which parser to use for a given
+# extension. Doxygen has a built-in mapping, but you can override or extend it
+# using this tag. The format is ext=language, where ext is a file extension, and
+# language is one of the parsers supported by doxygen: IDL, Java, Javascript,
+# C#, C, C++, D, PHP, Objective-C, Python, Fortran (fixed format Fortran:
+# FortranFixed, free formatted Fortran: FortranFree, unknown formatted Fortran:
+# Fortran. In the later case the parser tries to guess whether the code is fixed
+# or free formatted code, this is the default for Fortran type files), VHDL. For
+# instance to make doxygen treat .inc files as Fortran files (default is PHP),
+# and .f files as C (default is Fortran), use: inc=Fortran f=C.
+#
+# Note For files without extension you can use no_extension as a placeholder.
+#
+# Note that for custom extensions you also need to set FILE_PATTERNS otherwise
+# the files are not read by doxygen.
+
+EXTENSION_MAPPING =
+
+# If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments
+# according to the Markdown format, which allows for more readable
+# documentation. See http://daringfireball.net/projects/markdown/ for details.
+# The output of markdown processing is further processed by doxygen, so you can
+# mix doxygen, HTML, and XML commands with Markdown formatting. Disable only in
+# case of backward compatibilities issues.
+# The default value is: YES.
+
+MARKDOWN_SUPPORT = YES
+
+# When enabled doxygen tries to link words that correspond to documented
+# classes, or namespaces to their corresponding documentation. Such a link can
+# be prevented in individual cases by by putting a % sign in front of the word
+# or globally by setting AUTOLINK_SUPPORT to NO.
+# The default value is: YES.
+
+AUTOLINK_SUPPORT = YES
# If you use STL classes (i.e. std::string, std::vector, etc.) but do not want
-# to include (a tag file for) the STL sources as input, then you should
-# set this tag to YES in order to let doxygen match functions declarations and
-# definitions whose arguments contain STL classes (e.g. func(std::string); v.s.
-# func(std::string) {}). This also make the inheritance and collaboration
+# to include (a tag file for) the STL sources as input, then you should set this
+# tag to YES in order to let doxygen match functions declarations and
+# definitions whose arguments contain STL classes (e.g. func(std::string);
+# versus func(std::string) {}). This also make the inheritance and collaboration
# diagrams that involve STL classes more complete and accurate.
+# The default value is: NO.
BUILTIN_STL_SUPPORT = NO
@@ -230,19 +314,23 @@
# If you use Microsoft's C++/CLI language, you should set this option to YES to
# enable parsing support.
+# The default value is: NO.
CPP_CLI_SUPPORT = NO
-# Set the SIP_SUPPORT tag to YES if your project consists of sip sources only.
-# Doxygen will parse them like normal C++ but will assume all classes use public
-# instead of private inheritance when no explicit protection keyword is present.
+# Set the SIP_SUPPORT tag to YES if your project consists of sip (see:
+# http://www.riverbankcomputing.co.uk/software/sip/intro) sources only. Doxygen
+# will parse them like normal C++ but will assume all classes use public instead
+# of private inheritance when no explicit protection keyword is present.
+# The default value is: NO.
SIP_SUPPORT = NO
-# For Microsoft's IDL there are propget and propput attributes to indicate getter
-# and setter methods for a property. Setting this option to YES (the default)
-# will make doxygen to replace the get and set methods by a property in the
-# documentation. This will only work if the methods are indeed getting or
-# setting a simple type. If this is not the case, or you want to show the
-# methods anyway, you should set this option to NO.
+# For Microsoft's IDL there are propget and propput attributes to indicate
+# getter and setter methods for a property. Setting this option to YES will make
+# doxygen to replace the get and set methods by a property in the documentation.
+# This will only work if the methods are indeed getting or setting a simple
+# type. If this is not the case, or you want to show the methods anyway, you
+# should set this option to NO.
+# The default value is: YES.
IDL_PROPERTY_SUPPORT = YES
@@ -252,40 +340,61 @@
# member in the group (if any) for the other members of the group. By default
# all members of a group must be documented explicitly.
+# The default value is: NO.
DISTRIBUTE_GROUP_DOC = NO
-# Set the SUBGROUPING tag to YES (the default) to allow class member groups of
-# the same type (for instance a group of public functions) to be put as a
-# subgroup of that type (e.g. under the Public Functions section). Set it to
-# NO to prevent subgrouping. Alternatively, this can be done per class using
-# the \nosubgrouping command.
+# Set the SUBGROUPING tag to YES to allow class member groups of the same type
+# (for instance a group of public functions) to be put as a subgroup of that
+# type (e.g. under the Public Functions section). Set it to NO to prevent
+# subgrouping. Alternatively, this can be done per class using the
+# \nosubgrouping command.
+# The default value is: YES.
SUBGROUPING = YES
-# When TYPEDEF_HIDES_STRUCT is enabled, a typedef of a struct, union, or enum
-# is documented as struct, union, or enum with the name of the typedef. So
+# When the INLINE_GROUPED_CLASSES tag is set to YES, classes, structs and unions
+# are shown inside the group in which they are included (e.g. using \ingroup)
+# instead of on a separate page (for HTML and Man pages) or section (for LaTeX
+# and RTF).
+#
+# Note that this feature does not work in combination with
+# SEPARATE_MEMBER_PAGES.
+# The default value is: NO.
+
+INLINE_GROUPED_CLASSES = NO
+
+# When the INLINE_SIMPLE_STRUCTS tag is set to YES, structs, classes, and unions
+# with only public data fields or simple typedef fields will be shown inline in
+# the documentation of the scope in which they are defined (i.e. file,
+# namespace, or group documentation), provided this scope is documented. If set
+# to NO, structs, classes, and unions are shown on a separate page (for HTML and
+# Man pages) or section (for LaTeX and RTF).
+# The default value is: NO.
+
+INLINE_SIMPLE_STRUCTS = NO
+
+# When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or
+# enum is documented as struct, union, or enum with the name of the typedef. So
# typedef struct TypeS {} TypeT, will appear in the documentation as a struct
# with name TypeT. When disabled the typedef will appear as a member of a file,
-# namespace, or class. And the struct will be named TypeS. This can typically
-# be useful for C code in case the coding convention dictates that all compound
+# namespace, or class. And the struct will be named TypeS. This can typically be
+# useful for C code in case the coding convention dictates that all compound
# types are typedef'ed and only the typedef is referenced, never the tag name.
+# The default value is: NO.
TYPEDEF_HIDES_STRUCT = NO
-# The SYMBOL_CACHE_SIZE determines the size of the internal cache use to
-# determine which symbols to keep in memory and which to flush to disk.
-# When the cache is full, less often used symbols will be written to disk.
-# For small to medium size projects (<1000 input files) the default value is
-# probably good enough. For larger projects a too small cache size can cause
-# doxygen to be busy swapping symbols to and from disk most of the time
-# causing a significant performance penality.
-# If the system has enough physical memory increasing the cache will improve the
-# performance by keeping more symbols in memory. Note that the value works on
-# a logarithmic scale so increasing the size by one will rougly double the
-# memory usage. The cache size is given by this formula:
-# 2^(16+SYMBOL_CACHE_SIZE). The valid range is 0..9, the default is 0,
-# corresponding to a cache size of 2^16 = 65536 symbols
-
-SYMBOL_CACHE_SIZE = 0
+# The size of the symbol lookup cache can be set using LOOKUP_CACHE_SIZE. This
+# cache is used to resolve symbols given their name and scope. Since this can be
+# an expensive process and often the same symbol appears multiple times in the
+# code, doxygen keeps a cache of pre-resolved symbols. If the cache is too small
+# doxygen will become slower. If the cache is too large, memory is wasted. The
+# cache size is given by this formula: 2^(16+LOOKUP_CACHE_SIZE). The valid range
+# is 0..9, the default is 0, corresponding to a cache size of 2^16=65536
+# symbols. At the end of a run doxygen will report the cache usage and suggest
+# the optimal cache size from a speed point of view.
+# Minimum value: 0, maximum value: 9, default value: 0.
+
+LOOKUP_CACHE_SIZE = 0
#---------------------------------------------------------------------------
@@ -294,30 +403,44 @@
# If the EXTRACT_ALL tag is set to YES doxygen will assume all entities in
-# documentation are documented, even if no documentation was available.
-# Private class members and static file members will be hidden unless
-# the EXTRACT_PRIVATE and EXTRACT_STATIC tags are set to YES
-
-EXTRACT_ALL = YES
-
-# If the EXTRACT_PRIVATE tag is set to YES all private members of a class
-# will be included in the documentation.
+# documentation are documented, even if no documentation was available. Private
+# class members and static file members will be hidden unless the
+# EXTRACT_PRIVATE respectively EXTRACT_STATIC tags are set to YES.
+# Note: This will also disable the warnings about undocumented members that are
+# normally produced when WARNINGS is set to YES.
+# The default value is: NO.
+
+EXTRACT_ALL = NO
+
+# If the EXTRACT_PRIVATE tag is set to YES all private members of a class will
+# be included in the documentation.
+# The default value is: NO.
EXTRACT_PRIVATE = NO
-# If the EXTRACT_STATIC tag is set to YES all static members of a file
-# will be included in the documentation.
+# If the EXTRACT_PACKAGE tag is set to YES all members with package or internal
+# scope will be included in the documentation.
+# The default value is: NO.
+
+EXTRACT_PACKAGE = NO
+
+# If the EXTRACT_STATIC tag is set to YES all static members of a file will be
+# included in the documentation.
+# The default value is: NO.
EXTRACT_STATIC = NO
-# If the EXTRACT_LOCAL_CLASSES tag is set to YES classes (and structs)
-# defined locally in source files will be included in the documentation.
-# If set to NO only classes defined in header files are included.
+# If the EXTRACT_LOCAL_CLASSES tag is set to YES classes (and structs) defined
+# locally in source files will be included in the documentation. If set to NO
+# only classes defined in header files are included. Does not have any effect
+# for Java sources.
+# The default value is: YES.
EXTRACT_LOCAL_CLASSES = YES
-# This flag is only useful for Objective-C code. When set to YES local
-# methods, which are defined in the implementation section but not in
-# the interface are included in the documentation.
-# If set to NO (the default) only methods in the interface are included.
+# This flag is only useful for Objective-C code. When set to YES local methods,
+# which are defined in the implementation section but not in the interface are
+# included in the documentation. If set to NO only methods in the interface are
+# included.
+# The default value is: NO.
EXTRACT_LOCAL_METHODS = NO
@@ -325,166 +448,205 @@
# If this flag is set to YES, the members of anonymous namespaces will be
# extracted and appear in the documentation as a namespace called
-# 'anonymous_namespace{file}', where file will be replaced with the base
-# name of the file that contains the anonymous namespace. By default
-# anonymous namespace are hidden.
+# 'anonymous_namespace{file}', where file will be replaced with the base name of
+# the file that contains the anonymous namespace. By default anonymous namespace
+# are hidden.
+# The default value is: NO.
EXTRACT_ANON_NSPACES = NO
-# If the HIDE_UNDOC_MEMBERS tag is set to YES, Doxygen will hide all
-# undocumented members of documented classes, files or namespaces.
-# If set to NO (the default) these members will be included in the
-# various overviews, but no documentation section is generated.
-# This option has no effect if EXTRACT_ALL is enabled.
+# If the HIDE_UNDOC_MEMBERS tag is set to YES, doxygen will hide all
+# undocumented members inside documented classes or files. If set to NO these
+# members will be included in the various overviews, but no documentation
+# section is generated. This option has no effect if EXTRACT_ALL is enabled.
+# The default value is: NO.
HIDE_UNDOC_MEMBERS = NO
-# If the HIDE_UNDOC_CLASSES tag is set to YES, Doxygen will hide all
-# undocumented classes that are normally visible in the class hierarchy.
-# If set to NO (the default) these classes will be included in the various
-# overviews. This option has no effect if EXTRACT_ALL is enabled.
+# If the HIDE_UNDOC_CLASSES tag is set to YES, doxygen will hide all
+# undocumented classes that are normally visible in the class hierarchy. If set
+# to NO these classes will be included in the various overviews. This option has
+# no effect if EXTRACT_ALL is enabled.
+# The default value is: NO.
HIDE_UNDOC_CLASSES = NO
-# If the HIDE_FRIEND_COMPOUNDS tag is set to YES, Doxygen will hide all
-# friend (class|struct|union) declarations.
-# If set to NO (the default) these declarations will be included in the
-# documentation.
+# If the HIDE_FRIEND_COMPOUNDS tag is set to YES, doxygen will hide all friend
+# (class|struct|union) declarations. If set to NO these declarations will be
+# included in the documentation.
+# The default value is: NO.
HIDE_FRIEND_COMPOUNDS = NO
-# If the HIDE_IN_BODY_DOCS tag is set to YES, Doxygen will hide any
-# documentation blocks found inside the body of a function.
-# If set to NO (the default) these blocks will be appended to the
-# function's detailed documentation block.
+# If the HIDE_IN_BODY_DOCS tag is set to YES, doxygen will hide any
+# documentation blocks found inside the body of a function. If set to NO these
+# blocks will be appended to the function's detailed documentation block.
+# The default value is: NO.
HIDE_IN_BODY_DOCS = NO
-# The INTERNAL_DOCS tag determines if documentation
-# that is typed after a \internal command is included. If the tag is set
-# to NO (the default) then the documentation will be excluded.
-# Set it to YES to include the internal documentation.
+# The INTERNAL_DOCS tag determines if documentation that is typed after a
+# \internal command is included. If the tag is set to NO then the documentation
+# will be excluded. Set it to YES to include the internal documentation.
+# The default value is: NO.
INTERNAL_DOCS = NO
-# If the CASE_SENSE_NAMES tag is set to NO then Doxygen will only generate
-# file names in lower-case letters. If set to YES upper-case letters are also
+# If the CASE_SENSE_NAMES tag is set to NO then doxygen will only generate file
+# names in lower-case letters. If set to YES upper-case letters are also
# allowed. This is useful if you have classes or files whose names only differ
# in case and if your file system supports case sensitive file names. Windows
# and Mac users are advised to set this option to NO.
+# The default value is: system dependent.
CASE_SENSE_NAMES = YES
-# If the HIDE_SCOPE_NAMES tag is set to NO (the default) then Doxygen
-# will show members with their full class and namespace scopes in the
-# documentation. If set to YES the scope will be hidden.
+# If the HIDE_SCOPE_NAMES tag is set to NO then doxygen will show members with
+# their full class and namespace scopes in the documentation. If set to YES the
+# scope will be hidden.
+# The default value is: NO.
HIDE_SCOPE_NAMES = NO
-# If the SHOW_INCLUDE_FILES tag is set to YES (the default) then Doxygen
-# will put a list of the files that are included by a file in the documentation
-# of that file.
+# If the SHOW_INCLUDE_FILES tag is set to YES then doxygen will put a list of
+# the files that are included by a file in the documentation of that file.
+# The default value is: YES.
SHOW_INCLUDE_FILES = YES
-# If the INLINE_INFO tag is set to YES (the default) then a tag [inline]
-# is inserted in the documentation for inline members.
+# If the SHOW_GROUPED_MEMB_INC tag is set to YES then Doxygen will add for each
+# grouped member an include statement to the documentation, telling the reader
+# which file to include in order to use the member.
+# The default value is: NO.
+
+SHOW_GROUPED_MEMB_INC = NO
+
+# If the FORCE_LOCAL_INCLUDES tag is set to YES then doxygen will list include
+# files with double quotes in the documentation rather than with sharp brackets.
+# The default value is: NO.
+
+FORCE_LOCAL_INCLUDES = NO
+
+# If the INLINE_INFO tag is set to YES then a tag [inline] is inserted in the
+# documentation for inline members.
+# The default value is: YES.
INLINE_INFO = YES
-# If the SORT_MEMBER_DOCS tag is set to YES (the default) then doxygen
-# will sort the (detailed) documentation of file and class members
-# alphabetically by member name. If set to NO the members will appear in
-# declaration order.
+# If the SORT_MEMBER_DOCS tag is set to YES then doxygen will sort the
+# (detailed) documentation of file and class members alphabetically by member
+# name. If set to NO the members will appear in declaration order.
+# The default value is: YES.
SORT_MEMBER_DOCS = YES
-# If the SORT_BRIEF_DOCS tag is set to YES then doxygen will sort the
-# brief documentation of file, namespace and class members alphabetically
-# by member name. If set to NO (the default) the members will appear in
-# declaration order.
+# If the SORT_BRIEF_DOCS tag is set to YES then doxygen will sort the brief
+# descriptions of file, namespace and class members alphabetically by member
+# name. If set to NO the members will appear in declaration order. Note that
+# this will also influence the order of the classes in the class list.
+# The default value is: NO.
SORT_BRIEF_DOCS = NO
-# If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the (brief and detailed) documentation of class members so that constructors and destructors are listed first. If set to NO (the default) the constructors will appear in the respective orders defined by SORT_MEMBER_DOCS and SORT_BRIEF_DOCS. This tag will be ignored for brief docs if SORT_BRIEF_DOCS is set to NO and ignored for detailed docs if SORT_MEMBER_DOCS is set to NO.
+# If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the
+# (brief and detailed) documentation of class members so that constructors and
+# destructors are listed first. If set to NO the constructors will appear in the
+# respective orders defined by SORT_BRIEF_DOCS and SORT_MEMBER_DOCS.
+# Note: If SORT_BRIEF_DOCS is set to NO this option is ignored for sorting brief
+# member documentation.
+# Note: If SORT_MEMBER_DOCS is set to NO this option is ignored for sorting
+# detailed member documentation.
+# The default value is: NO.
SORT_MEMBERS_CTORS_1ST = NO
-# If the SORT_GROUP_NAMES tag is set to YES then doxygen will sort the
-# hierarchy of group names into alphabetical order. If set to NO (the default)
-# the group names will appear in their defined order.
+# If the SORT_GROUP_NAMES tag is set to YES then doxygen will sort the hierarchy
+# of group names into alphabetical order. If set to NO the group names will
+# appear in their defined order.
+# The default value is: NO.
SORT_GROUP_NAMES = NO
-# If the SORT_BY_SCOPE_NAME tag is set to YES, the class list will be
-# sorted by fully-qualified names, including namespaces. If set to
-# NO (the default), the class list will be sorted only by class name,
-# not including the namespace part.
+# If the SORT_BY_SCOPE_NAME tag is set to YES, the class list will be sorted by
+# fully-qualified names, including namespaces. If set to NO, the class list will
+# be sorted only by class name, not including the namespace part.
# Note: This option is not very useful if HIDE_SCOPE_NAMES is set to YES.
-# Note: This option applies only to the class list, not to the
-# alphabetical list.
+# Note: This option applies only to the class list, not to the alphabetical
+# list.
+# The default value is: NO.
SORT_BY_SCOPE_NAME = NO
-# The GENERATE_TODOLIST tag can be used to enable (YES) or
-# disable (NO) the todo list. This list is created by putting \todo
-# commands in the documentation.
+# If the STRICT_PROTO_MATCHING option is enabled and doxygen fails to do proper
+# type resolution of all parameters of a function it will reject a match between
+# the prototype and the implementation of a member function even if there is
+# only one candidate or it is obvious which candidate to choose by doing a
+# simple string match. By disabling STRICT_PROTO_MATCHING doxygen will still
+# accept a match between prototype and implementation in such cases.
+# The default value is: NO.
+
+STRICT_PROTO_MATCHING = NO
+
+# The GENERATE_TODOLIST tag can be used to enable ( YES) or disable ( NO) the
+# todo list. This list is created by putting \todo commands in the
+# documentation.
+# The default value is: YES.
GENERATE_TODOLIST = YES
-# The GENERATE_TESTLIST tag can be used to enable (YES) or
-# disable (NO) the test list. This list is created by putting \test
-# commands in the documentation.
+# The GENERATE_TESTLIST tag can be used to enable ( YES) or disable ( NO) the
+# test list. This list is created by putting \test commands in the
+# documentation.
+# The default value is: YES.
GENERATE_TESTLIST = YES
-# The GENERATE_BUGLIST tag can be used to enable (YES) or
-# disable (NO) the bug list. This list is created by putting \bug
-# commands in the documentation.
+# The GENERATE_BUGLIST tag can be used to enable ( YES) or disable ( NO) the bug
+# list. This list is created by putting \bug commands in the documentation.
+# The default value is: YES.
GENERATE_BUGLIST = YES
-# The GENERATE_DEPRECATEDLIST tag can be used to enable (YES) or
-# disable (NO) the deprecated list. This list is created by putting
-# \deprecated commands in the documentation.
+# The GENERATE_DEPRECATEDLIST tag can be used to enable ( YES) or disable ( NO)
+# the deprecated list. This list is created by putting \deprecated commands in
+# the documentation.
+# The default value is: YES.
GENERATE_DEPRECATEDLIST= YES
-# The ENABLED_SECTIONS tag can be used to enable conditional
-# documentation sections, marked by \if sectionname ... \endif.
+# The ENABLED_SECTIONS tag can be used to enable conditional documentation
+# sections, marked by \if ... \endif and \cond
+# ... \endcond blocks.
ENABLED_SECTIONS =
-# The MAX_INITIALIZER_LINES tag determines the maximum number of lines
-# the initial value of a variable or define consists of for it to appear in
-# the documentation. If the initializer consists of more lines than specified
-# here it will be hidden. Use a value of 0 to hide initializers completely.
-# The appearance of the initializer of individual variables and defines in the
-# documentation can be controlled using \showinitializer or \hideinitializer
-# command in the documentation regardless of this setting.
+# The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the
+# initial value of a variable or macro / define can have for it to appear in the
+# documentation. If the initializer consists of more lines than specified here
+# it will be hidden. Use a value of 0 to hide initializers completely. The
+# appearance of the value of individual variables and macros / defines can be
+# controlled using \showinitializer or \hideinitializer command in the
+# documentation regardless of this setting.
+# Minimum value: 0, maximum value: 10000, default value: 30.
MAX_INITIALIZER_LINES = 30
-# Set the SHOW_USED_FILES tag to NO to disable the list of files generated
-# at the bottom of the documentation of classes and structs. If set to YES the
-# list will mention the files that were used to generate the documentation.
+# Set the SHOW_USED_FILES tag to NO to disable the list of files generated at
+# the bottom of the documentation of classes and structs. If set to YES the list
+# will mention the files that were used to generate the documentation.
+# The default value is: YES.
SHOW_USED_FILES = YES
-# If the sources in your project are distributed over multiple directories
-# then setting the SHOW_DIRECTORIES tag to YES will show the directory hierarchy
-# in the documentation. The default is NO.
-
-SHOW_DIRECTORIES = NO
-
-# Set the SHOW_FILES tag to NO to disable the generation of the Files page.
-# This will remove the Files entry from the Quick Index and from the
-# Folder Tree View (if specified). The default is YES.
+# Set the SHOW_FILES tag to NO to disable the generation of the Files page. This
+# will remove the Files entry from the Quick Index and from the Folder Tree View
+# (if specified).
+# The default value is: YES.
SHOW_FILES = YES
-# Set the SHOW_NAMESPACES tag to NO to disable the generation of the
-# Namespaces page.
-# This will remove the Namespaces entry from the Quick Index
-# and from the Folder Tree View (if specified). The default is YES.
+# Set the SHOW_NAMESPACES tag to NO to disable the generation of the Namespaces
+# page. This will remove the Namespaces entry from the Quick Index and from the
+# Folder Tree View (if specified).
+# The default value is: YES.
SHOW_NAMESPACES = YES
@@ -493,114 +655,144 @@
# doxygen should invoke to get the current version for each file (typically from
# the version control system). Doxygen will invoke the program by executing (via
-# popen()) the command , where is the value of
-# the FILE_VERSION_FILTER tag, and is the name of an input file
-# provided by doxygen. Whatever the program writes to standard output
-# is used as the file version. See the manual for examples.
+# popen()) the command command input-file, where command is the value of the
+# FILE_VERSION_FILTER tag, and input-file is the name of an input file provided
+# by doxygen. Whatever the program writes to standard output is used as the file
+# version. For an example see the documentation.
FILE_VERSION_FILTER =
-# The LAYOUT_FILE tag can be used to specify a layout file which will be parsed by
-# doxygen. The layout file controls the global structure of the generated output files
-# in an output format independent way. The create the layout file that represents
-# doxygen's defaults, run doxygen with the -l option. You can optionally specify a
-# file name after the option, if omitted DoxygenLayout.xml will be used as the name
-# of the layout file.
+# The LAYOUT_FILE tag can be used to specify a layout file which will be parsed
+# by doxygen. The layout file controls the global structure of the generated
+# output files in an output format independent way. To create the layout file
+# that represents doxygen's defaults, run doxygen with the -l option. You can
+# optionally specify a file name after the option, if omitted DoxygenLayout.xml
+# will be used as the name of the layout file.
+#
+# Note that if you run doxygen from a directory containing a file called
+# DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE
+# tag is left empty.
LAYOUT_FILE =
-#---------------------------------------------------------------------------
-# configuration options related to warning and progress messages
-#---------------------------------------------------------------------------
-
-# The QUIET tag can be used to turn on/off the messages that are generated
-# by doxygen. Possible values are YES and NO. If left blank NO is used.
+# The CITE_BIB_FILES tag can be used to specify one or more bib files containing
+# the reference definitions. This must be a list of .bib files. The .bib
+# extension is automatically appended if omitted. This requires the bibtex tool
+# to be installed. See also http://en.wikipedia.org/wiki/BibTeX for more info.
+# For LaTeX the style of the bibliography can be controlled using
+# LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the
+# search path. See also \cite for info how to create references.
+
+CITE_BIB_FILES =
+
+#---------------------------------------------------------------------------
+# Configuration options related to warning and progress messages
+#---------------------------------------------------------------------------
+
+# The QUIET tag can be used to turn on/off the messages that are generated to
+# standard output by doxygen. If QUIET is set to YES this implies that the
+# messages are off.
+# The default value is: NO.
QUIET = NO
# The WARNINGS tag can be used to turn on/off the warning messages that are
-# generated by doxygen. Possible values are YES and NO. If left blank
-# NO is used.
+# generated to standard error ( stderr) by doxygen. If WARNINGS is set to YES
+# this implies that the warnings are on.
+#
+# Tip: Turn warnings on while writing the documentation.
+# The default value is: YES.
WARNINGS = YES
-# If WARN_IF_UNDOCUMENTED is set to YES, then doxygen will generate warnings
-# for undocumented members. If EXTRACT_ALL is set to YES then this flag will
-# automatically be disabled.
+# If the WARN_IF_UNDOCUMENTED tag is set to YES, then doxygen will generate
+# warnings for undocumented members. If EXTRACT_ALL is set to YES then this flag
+# will automatically be disabled.
+# The default value is: YES.
WARN_IF_UNDOCUMENTED = YES
-# If WARN_IF_DOC_ERROR is set to YES, doxygen will generate warnings for
-# potential errors in the documentation, such as not documenting some
-# parameters in a documented function, or documenting parameters that
-# don't exist or using markup commands wrongly.
+# If the WARN_IF_DOC_ERROR tag is set to YES, doxygen will generate warnings for
+# potential errors in the documentation, such as not documenting some parameters
+# in a documented function, or documenting parameters that don't exist or using
+# markup commands wrongly.
+# The default value is: YES.
WARN_IF_DOC_ERROR = YES
-# This WARN_NO_PARAMDOC option can be abled to get warnings for
-# functions that are documented, but have no documentation for their parameters
-# or return value. If set to NO (the default) doxygen will only warn about
-# wrong or incomplete parameter documentation, but not about the absence of
-# documentation.
+# This WARN_NO_PARAMDOC option can be enabled to get warnings for functions that
+# are documented, but have no documentation for their parameters or return
+# value. If set to NO doxygen will only warn about wrong or incomplete parameter
+# documentation, but not about the absence of documentation.
+# The default value is: NO.
WARN_NO_PARAMDOC = NO
-# The WARN_FORMAT tag determines the format of the warning messages that
-# doxygen can produce. The string should contain the $file, $line, and $text
-# tags, which will be replaced by the file and line number from which the
-# warning originated and the warning text. Optionally the format may contain
-# $version, which will be replaced by the version of the file (if it could
-# be obtained via FILE_VERSION_FILTER)
+# The WARN_FORMAT tag determines the format of the warning messages that doxygen
+# can produce. The string should contain the $file, $line, and $text tags, which
+# will be replaced by the file and line number from which the warning originated
+# and the warning text. Optionally the format may contain $version, which will
+# be replaced by the version of the file (if it could be obtained via
+# FILE_VERSION_FILTER)
+# The default value is: $file:$line: $text.
WARN_FORMAT = "$file:$line: $text"
-# The WARN_LOGFILE tag can be used to specify a file to which warning
-# and error messages should be written. If left blank the output is written
-# to stderr.
+# The WARN_LOGFILE tag can be used to specify a file to which warning and error
+# messages should be written. If left blank the output is written to standard
+# error (stderr).
WARN_LOGFILE =
#---------------------------------------------------------------------------
-# configuration options related to the input files
-#---------------------------------------------------------------------------
-
-# The INPUT tag can be used to specify the files and/or directories that contain
-# documented source files. You may enter file names like "myfile.cpp" or
-# directories like "/usr/src/myproject". Separate the files or directories
-# with spaces.
-
-INPUT =
+# Configuration options related to the input files
+#---------------------------------------------------------------------------
+
+# The INPUT tag is used to specify the files and/or directories that contain
+# documented source files. You may enter file names like myfile.cpp or
+# directories like /usr/src/myproject. Separate the files or directories with
+# spaces.
+# Note: If this tag is empty the current directory is searched.
+
+INPUT = . ./docsrc
# This tag can be used to specify the character encoding of the source files
-# that doxygen parses. Internally doxygen uses the UTF-8 encoding, which is
-# also the default input encoding. Doxygen uses libiconv (or the iconv built
-# into libc) for the transcoding. See http://www.gnu.org/software/libiconv for
-# the list of possible encodings.
+# that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses
+# libiconv (or the iconv built into libc) for the transcoding. See the libiconv
+# documentation (see: http://www.gnu.org/software/libiconv) for the list of
+# possible encodings.
+# The default value is: UTF-8.
INPUT_ENCODING = UTF-8
# If the value of the INPUT tag contains directories, you can use the
-# FILE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp
-# and *.h) to filter out the source-files in the directories. If left
-# blank the following patterns are tested:
-# *.c *.cc *.cxx *.cpp *.c++ *.java *.ii *.ixx *.ipp *.i++ *.inl *.h *.hh *.hxx
-# *.hpp *.h++ *.idl *.odl *.cs *.php *.php3 *.inc *.m *.mm *.py *.f90
-
-FILE_PATTERNS = *.f90
-
-# The RECURSIVE tag can be used to turn specify whether or not subdirectories
-# should be searched for input files as well. Possible values are YES and NO.
-# If left blank NO is used.
+# FILE_PATTERNS tag to specify one or more wildcard patterns (like *.cpp and
+# *.h) to filter out the source-files in the directories. If left blank the
+# following patterns are tested:*.c, *.cc, *.cxx, *.cpp, *.c++, *.java, *.ii,
+# *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, *.hh, *.hxx, *.hpp,
+# *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, *.m, *.markdown,
+# *.md, *.mm, *.dox, *.py, *.f90, *.f, *.for, *.tcl, *.vhd, *.vhdl, *.ucf,
+# *.qsf, *.as and *.js.
+
+FILE_PATTERNS =
+
+# The RECURSIVE tag can be used to specify whether or not subdirectories should
+# be searched for input files as well.
+# The default value is: NO.
RECURSIVE = NO
-# The EXCLUDE tag can be used to specify files and/or directories that should
+# The EXCLUDE tag can be used to specify files and/or directories that should be
# excluded from the INPUT source files. This way you can easily exclude a
# subdirectory from a directory tree whose root is specified with the INPUT tag.
+#
+# Note that relative paths are relative to the directory from which doxygen is
+# run.
EXCLUDE =
-# The EXCLUDE_SYMLINKS tag can be used select whether or not files or
-# directories that are symbolic links (a Unix filesystem feature) are excluded
+# The EXCLUDE_SYMLINKS tag can be used to select whether or not files or
+# directories that are symbolic links (a Unix file system feature) are excluded
# from the input.
+# The default value is: NO.
EXCLUDE_SYMLINKS = NO
@@ -608,7 +800,8 @@
# If the value of the INPUT tag contains directories, you can use the
# EXCLUDE_PATTERNS tag to specify one or more wildcard patterns to exclude
-# certain files from those directories. Note that the wildcards are matched
-# against the file with absolute path, so to exclude all test directories
-# for example use the pattern */test/*
+# certain files from those directories.
+#
+# Note that the wildcards are matched against the file with absolute path, so to
+# exclude all test directories for example use the pattern */test/*
EXCLUDE_PATTERNS =
@@ -619,596 +812,1087 @@
# wildcard * is used, a substring. Examples: ANamespace, AClass,
# AClass::ANamespace, ANamespace::*Test
+#
+# Note that the wildcards are matched against the file with absolute path, so to
+# exclude all test directories use the pattern */test/*
EXCLUDE_SYMBOLS =
-# The EXAMPLE_PATH tag can be used to specify one or more files or
-# directories that contain example code fragments that are included (see
-# the \include command).
+# The EXAMPLE_PATH tag can be used to specify one or more files or directories
+# that contain example code fragments that are included (see the \include
+# command).
EXAMPLE_PATH =
# If the value of the EXAMPLE_PATH tag contains directories, you can use the
-# EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp
-# and *.h) to filter out the source-files in the directories. If left
-# blank all files are included.
+# EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp and
+# *.h) to filter out the source-files in the directories. If left blank all
+# files are included.
EXAMPLE_PATTERNS =
# If the EXAMPLE_RECURSIVE tag is set to YES then subdirectories will be
-# searched for input files to be used with the \include or \dontinclude
-# commands irrespective of the value of the RECURSIVE tag.
-# Possible values are YES and NO. If left blank NO is used.
+# searched for input files to be used with the \include or \dontinclude commands
+# irrespective of the value of the RECURSIVE tag.
+# The default value is: NO.
EXAMPLE_RECURSIVE = NO
-# The IMAGE_PATH tag can be used to specify one or more files or
-# directories that contain image that are included in the documentation (see
-# the \image command).
-
-IMAGE_PATH =
+# The IMAGE_PATH tag can be used to specify one or more files or directories
+# that contain images that are to be included in the documentation (see the
+# \image command).
+
+IMAGE_PATH = ./docsrc/Image
# The INPUT_FILTER tag can be used to specify a program that doxygen should
# invoke to filter for each input file. Doxygen will invoke the filter program
-# by executing (via popen()) the command , where
-# is the value of the INPUT_FILTER tag, and is the name of an
-# input file. Doxygen will then use the output that the filter program writes
-# to standard output.
-# If FILTER_PATTERNS is specified, this tag will be
-# ignored.
+# by executing (via popen()) the command:
+#
+#
+#
+# where is the value of the INPUT_FILTER tag, and is the
+# name of an input file. Doxygen will then use the output that the filter
+# program writes to standard output. If FILTER_PATTERNS is specified, this tag
+# will be ignored.
+#
+# Note that the filter must not add or remove lines; it is applied before the
+# code is scanned, but not when the output code is generated. If lines are added
+# or removed, the anchors will not be placed correctly.
INPUT_FILTER =
# The FILTER_PATTERNS tag can be used to specify filters on a per file pattern
-# basis.
-# Doxygen will compare the file name with each pattern and apply the
-# filter if there is a match.
-# The filters are a list of the form:
-# pattern=filter (like *.cpp=my_cpp_filter). See INPUT_FILTER for further
-# info on how filters are used. If FILTER_PATTERNS is empty, INPUT_FILTER
-# is applied to all files.
+# basis. Doxygen will compare the file name with each pattern and apply the
+# filter if there is a match. The filters are a list of the form: pattern=filter
+# (like *.cpp=my_cpp_filter). See INPUT_FILTER for further information on how
+# filters are used. If the FILTER_PATTERNS tag is empty or if none of the
+# patterns match the file name, INPUT_FILTER is applied.
FILTER_PATTERNS =
# If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using
-# INPUT_FILTER) will be used to filter the input files when producing source
-# files to browse (i.e. when SOURCE_BROWSER is set to YES).
+# INPUT_FILTER ) will also be used to filter the input files that are used for
+# producing the source files to browse (i.e. when SOURCE_BROWSER is set to YES).
+# The default value is: NO.
FILTER_SOURCE_FILES = NO
-#---------------------------------------------------------------------------
-# configuration options related to source browsing
-#---------------------------------------------------------------------------
-
-# If the SOURCE_BROWSER tag is set to YES then a list of source files will
-# be generated. Documented entities will be cross-referenced with these sources.
-# Note: To get rid of all source code in the generated output, make sure also
-# VERBATIM_HEADERS is set to NO.
+# The FILTER_SOURCE_PATTERNS tag can be used to specify source filters per file
+# pattern. A pattern will override the setting for FILTER_PATTERN (if any) and
+# it is also possible to disable source filtering for a specific pattern using
+# *.ext= (so without naming a filter).
+# This tag requires that the tag FILTER_SOURCE_FILES is set to YES.
+
+FILTER_SOURCE_PATTERNS =
+
+# If the USE_MDFILE_AS_MAINPAGE tag refers to the name of a markdown file that
+# is part of the input, its contents will be placed on the main page
+# (index.html). This can be useful if you have a project on for instance GitHub
+# and want to reuse the introduction page also for the doxygen output.
+
+USE_MDFILE_AS_MAINPAGE =
+
+#---------------------------------------------------------------------------
+# Configuration options related to source browsing
+#---------------------------------------------------------------------------
+
+# If the SOURCE_BROWSER tag is set to YES then a list of source files will be
+# generated. Documented entities will be cross-referenced with these sources.
+#
+# Note: To get rid of all source code in the generated output, make sure that
+# also VERBATIM_HEADERS is set to NO.
+# The default value is: NO.
SOURCE_BROWSER = NO
-# Setting the INLINE_SOURCES tag to YES will include the body
-# of functions and classes directly in the documentation.
+# Setting the INLINE_SOURCES tag to YES will include the body of functions,
+# classes and enums directly into the documentation.
+# The default value is: NO.
INLINE_SOURCES = NO
-# Setting the STRIP_CODE_COMMENTS tag to YES (the default) will instruct
-# doxygen to hide any special comment blocks from generated source code
-# fragments. Normal C and C++ comments will always remain visible.
+# Setting the STRIP_CODE_COMMENTS tag to YES will instruct doxygen to hide any
+# special comment blocks from generated source code fragments. Normal C, C++ and
+# Fortran comments will always remain visible.
+# The default value is: YES.
STRIP_CODE_COMMENTS = YES
-# If the REFERENCED_BY_RELATION tag is set to YES
-# then for each documented function all documented
-# functions referencing it will be listed.
+# If the REFERENCED_BY_RELATION tag is set to YES then for each documented
+# function all documented functions referencing it will be listed.
+# The default value is: NO.
REFERENCED_BY_RELATION = NO
-# If the REFERENCES_RELATION tag is set to YES
-# then for each documented function all documented entities
-# called/used by that function will be listed.
+# If the REFERENCES_RELATION tag is set to YES then for each documented function
+# all documented entities called/used by that function will be listed.
+# The default value is: NO.
REFERENCES_RELATION = NO
-# If the REFERENCES_LINK_SOURCE tag is set to YES (the default)
-# and SOURCE_BROWSER tag is set to YES, then the hyperlinks from
-# functions in REFERENCES_RELATION and REFERENCED_BY_RELATION lists will
-# link to the source code.
-# Otherwise they will link to the documentation.
+# If the REFERENCES_LINK_SOURCE tag is set to YES and SOURCE_BROWSER tag is set
+# to YES, then the hyperlinks from functions in REFERENCES_RELATION and
+# REFERENCED_BY_RELATION lists will link to the source code. Otherwise they will
+# link to the documentation.
+# The default value is: YES.
REFERENCES_LINK_SOURCE = YES
-# If the USE_HTAGS tag is set to YES then the references to source code
-# will point to the HTML generated by the htags(1) tool instead of doxygen
-# built-in source browser. The htags tool is part of GNU's global source
-# tagging system (see http://www.gnu.org/software/global/global.html). You
-# will need version 4.8.6 or higher.
+# If SOURCE_TOOLTIPS is enabled (the default) then hovering a hyperlink in the
+# source code will show a tooltip with additional information such as prototype,
+# brief description and links to the definition and documentation. Since this
+# will make the HTML file larger and loading of large files a bit slower, you
+# can opt to disable this feature.
+# The default value is: YES.
+# This tag requires that the tag SOURCE_BROWSER is set to YES.
+
+SOURCE_TOOLTIPS = YES
+
+# If the USE_HTAGS tag is set to YES then the references to source code will
+# point to the HTML generated by the htags(1) tool instead of doxygen built-in
+# source browser. The htags tool is part of GNU's global source tagging system
+# (see http://www.gnu.org/software/global/global.html). You will need version
+# 4.8.6 or higher.
+#
+# To use it do the following:
+# - Install the latest version of global
+# - Enable SOURCE_BROWSER and USE_HTAGS in the config file
+# - Make sure the INPUT points to the root of the source tree
+# - Run doxygen as normal
+#
+# Doxygen will invoke htags (and that will in turn invoke gtags), so these
+# tools must be available from the command line (i.e. in the search path).
+#
+# The result: instead of the source browser generated by doxygen, the links to
+# source code will now point to the output of htags.
+# The default value is: NO.
+# This tag requires that the tag SOURCE_BROWSER is set to YES.
USE_HTAGS = NO
-# If the VERBATIM_HEADERS tag is set to YES (the default) then Doxygen
-# will generate a verbatim copy of the header file for each class for
-# which an include is specified. Set to NO to disable this.
+# If the VERBATIM_HEADERS tag is set the YES then doxygen will generate a
+# verbatim copy of the header file for each class for which an include is
+# specified. Set to NO to disable this.
+# See also: Section \class.
+# The default value is: YES.
VERBATIM_HEADERS = YES
#---------------------------------------------------------------------------
-# configuration options related to the alphabetical class index
-#---------------------------------------------------------------------------
-
-# If the ALPHABETICAL_INDEX tag is set to YES, an alphabetical index
-# of all compounds will be generated. Enable this if the project
-# contains a lot of classes, structs, unions or interfaces.
+# Configuration options related to the alphabetical class index
+#---------------------------------------------------------------------------
+
+# If the ALPHABETICAL_INDEX tag is set to YES, an alphabetical index of all
+# compounds will be generated. Enable this if the project contains a lot of
+# classes, structs, unions or interfaces.
+# The default value is: YES.
ALPHABETICAL_INDEX = NO
-# If the alphabetical index is enabled (see ALPHABETICAL_INDEX) then
-# the COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns
-# in which this list will be split (can be a number in the range [1..20])
+# The COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns in
+# which the alphabetical index list will be split.
+# Minimum value: 1, maximum value: 20, default value: 5.
+# This tag requires that the tag ALPHABETICAL_INDEX is set to YES.
COLS_IN_ALPHA_INDEX = 5
-# In case all classes in a project start with a common prefix, all
-# classes will be put under the same header in the alphabetical index.
-# The IGNORE_PREFIX tag can be used to specify one or more prefixes that
-# should be ignored while generating the index headers.
+# In case all classes in a project start with a common prefix, all classes will
+# be put under the same header in the alphabetical index. The IGNORE_PREFIX tag
+# can be used to specify a prefix (or a list of prefixes) that should be ignored
+# while generating the index headers.
+# This tag requires that the tag ALPHABETICAL_INDEX is set to YES.
IGNORE_PREFIX =
#---------------------------------------------------------------------------
-# configuration options related to the HTML output
-#---------------------------------------------------------------------------
-
-# If the GENERATE_HTML tag is set to YES (the default) Doxygen will
-# generate HTML output.
+# Configuration options related to the HTML output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_HTML tag is set to YES doxygen will generate HTML output
+# The default value is: YES.
GENERATE_HTML = YES
-# The HTML_OUTPUT tag is used to specify where the HTML docs will be put.
-# If a relative path is entered the value of OUTPUT_DIRECTORY will be
-# put in front of it. If left blank `html' will be used as the default path.
+# The HTML_OUTPUT tag is used to specify where the HTML docs will be put. If a
+# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of
+# it.
+# The default directory is: html.
+# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_OUTPUT = html
-# The HTML_FILE_EXTENSION tag can be used to specify the file extension for
-# each generated HTML page (for example: .htm,.php,.asp). If it is left blank
-# doxygen will generate files with .html extension.
+# The HTML_FILE_EXTENSION tag can be used to specify the file extension for each
+# generated HTML page (for example: .htm, .php, .asp).
+# The default value is: .html.
+# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_FILE_EXTENSION = .html
-# The HTML_HEADER tag can be used to specify a personal HTML header for
-# each generated HTML page. If it is left blank doxygen will generate a
+# The HTML_HEADER tag can be used to specify a user-defined HTML header file for
+# each generated HTML page. If the tag is left blank doxygen will generate a
# standard header.
+#
+# To get valid HTML the header file that includes any scripts and style sheets
+# that doxygen needs, which is dependent on the configuration options used (e.g.
+# the setting GENERATE_TREEVIEW). It is highly recommended to start with a
+# default header using
+# doxygen -w html new_header.html new_footer.html new_stylesheet.css
+# YourConfigFile
+# and then modify the file new_header.html. See also section "Doxygen usage"
+# for information on how to generate the default header that doxygen normally
+# uses.
+# Note: The header is subject to change so you typically have to regenerate the
+# default header when upgrading to a newer version of doxygen. For a description
+# of the possible markers and block names see the documentation.
+# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_HEADER =
-# The HTML_FOOTER tag can be used to specify a personal HTML footer for
-# each generated HTML page. If it is left blank doxygen will generate a
-# standard footer.
+# The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each
+# generated HTML page. If the tag is left blank doxygen will generate a standard
+# footer. See HTML_HEADER for more information on how to generate a default
+# footer and what special commands can be used inside the footer. See also
+# section "Doxygen usage" for information on how to generate the default footer
+# that doxygen normally uses.
+# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_FOOTER =
-# If the HTML_TIMESTAMP tag is set to YES then the generated HTML
-# documentation will contain the timesstamp.
-
-HTML_TIMESTAMP = NO
-
-# The HTML_STYLESHEET tag can be used to specify a user-defined cascading
-# style sheet that is used by each HTML page. It can be used to
-# fine-tune the look of the HTML output. If the tag is left blank doxygen
-# will generate a default style sheet. Note that doxygen will try to copy
-# the style sheet file to the HTML output directory, so don't put your own
-# stylesheet in the HTML output directory as well, or it will be erased!
+# The HTML_STYLESHEET tag can be used to specify a user-defined cascading style
+# sheet that is used by each HTML page. It can be used to fine-tune the look of
+# the HTML output. If left blank doxygen will generate a default style sheet.
+# See also section "Doxygen usage" for information on how to generate the style
+# sheet that doxygen normally uses.
+# Note: It is recommended to use HTML_EXTRA_STYLESHEET instead of this tag, as
+# it is more robust and this tag (HTML_STYLESHEET) will in the future become
+# obsolete.
+# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_STYLESHEET =
-# If the HTML_ALIGN_MEMBERS tag is set to YES, the members of classes,
-# files or namespaces will be aligned in HTML using tables. If set to
-# NO a bullet list will be used.
-
-HTML_ALIGN_MEMBERS = YES
+# The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined
+# cascading style sheets that are included after the standard style sheets
+# created by doxygen. Using this option one can overrule certain style aspects.
+# This is preferred over using HTML_STYLESHEET since it does not replace the
+# standard style sheet and is therefor more robust against future updates.
+# Doxygen will copy the style sheet files to the output directory.
+# Note: The order of the extra stylesheet files is of importance (e.g. the last
+# stylesheet in the list overrules the setting of the previous ones in the
+# list). For an example see the documentation.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_EXTRA_STYLESHEET =
+
+# The HTML_EXTRA_FILES tag can be used to specify one or more extra images or
+# other source files which should be copied to the HTML output directory. Note
+# that these files will be copied to the base HTML output directory. Use the
+# $relpath^ marker in the HTML_HEADER and/or HTML_FOOTER files to load these
+# files. In the HTML_STYLESHEET file, use the file name only. Also note that the
+# files will be copied as-is; there are no commands or markers available.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_EXTRA_FILES =
+
+# The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen
+# will adjust the colors in the stylesheet and background images according to
+# this color. Hue is specified as an angle on a colorwheel, see
+# http://en.wikipedia.org/wiki/Hue for more information. For instance the value
+# 0 represents red, 60 is yellow, 120 is green, 180 is cyan, 240 is blue, 300
+# purple, and 360 is red again.
+# Minimum value: 0, maximum value: 359, default value: 220.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_COLORSTYLE_HUE = 220
+
+# The HTML_COLORSTYLE_SAT tag controls the purity (or saturation) of the colors
+# in the HTML output. For a value of 0 the output will use grayscales only. A
+# value of 255 will produce the most vivid colors.
+# Minimum value: 0, maximum value: 255, default value: 100.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_COLORSTYLE_SAT = 100
+
+# The HTML_COLORSTYLE_GAMMA tag controls the gamma correction applied to the
+# luminance component of the colors in the HTML output. Values below 100
+# gradually make the output lighter, whereas values above 100 make the output
+# darker. The value divided by 100 is the actual gamma applied, so 80 represents
+# a gamma of 0.8, The value 220 represents a gamma of 2.2, and 100 does not
+# change the gamma.
+# Minimum value: 40, maximum value: 240, default value: 80.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_COLORSTYLE_GAMMA = 80
+
+# If the HTML_TIMESTAMP tag is set to YES then the footer of each generated HTML
+# page will contain the date and time when the page was generated. Setting this
+# to NO can help when comparing the output of multiple runs.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_TIMESTAMP = YES
# If the HTML_DYNAMIC_SECTIONS tag is set to YES then the generated HTML
# documentation will contain sections that can be hidden and shown after the
-# page has loaded. For this to work a browser that supports
-# JavaScript and DHTML is required (for instance Mozilla 1.0+, Firefox
-# Netscape 6.0+, Internet explorer 5.0+, Konqueror, or Safari).
+# page has loaded.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_DYNAMIC_SECTIONS = NO
-# If the GENERATE_DOCSET tag is set to YES, additional index files
-# will be generated that can be used as input for Apple's Xcode 3
-# integrated development environment, introduced with OSX 10.5 (Leopard).
-# To create a documentation set, doxygen will generate a Makefile in the
-# HTML output directory. Running make will produce the docset in that
-# directory and running "make install" will install the docset in
-# ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find
-# it at startup.
-# See http://developer.apple.com/tools/creatingdocsetswithdoxygen.html for more information.
+# With HTML_INDEX_NUM_ENTRIES one can control the preferred number of entries
+# shown in the various tree structured indices initially; the user can expand
+# and collapse entries dynamically later on. Doxygen will expand the tree to
+# such a level that at most the specified number of entries are visible (unless
+# a fully collapsed tree already exceeds this amount). So setting the number of
+# entries 1 will produce a full collapsed tree by default. 0 is a special value
+# representing an infinite number of entries and will result in a full expanded
+# tree by default.
+# Minimum value: 0, maximum value: 9999, default value: 100.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_INDEX_NUM_ENTRIES = 100
+
+# If the GENERATE_DOCSET tag is set to YES, additional index files will be
+# generated that can be used as input for Apple's Xcode 3 integrated development
+# environment (see: http://developer.apple.com/tools/xcode/), introduced with
+# OSX 10.5 (Leopard). To create a documentation set, doxygen will generate a
+# Makefile in the HTML output directory. Running make will produce the docset in
+# that directory and running make install will install the docset in
+# ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at
+# startup. See http://developer.apple.com/tools/creatingdocsetswithdoxygen.html
+# for more information.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
GENERATE_DOCSET = NO
-# When GENERATE_DOCSET tag is set to YES, this tag determines the name of the
-# feed. A documentation feed provides an umbrella under which multiple
-# documentation sets from a single provider (such as a company or product suite)
-# can be grouped.
+# This tag determines the name of the docset feed. A documentation feed provides
+# an umbrella under which multiple documentation sets from a single provider
+# (such as a company or product suite) can be grouped.
+# The default value is: Doxygen generated docs.
+# This tag requires that the tag GENERATE_DOCSET is set to YES.
DOCSET_FEEDNAME = "Doxygen generated docs"
-# When GENERATE_DOCSET tag is set to YES, this tag specifies a string that
-# should uniquely identify the documentation set bundle. This should be a
-# reverse domain-name style string, e.g. com.mycompany.MyDocSet. Doxygen
-# will append .docset to the name.
+# This tag specifies a string that should uniquely identify the documentation
+# set bundle. This should be a reverse domain-name style string, e.g.
+# com.mycompany.MyDocSet. Doxygen will append .docset to the name.
+# The default value is: org.doxygen.Project.
+# This tag requires that the tag GENERATE_DOCSET is set to YES.
DOCSET_BUNDLE_ID = org.doxygen.Project
-# If the GENERATE_HTMLHELP tag is set to YES, additional index files
-# will be generated that can be used as input for tools like the
-# Microsoft HTML help workshop to generate a compiled HTML help file (.chm)
-# of the generated HTML documentation.
+# The DOCSET_PUBLISHER_ID tag specifies a string that should uniquely identify
+# the documentation publisher. This should be a reverse domain-name style
+# string, e.g. com.mycompany.MyDocSet.documentation.
+# The default value is: org.doxygen.Publisher.
+# This tag requires that the tag GENERATE_DOCSET is set to YES.
+
+DOCSET_PUBLISHER_ID = org.doxygen.Publisher
+
+# The DOCSET_PUBLISHER_NAME tag identifies the documentation publisher.
+# The default value is: Publisher.
+# This tag requires that the tag GENERATE_DOCSET is set to YES.
+
+DOCSET_PUBLISHER_NAME = Publisher
+
+# If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three
+# additional HTML index files: index.hhp, index.hhc, and index.hhk. The
+# index.hhp is a project file that can be read by Microsoft's HTML Help Workshop
+# (see: http://www.microsoft.com/en-us/download/details.aspx?id=21138) on
+# Windows.
+#
+# The HTML Help Workshop contains a compiler that can convert all HTML output
+# generated by doxygen into a single compiled HTML file (.chm). Compiled HTML
+# files are now used as the Windows 98 help format, and will replace the old
+# Windows help format (.hlp) on all Windows platforms in the future. Compressed
+# HTML files also contain an index, a table of contents, and you can search for
+# words in the documentation. The HTML workshop also contains a viewer for
+# compressed HTML files.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
GENERATE_HTMLHELP = NO
-# If the GENERATE_HTMLHELP tag is set to YES, the CHM_FILE tag can
-# be used to specify the file name of the resulting .chm file. You
-# can add a path in front of the file if the result should not be
+# The CHM_FILE tag can be used to specify the file name of the resulting .chm
+# file. You can add a path in front of the file if the result should not be
# written to the html output directory.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
CHM_FILE =
-# If the GENERATE_HTMLHELP tag is set to YES, the HHC_LOCATION tag can
-# be used to specify the location (absolute path including file name) of
-# the HTML help compiler (hhc.exe). If non-empty doxygen will try to run
-# the HTML help compiler on the generated index.hhp.
+# The HHC_LOCATION tag can be used to specify the location (absolute path
+# including file name) of the HTML help compiler ( hhc.exe). If non-empty
+# doxygen will try to run the HTML help compiler on the generated index.hhp.
+# The file has to be specified with full path.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
HHC_LOCATION =
-# If the GENERATE_HTMLHELP tag is set to YES, the GENERATE_CHI flag
-# controls if a separate .chi index file is generated (YES) or that
-# it should be included in the master .chm file (NO).
+# The GENERATE_CHI flag controls if a separate .chi index file is generated (
+# YES) or that it should be included in the master .chm file ( NO).
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
GENERATE_CHI = NO
-# If the GENERATE_HTMLHELP tag is set to YES, the CHM_INDEX_ENCODING
-# is used to encode HtmlHelp index (hhk), content (hhc) and project file
-# content.
+# The CHM_INDEX_ENCODING is used to encode HtmlHelp index ( hhk), content ( hhc)
+# and project file content.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
CHM_INDEX_ENCODING =
-# If the GENERATE_HTMLHELP tag is set to YES, the BINARY_TOC flag
-# controls whether a binary table of contents is generated (YES) or a
-# normal table of contents (NO) in the .chm file.
+# The BINARY_TOC flag controls whether a binary table of contents is generated (
+# YES) or a normal table of contents ( NO) in the .chm file. Furthermore it
+# enables the Previous and Next buttons.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
BINARY_TOC = NO
-# The TOC_EXPAND flag can be set to YES to add extra items for group members
-# to the contents of the HTML help documentation and to the tree view.
+# The TOC_EXPAND flag can be set to YES to add extra items for group members to
+# the table of contents of the HTML help documentation and to the tree view.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
TOC_EXPAND = NO
-# If the GENERATE_QHP tag is set to YES and both QHP_NAMESPACE and QHP_VIRTUAL_FOLDER
-# are set, an additional index file will be generated that can be used as input for
-# Qt's qhelpgenerator to generate a Qt Compressed Help (.qch) of the generated
-# HTML documentation.
+# If the GENERATE_QHP tag is set to YES and both QHP_NAMESPACE and
+# QHP_VIRTUAL_FOLDER are set, an additional index file will be generated that
+# can be used as input for Qt's qhelpgenerator to generate a Qt Compressed Help
+# (.qch) of the generated HTML documentation.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
GENERATE_QHP = NO
-# If the QHG_LOCATION tag is specified, the QCH_FILE tag can
-# be used to specify the file name of the resulting .qch file.
-# The path specified is relative to the HTML output folder.
+# If the QHG_LOCATION tag is specified, the QCH_FILE tag can be used to specify
+# the file name of the resulting .qch file. The path specified is relative to
+# the HTML output folder.
+# This tag requires that the tag GENERATE_QHP is set to YES.
QCH_FILE =
-# The QHP_NAMESPACE tag specifies the namespace to use when generating
-# Qt Help Project output. For more information please see
-# http://doc.trolltech.com/qthelpproject.html#namespace
-
-QHP_NAMESPACE =
-
-# The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating
-# Qt Help Project output. For more information please see
-# http://doc.trolltech.com/qthelpproject.html#virtual-folders
+# The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help
+# Project output. For more information please see Qt Help Project / Namespace
+# (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#namespace).
+# The default value is: org.doxygen.Project.
+# This tag requires that the tag GENERATE_QHP is set to YES.
+
+QHP_NAMESPACE = org.doxygen.Project
+
+# The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt
+# Help Project output. For more information please see Qt Help Project / Virtual
+# Folders (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#virtual-
+# folders).
+# The default value is: doc.
+# This tag requires that the tag GENERATE_QHP is set to YES.
QHP_VIRTUAL_FOLDER = doc
-# If QHP_CUST_FILTER_NAME is set, it specifies the name of a custom filter to add.
-# For more information please see
-# http://doc.trolltech.com/qthelpproject.html#custom-filters
+# If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom
+# filter to add. For more information please see Qt Help Project / Custom
+# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom-
+# filters).
+# This tag requires that the tag GENERATE_QHP is set to YES.
QHP_CUST_FILTER_NAME =
-# The QHP_CUST_FILT_ATTRS tag specifies the list of the attributes of the custom filter to add.For more information please see
-# Qt Help Project / Custom Filters .
+# The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the
+# custom filter to add. For more information please see Qt Help Project / Custom
+# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom-
+# filters).
+# This tag requires that the tag GENERATE_QHP is set to YES.
QHP_CUST_FILTER_ATTRS =
-# The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this project's
-# filter section matches.
-# Qt Help Project / Filter Attributes .
+# The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this
+# project's filter section matches. Qt Help Project / Filter Attributes (see:
+# http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes).
+# This tag requires that the tag GENERATE_QHP is set to YES.
QHP_SECT_FILTER_ATTRS =
-# If the GENERATE_QHP tag is set to YES, the QHG_LOCATION tag can
-# be used to specify the location of Qt's qhelpgenerator.
-# If non-empty doxygen will try to run qhelpgenerator on the generated
-# .qhp file.
+# The QHG_LOCATION tag can be used to specify the location of Qt's
+# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the
+# generated .qhp file.
+# This tag requires that the tag GENERATE_QHP is set to YES.
QHG_LOCATION =
-# The DISABLE_INDEX tag can be used to turn on/off the condensed index at
-# top of each HTML page. The value NO (the default) enables the index and
-# the value YES disables it.
+# If the GENERATE_ECLIPSEHELP tag is set to YES, additional index files will be
+# generated, together with the HTML files, they form an Eclipse help plugin. To
+# install this plugin and make it available under the help contents menu in
+# Eclipse, the contents of the directory containing the HTML and XML files needs
+# to be copied into the plugins directory of eclipse. The name of the directory
+# within the plugins directory should be the same as the ECLIPSE_DOC_ID value.
+# After copying Eclipse needs to be restarted before the help appears.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+GENERATE_ECLIPSEHELP = NO
+
+# A unique identifier for the Eclipse help plugin. When installing the plugin
+# the directory name containing the HTML and XML files should also have this
+# name. Each documentation set should have its own identifier.
+# The default value is: org.doxygen.Project.
+# This tag requires that the tag GENERATE_ECLIPSEHELP is set to YES.
+
+ECLIPSE_DOC_ID = org.doxygen.Project
+
+# If you want full control over the layout of the generated HTML pages it might
+# be necessary to disable the index and replace it with your own. The
+# DISABLE_INDEX tag can be used to turn on/off the condensed index (tabs) at top
+# of each HTML page. A value of NO enables the index and the value YES disables
+# it. Since the tabs in the index contain the same information as the navigation
+# tree, you can set this option to YES if you also set GENERATE_TREEVIEW to YES.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
DISABLE_INDEX = NO
-# This tag can be used to set the number of enum values (range [1..20])
-# that doxygen will group on one line in the generated HTML documentation.
+# The GENERATE_TREEVIEW tag is used to specify whether a tree-like index
+# structure should be generated to display hierarchical information. If the tag
+# value is set to YES, a side panel will be generated containing a tree-like
+# index structure (just like the one that is generated for HTML Help). For this
+# to work a browser that supports JavaScript, DHTML, CSS and frames is required
+# (i.e. any modern browser). Windows users are probably better off using the
+# HTML help feature. Via custom stylesheets (see HTML_EXTRA_STYLESHEET) one can
+# further fine-tune the look of the index. As an example, the default style
+# sheet generated by doxygen has an example that shows how to put an image at
+# the root of the tree instead of the PROJECT_NAME. Since the tree basically has
+# the same information as the tab index, you could consider setting
+# DISABLE_INDEX to YES when enabling this option.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+GENERATE_TREEVIEW = NO
+
+# The ENUM_VALUES_PER_LINE tag can be used to set the number of enum values that
+# doxygen will group on one line in the generated HTML documentation.
+#
+# Note that a value of 0 will completely suppress the enum values from appearing
+# in the overview section.
+# Minimum value: 0, maximum value: 20, default value: 4.
+# This tag requires that the tag GENERATE_HTML is set to YES.
ENUM_VALUES_PER_LINE = 4
-# The GENERATE_TREEVIEW tag is used to specify whether a tree-like index
-# structure should be generated to display hierarchical information.
-# If the tag value is set to YES, a side panel will be generated
-# containing a tree-like index structure (just like the one that
-# is generated for HTML Help). For this to work a browser that supports
-# JavaScript, DHTML, CSS and frames is required (i.e. any modern browser).
-# Windows users are probably better off using the HTML help feature.
-
-GENERATE_TREEVIEW = NO
-
-# By enabling USE_INLINE_TREES, doxygen will generate the Groups, Directories,
-# and Class Hierarchy pages using a tree view instead of an ordered list.
-
-USE_INLINE_TREES = NO
-
-# If the treeview is enabled (see GENERATE_TREEVIEW) then this tag can be
-# used to set the initial width (in pixels) of the frame in which the tree
-# is shown.
+# If the treeview is enabled (see GENERATE_TREEVIEW) then this tag can be used
+# to set the initial width (in pixels) of the frame in which the tree is shown.
+# Minimum value: 0, maximum value: 1500, default value: 250.
+# This tag requires that the tag GENERATE_HTML is set to YES.
TREEVIEW_WIDTH = 250
-# Use this tag to change the font size of Latex formulas included
-# as images in the HTML documentation. The default is 10. Note that
-# when you change the font size after a successful doxygen run you need
-# to manually remove any form_*.png images from the HTML output directory
-# to force them to be regenerated.
+# When the EXT_LINKS_IN_WINDOW option is set to YES doxygen will open links to
+# external symbols imported via tag files in a separate window.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+EXT_LINKS_IN_WINDOW = NO
+
+# Use this tag to change the font size of LaTeX formulas included as images in
+# the HTML documentation. When you change the font size after a successful
+# doxygen run you need to manually remove any form_*.png images from the HTML
+# output directory to force them to be regenerated.
+# Minimum value: 8, maximum value: 50, default value: 10.
+# This tag requires that the tag GENERATE_HTML is set to YES.
FORMULA_FONTSIZE = 10
-# When the SEARCHENGINE tag is enable doxygen will generate a search box for the HTML output. The underlying search engine uses javascript
-# and DHTML and should work on any modern browser. Note that when using HTML help (GENERATE_HTMLHELP) or Qt help (GENERATE_QHP)
-# there is already a search function so this one should typically
-# be disabled.
+# Use the FORMULA_TRANPARENT tag to determine whether or not the images
+# generated for formulas are transparent PNGs. Transparent PNGs are not
+# supported properly for IE 6.0, but are supported on all modern browsers.
+#
+# Note that when changing this option you need to delete any form_*.png files in
+# the HTML output directory before the changes have effect.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+FORMULA_TRANSPARENT = YES
+
+# Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see
+# http://www.mathjax.org) which uses client side Javascript for the rendering
+# instead of using prerendered bitmaps. Use this if you do not have LaTeX
+# installed or if you want to formulas look prettier in the HTML output. When
+# enabled you may also need to install MathJax separately and configure the path
+# to it using the MATHJAX_RELPATH option.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+USE_MATHJAX = NO
+
+# When MathJax is enabled you can set the default output format to be used for
+# the MathJax output. See the MathJax site (see:
+# http://docs.mathjax.org/en/latest/output.html) for more details.
+# Possible values are: HTML-CSS (which is slower, but has the best
+# compatibility), NativeMML (i.e. MathML) and SVG.
+# The default value is: HTML-CSS.
+# This tag requires that the tag USE_MATHJAX is set to YES.
+
+MATHJAX_FORMAT = HTML-CSS
+
+# When MathJax is enabled you need to specify the location relative to the HTML
+# output directory using the MATHJAX_RELPATH option. The destination directory
+# should contain the MathJax.js script. For instance, if the mathjax directory
+# is located at the same level as the HTML output directory, then
+# MATHJAX_RELPATH should be ../mathjax. The default value points to the MathJax
+# Content Delivery Network so you can quickly see the result without installing
+# MathJax. However, it is strongly recommended to install a local copy of
+# MathJax from http://www.mathjax.org before deployment.
+# The default value is: http://cdn.mathjax.org/mathjax/latest.
+# This tag requires that the tag USE_MATHJAX is set to YES.
+
+MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest
+
+# The MATHJAX_EXTENSIONS tag can be used to specify one or more MathJax
+# extension names that should be enabled during MathJax rendering. For example
+# MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols
+# This tag requires that the tag USE_MATHJAX is set to YES.
+
+MATHJAX_EXTENSIONS =
+
+# The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces
+# of code that will be used on startup of the MathJax code. See the MathJax site
+# (see: http://docs.mathjax.org/en/latest/output.html) for more details. For an
+# example see the documentation.
+# This tag requires that the tag USE_MATHJAX is set to YES.
+
+MATHJAX_CODEFILE =
+
+# When the SEARCHENGINE tag is enabled doxygen will generate a search box for
+# the HTML output. The underlying search engine uses javascript and DHTML and
+# should work on any modern browser. Note that when using HTML help
+# (GENERATE_HTMLHELP), Qt help (GENERATE_QHP), or docsets (GENERATE_DOCSET)
+# there is already a search function so this one should typically be disabled.
+# For large projects the javascript based search engine can be slow, then
+# enabling SERVER_BASED_SEARCH may provide a better solution. It is possible to
+# search using the keyboard; to jump to the search box use + S
+# (what the is depends on the OS and browser, but it is typically
+# , /, or both). Inside the search box use the to jump into the search results window, the results can be navigated
+# using the . Press to select an item or to cancel
+# the search. The filter options can be selected when the cursor is inside the
+# search box by pressing +. Also here use the
+# to select a filter and or to activate or cancel the filter
+# option.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_HTML is set to YES.
SEARCHENGINE = YES
-#---------------------------------------------------------------------------
-# configuration options related to the LaTeX output
-#---------------------------------------------------------------------------
-
-# If the GENERATE_LATEX tag is set to YES (the default) Doxygen will
-# generate Latex output.
+# When the SERVER_BASED_SEARCH tag is enabled the search engine will be
+# implemented using a web server instead of a web client using Javascript. There
+# are two flavors of web server based searching depending on the EXTERNAL_SEARCH
+# setting. When disabled, doxygen will generate a PHP script for searching and
+# an index file used by the script. When EXTERNAL_SEARCH is enabled the indexing
+# and searching needs to be provided by external tools. See the section
+# "External Indexing and Searching" for details.
+# The default value is: NO.
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+SERVER_BASED_SEARCH = NO
+
+# When EXTERNAL_SEARCH tag is enabled doxygen will no longer generate the PHP
+# script for searching. Instead the search results are written to an XML file
+# which needs to be processed by an external indexer. Doxygen will invoke an
+# external search engine pointed to by the SEARCHENGINE_URL option to obtain the
+# search results.
+#
+# Doxygen ships with an example indexer ( doxyindexer) and search engine
+# (doxysearch.cgi) which are based on the open source search engine library
+# Xapian (see: http://xapian.org/).
+#
+# See the section "External Indexing and Searching" for details.
+# The default value is: NO.
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+EXTERNAL_SEARCH = NO
+
+# The SEARCHENGINE_URL should point to a search engine hosted by a web server
+# which will return the search results when EXTERNAL_SEARCH is enabled.
+#
+# Doxygen ships with an example indexer ( doxyindexer) and search engine
+# (doxysearch.cgi) which are based on the open source search engine library
+# Xapian (see: http://xapian.org/). See the section "External Indexing and
+# Searching" for details.
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+SEARCHENGINE_URL =
+
+# When SERVER_BASED_SEARCH and EXTERNAL_SEARCH are both enabled the unindexed
+# search data is written to a file for indexing by an external tool. With the
+# SEARCHDATA_FILE tag the name of this file can be specified.
+# The default file is: searchdata.xml.
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+SEARCHDATA_FILE = searchdata.xml
+
+# When SERVER_BASED_SEARCH and EXTERNAL_SEARCH are both enabled the
+# EXTERNAL_SEARCH_ID tag can be used as an identifier for the project. This is
+# useful in combination with EXTRA_SEARCH_MAPPINGS to search through multiple
+# projects and redirect the results back to the right project.
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+EXTERNAL_SEARCH_ID =
+
+# The EXTRA_SEARCH_MAPPINGS tag can be used to enable searching through doxygen
+# projects other than the one defined by this configuration file, but that are
+# all added to the same external search index. Each project needs to have a
+# unique id set via EXTERNAL_SEARCH_ID. The search mapping then maps the id of
+# to a relative location where the documentation can be found. The format is:
+# EXTRA_SEARCH_MAPPINGS = tagname1=loc1 tagname2=loc2 ...
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+EXTRA_SEARCH_MAPPINGS =
+
+#---------------------------------------------------------------------------
+# Configuration options related to the LaTeX output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_LATEX tag is set to YES doxygen will generate LaTeX output.
+# The default value is: YES.
GENERATE_LATEX = YES
-# The LATEX_OUTPUT tag is used to specify where the LaTeX docs will be put.
-# If a relative path is entered the value of OUTPUT_DIRECTORY will be
-# put in front of it. If left blank `latex' will be used as the default path.
+# The LATEX_OUTPUT tag is used to specify where the LaTeX docs will be put. If a
+# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of
+# it.
+# The default directory is: latex.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
LATEX_OUTPUT = latex
# The LATEX_CMD_NAME tag can be used to specify the LaTeX command name to be
-# invoked. If left blank `latex' will be used as the default command name.
+# invoked.
+#
+# Note that when enabling USE_PDFLATEX this option is only used for generating
+# bitmaps for formulas in the HTML output, but not in the Makefile that is
+# written to the output directory.
+# The default file is: latex.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
LATEX_CMD_NAME = latex
-# The MAKEINDEX_CMD_NAME tag can be used to specify the command name to
-# generate index for LaTeX. If left blank `makeindex' will be used as the
-# default command name.
+# The MAKEINDEX_CMD_NAME tag can be used to specify the command name to generate
+# index for LaTeX.
+# The default file is: makeindex.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
MAKEINDEX_CMD_NAME = makeindex
-# If the COMPACT_LATEX tag is set to YES Doxygen generates more compact
-# LaTeX documents. This may be useful for small projects and may help to
-# save some trees in general.
+# If the COMPACT_LATEX tag is set to YES doxygen generates more compact LaTeX
+# documents. This may be useful for small projects and may help to save some
+# trees in general.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
COMPACT_LATEX = NO
-# The PAPER_TYPE tag can be used to set the paper type that is used
-# by the printer. Possible values are: a4, a4wide, letter, legal and
-# executive. If left blank a4wide will be used.
-
-PAPER_TYPE = a4wide
-
-# The EXTRA_PACKAGES tag can be to specify one or more names of LaTeX
-# packages that should be included in the LaTeX output.
+# The PAPER_TYPE tag can be used to set the paper type that is used by the
+# printer.
+# Possible values are: a4 (210 x 297 mm), letter (8.5 x 11 inches), legal (8.5 x
+# 14 inches) and executive (7.25 x 10.5 inches).
+# The default value is: a4.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+PAPER_TYPE = a4
+
+# The EXTRA_PACKAGES tag can be used to specify one or more LaTeX package names
+# that should be included in the LaTeX output. To get the times font for
+# instance you can specify
+# EXTRA_PACKAGES=times
+# If left blank no extra packages will be included.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
EXTRA_PACKAGES =
-# The LATEX_HEADER tag can be used to specify a personal LaTeX header for
-# the generated latex document. The header should contain everything until
-# the first chapter. If it is left blank doxygen will generate a
-# standard header. Notice: only use this tag if you know what you are doing!
+# The LATEX_HEADER tag can be used to specify a personal LaTeX header for the
+# generated LaTeX document. The header should contain everything until the first
+# chapter. If it is left blank doxygen will generate a standard header. See
+# section "Doxygen usage" for information on how to let doxygen write the
+# default header to a separate file.
+#
+# Note: Only use a user-defined header if you know what you are doing! The
+# following commands have a special meaning inside the header: $title,
+# $datetime, $date, $doxygenversion, $projectname, $projectnumber,
+# $projectbrief, $projectlogo. Doxygen will replace $title with the empy string,
+# for the replacement values of the other commands the user is refered to
+# HTML_HEADER.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
LATEX_HEADER =
-# If the PDF_HYPERLINKS tag is set to YES, the LaTeX that is generated
-# is prepared for conversion to pdf (using ps2pdf). The pdf file will
-# contain links (just like the HTML output) instead of page references
-# This makes the output suitable for online browsing using a pdf viewer.
+# The LATEX_FOOTER tag can be used to specify a personal LaTeX footer for the
+# generated LaTeX document. The footer should contain everything after the last
+# chapter. If it is left blank doxygen will generate a standard footer. See
+# LATEX_HEADER for more information on how to generate a default footer and what
+# special commands can be used inside the footer.
+#
+# Note: Only use a user-defined footer if you know what you are doing!
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_FOOTER =
+
+# The LATEX_EXTRA_FILES tag can be used to specify one or more extra images or
+# other source files which should be copied to the LATEX_OUTPUT output
+# directory. Note that the files will be copied as-is; there are no commands or
+# markers available.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_EXTRA_FILES =
+
+# If the PDF_HYPERLINKS tag is set to YES, the LaTeX that is generated is
+# prepared for conversion to PDF (using ps2pdf or pdflatex). The PDF file will
+# contain links (just like the HTML output) instead of page references. This
+# makes the output suitable for online browsing using a PDF viewer.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
PDF_HYPERLINKS = YES
-# If the USE_PDFLATEX tag is set to YES, pdflatex will be used instead of
-# plain latex in the generated Makefile. Set this option to YES to get a
+# If the USE_PDFLATEX tag is set to YES, doxygen will use pdflatex to generate
+# the PDF file directly from the LaTeX files. Set this option to YES to get a
# higher quality PDF documentation.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
USE_PDFLATEX = YES
-# If the LATEX_BATCHMODE tag is set to YES, doxygen will add the \\batchmode.
-# command to the generated LaTeX files. This will instruct LaTeX to keep
-# running if errors occur, instead of asking the user for help.
-# This option is also used when generating formulas in HTML.
+# If the LATEX_BATCHMODE tag is set to YES, doxygen will add the \batchmode
+# command to the generated LaTeX files. This will instruct LaTeX to keep running
+# if errors occur, instead of asking the user for help. This option is also used
+# when generating formulas in HTML.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
LATEX_BATCHMODE = NO
-# If LATEX_HIDE_INDICES is set to YES then doxygen will not
-# include the index chapters (such as File Index, Compound Index, etc.)
-# in the output.
+# If the LATEX_HIDE_INDICES tag is set to YES then doxygen will not include the
+# index chapters (such as File Index, Compound Index, etc.) in the output.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
LATEX_HIDE_INDICES = NO
-# If LATEX_SOURCE_CODE is set to YES then doxygen will include source code with syntax highlighting in the LaTeX output. Note that which sources are shown also depends on other settings such as SOURCE_BROWSER.
+# If the LATEX_SOURCE_CODE tag is set to YES then doxygen will include source
+# code with syntax highlighting in the LaTeX output.
+#
+# Note that which sources are shown also depends on other settings such as
+# SOURCE_BROWSER.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
LATEX_SOURCE_CODE = NO
-#---------------------------------------------------------------------------
-# configuration options related to the RTF output
-#---------------------------------------------------------------------------
-
-# If the GENERATE_RTF tag is set to YES Doxygen will generate RTF output
-# The RTF output is optimized for Word 97 and may not look very pretty with
-# other RTF readers or editors.
+# The LATEX_BIB_STYLE tag can be used to specify the style to use for the
+# bibliography, e.g. plainnat, or ieeetr. See
+# http://en.wikipedia.org/wiki/BibTeX and \cite for more info.
+# The default value is: plain.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_BIB_STYLE = plain
+
+#---------------------------------------------------------------------------
+# Configuration options related to the RTF output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_RTF tag is set to YES doxygen will generate RTF output. The
+# RTF output is optimized for Word 97 and may not look too pretty with other RTF
+# readers/editors.
+# The default value is: NO.
GENERATE_RTF = NO
-# The RTF_OUTPUT tag is used to specify where the RTF docs will be put.
-# If a relative path is entered the value of OUTPUT_DIRECTORY will be
-# put in front of it. If left blank `rtf' will be used as the default path.
+# The RTF_OUTPUT tag is used to specify where the RTF docs will be put. If a
+# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of
+# it.
+# The default directory is: rtf.
+# This tag requires that the tag GENERATE_RTF is set to YES.
RTF_OUTPUT = rtf
-# If the COMPACT_RTF tag is set to YES Doxygen generates more compact
-# RTF documents. This may be useful for small projects and may help to
-# save some trees in general.
+# If the COMPACT_RTF tag is set to YES doxygen generates more compact RTF
+# documents. This may be useful for small projects and may help to save some
+# trees in general.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_RTF is set to YES.
COMPACT_RTF = NO
-# If the RTF_HYPERLINKS tag is set to YES, the RTF that is generated
-# will contain hyperlink fields. The RTF file will
-# contain links (just like the HTML output) instead of page references.
-# This makes the output suitable for online browsing using WORD or other
-# programs which support those fields.
-# Note: wordpad (write) and others do not support links.
+# If the RTF_HYPERLINKS tag is set to YES, the RTF that is generated will
+# contain hyperlink fields. The RTF file will contain links (just like the HTML
+# output) instead of page references. This makes the output suitable for online
+# browsing using Word or some other Word compatible readers that support those
+# fields.
+#
+# Note: WordPad (write) and others do not support links.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_RTF is set to YES.
RTF_HYPERLINKS = NO
-# Load stylesheet definitions from file. Syntax is similar to doxygen's
-# config file, i.e. a series of assignments. You only have to provide
-# replacements, missing definitions are set to their default value.
+# Load stylesheet definitions from file. Syntax is similar to doxygen's config
+# file, i.e. a series of assignments. You only have to provide replacements,
+# missing definitions are set to their default value.
+#
+# See also section "Doxygen usage" for information on how to generate the
+# default style sheet that doxygen normally uses.
+# This tag requires that the tag GENERATE_RTF is set to YES.
RTF_STYLESHEET_FILE =
-# Set optional variables used in the generation of an rtf document.
-# Syntax is similar to doxygen's config file.
+# Set optional variables used in the generation of an RTF document. Syntax is
+# similar to doxygen's config file. A template extensions file can be generated
+# using doxygen -e rtf extensionFile.
+# This tag requires that the tag GENERATE_RTF is set to YES.
RTF_EXTENSIONS_FILE =
#---------------------------------------------------------------------------
-# configuration options related to the man page output
-#---------------------------------------------------------------------------
-
-# If the GENERATE_MAN tag is set to YES (the default) Doxygen will
-# generate man pages
+# Configuration options related to the man page output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_MAN tag is set to YES doxygen will generate man pages for
+# classes and files.
+# The default value is: NO.
GENERATE_MAN = NO
-# The MAN_OUTPUT tag is used to specify where the man pages will be put.
-# If a relative path is entered the value of OUTPUT_DIRECTORY will be
-# put in front of it. If left blank `man' will be used as the default path.
+# The MAN_OUTPUT tag is used to specify where the man pages will be put. If a
+# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of
+# it. A directory man3 will be created inside the directory specified by
+# MAN_OUTPUT.
+# The default directory is: man.
+# This tag requires that the tag GENERATE_MAN is set to YES.
MAN_OUTPUT = man
-# The MAN_EXTENSION tag determines the extension that is added to
-# the generated man pages (default is the subroutine's section .3)
+# The MAN_EXTENSION tag determines the extension that is added to the generated
+# man pages. In case the manual section does not start with a number, the number
+# 3 is prepended. The dot (.) at the beginning of the MAN_EXTENSION tag is
+# optional.
+# The default value is: .3.
+# This tag requires that the tag GENERATE_MAN is set to YES.
MAN_EXTENSION = .3
-# If the MAN_LINKS tag is set to YES and Doxygen generates man output,
-# then it will generate one additional man file for each entity
-# documented in the real man page(s). These additional files
-# only source the real man page, but without them the man command
-# would be unable to find the correct page. The default is NO.
+# The MAN_SUBDIR tag determines the name of the directory created within
+# MAN_OUTPUT in which the man pages are placed. If defaults to man followed by
+# MAN_EXTENSION with the initial . removed.
+# This tag requires that the tag GENERATE_MAN is set to YES.
+
+MAN_SUBDIR =
+
+# If the MAN_LINKS tag is set to YES and doxygen generates man output, then it
+# will generate one additional man file for each entity documented in the real
+# man page(s). These additional files only source the real man page, but without
+# them the man command would be unable to find the correct page.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_MAN is set to YES.
MAN_LINKS = NO
#---------------------------------------------------------------------------
-# configuration options related to the XML output
-#---------------------------------------------------------------------------
-
-# If the GENERATE_XML tag is set to YES Doxygen will
-# generate an XML file that captures the structure of
-# the code including all documentation.
+# Configuration options related to the XML output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_XML tag is set to YES doxygen will generate an XML file that
+# captures the structure of the code including all documentation.
+# The default value is: NO.
GENERATE_XML = NO
-# The XML_OUTPUT tag is used to specify where the XML pages will be put.
-# If a relative path is entered the value of OUTPUT_DIRECTORY will be
-# put in front of it. If left blank `xml' will be used as the default path.
+# The XML_OUTPUT tag is used to specify where the XML pages will be put. If a
+# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of
+# it.
+# The default directory is: xml.
+# This tag requires that the tag GENERATE_XML is set to YES.
XML_OUTPUT = xml
-# The XML_SCHEMA tag can be used to specify an XML schema,
-# which can be used by a validating XML parser to check the
-# syntax of the XML files.
-
-XML_SCHEMA =
-
-# The XML_DTD tag can be used to specify an XML DTD,
-# which can be used by a validating XML parser to check the
-# syntax of the XML files.
-
-XML_DTD =
-
-# If the XML_PROGRAMLISTING tag is set to YES Doxygen will
-# dump the program listings (including syntax highlighting
-# and cross-referencing information) to the XML output. Note that
-# enabling this will significantly increase the size of the XML output.
+# If the XML_PROGRAMLISTING tag is set to YES doxygen will dump the program
+# listings (including syntax highlighting and cross-referencing information) to
+# the XML output. Note that enabling this will significantly increase the size
+# of the XML output.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_XML is set to YES.
XML_PROGRAMLISTING = YES
#---------------------------------------------------------------------------
-# configuration options for the AutoGen Definitions output
-#---------------------------------------------------------------------------
-
-# If the GENERATE_AUTOGEN_DEF tag is set to YES Doxygen will
-# generate an AutoGen Definitions (see autogen.sf.net) file
-# that captures the structure of the code including all
-# documentation. Note that this feature is still experimental
-# and incomplete at the moment.
+# Configuration options related to the DOCBOOK output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_DOCBOOK tag is set to YES doxygen will generate Docbook files
+# that can be used to generate PDF.
+# The default value is: NO.
+
+GENERATE_DOCBOOK = NO
+
+# The DOCBOOK_OUTPUT tag is used to specify where the Docbook pages will be put.
+# If a relative path is entered the value of OUTPUT_DIRECTORY will be put in
+# front of it.
+# The default directory is: docbook.
+# This tag requires that the tag GENERATE_DOCBOOK is set to YES.
+
+DOCBOOK_OUTPUT = docbook
+
+# If the DOCBOOK_PROGRAMLISTING tag is set to YES doxygen will include the
+# program listings (including syntax highlighting and cross-referencing
+# information) to the DOCBOOK output. Note that enabling this will significantly
+# increase the size of the DOCBOOK output.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_DOCBOOK is set to YES.
+
+DOCBOOK_PROGRAMLISTING = NO
+
+#---------------------------------------------------------------------------
+# Configuration options for the AutoGen Definitions output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_AUTOGEN_DEF tag is set to YES doxygen will generate an AutoGen
+# Definitions (see http://autogen.sf.net) file that captures the structure of
+# the code including all documentation. Note that this feature is still
+# experimental and incomplete at the moment.
+# The default value is: NO.
GENERATE_AUTOGEN_DEF = NO
#---------------------------------------------------------------------------
-# configuration options related to the Perl module output
-#---------------------------------------------------------------------------
-
-# If the GENERATE_PERLMOD tag is set to YES Doxygen will
-# generate a Perl module file that captures the structure of
-# the code including all documentation. Note that this
-# feature is still experimental and incomplete at the
-# moment.
+# Configuration options related to the Perl module output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_PERLMOD tag is set to YES doxygen will generate a Perl module
+# file that captures the structure of the code including all documentation.
+#
+# Note that this feature is still experimental and incomplete at the moment.
+# The default value is: NO.
GENERATE_PERLMOD = NO
-# If the PERLMOD_LATEX tag is set to YES Doxygen will generate
-# the necessary Makefile rules, Perl scripts and LaTeX code to be able
-# to generate PDF and DVI output from the Perl module output.
+# If the PERLMOD_LATEX tag is set to YES doxygen will generate the necessary
+# Makefile rules, Perl scripts and LaTeX code to be able to generate PDF and DVI
+# output from the Perl module output.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_PERLMOD is set to YES.
PERLMOD_LATEX = NO
-# If the PERLMOD_PRETTY tag is set to YES the Perl module output will be
-# nicely formatted so it can be parsed by a human reader.
-# This is useful
-# if you want to understand what is going on.
-# On the other hand, if this
-# tag is set to NO the size of the Perl module output will be much smaller
-# and Perl will parse it just the same.
+# If the PERLMOD_PRETTY tag is set to YES the Perl module output will be nicely
+# formatted so it can be parsed by a human reader. This is useful if you want to
+# understand what is going on. On the other hand, if this tag is set to NO the
+# size of the Perl module output will be much smaller and Perl will parse it
+# just the same.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_PERLMOD is set to YES.
PERLMOD_PRETTY = YES
-# The names of the make variables in the generated doxyrules.make file
-# are prefixed with the string contained in PERLMOD_MAKEVAR_PREFIX.
-# This is useful so different doxyrules.make files included by the same
-# Makefile don't overwrite each other's variables.
+# The names of the make variables in the generated doxyrules.make file are
+# prefixed with the string contained in PERLMOD_MAKEVAR_PREFIX. This is useful
+# so different doxyrules.make files included by the same Makefile don't
+# overwrite each other's variables.
+# This tag requires that the tag GENERATE_PERLMOD is set to YES.
PERLMOD_MAKEVAR_PREFIX =
@@ -1218,31 +1902,38 @@
#---------------------------------------------------------------------------
-# If the ENABLE_PREPROCESSING tag is set to YES (the default) Doxygen will
-# evaluate all C-preprocessor directives found in the sources and include
-# files.
+# If the ENABLE_PREPROCESSING tag is set to YES doxygen will evaluate all
+# C-preprocessor directives found in the sources and include files.
+# The default value is: YES.
ENABLE_PREPROCESSING = YES
-# If the MACRO_EXPANSION tag is set to YES Doxygen will expand all macro
-# names in the source code. If set to NO (the default) only conditional
-# compilation will be performed. Macro expansion can be done in a controlled
-# way by setting EXPAND_ONLY_PREDEF to YES.
+# If the MACRO_EXPANSION tag is set to YES doxygen will expand all macro names
+# in the source code. If set to NO only conditional compilation will be
+# performed. Macro expansion can be done in a controlled way by setting
+# EXPAND_ONLY_PREDEF to YES.
+# The default value is: NO.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
MACRO_EXPANSION = NO
-# If the EXPAND_ONLY_PREDEF and MACRO_EXPANSION tags are both set to YES
-# then the macro expansion is limited to the macros specified with the
-# PREDEFINED and EXPAND_AS_DEFINED tags.
+# If the EXPAND_ONLY_PREDEF and MACRO_EXPANSION tags are both set to YES then
+# the macro expansion is limited to the macros specified with the PREDEFINED and
+# EXPAND_AS_DEFINED tags.
+# The default value is: NO.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
EXPAND_ONLY_PREDEF = NO
-# If the SEARCH_INCLUDES tag is set to YES (the default) the includes files
-# in the INCLUDE_PATH (see below) will be search if a #include is found.
+# If the SEARCH_INCLUDES tag is set to YES the includes files in the
+# INCLUDE_PATH will be searched if a #include is found.
+# The default value is: YES.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
SEARCH_INCLUDES = YES
# The INCLUDE_PATH tag can be used to specify one or more directories that
-# contain include files that are not input files but should be processed by
-# the preprocessor.
+# contain include files that are not input files but should be processed by the
+# preprocessor.
+# This tag requires that the tag SEARCH_INCLUDES is set to YES.
INCLUDE_PATH =
@@ -1250,76 +1941,87 @@
# You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard
# patterns (like *.h and *.hpp) to filter out the header-files in the
-# directories. If left blank, the patterns specified with FILE_PATTERNS will
-# be used.
+# directories. If left blank, the patterns specified with FILE_PATTERNS will be
+# used.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
INCLUDE_FILE_PATTERNS =
-# The PREDEFINED tag can be used to specify one or more macro names that
-# are defined before the preprocessor is started (similar to the -D option of
-# gcc). The argument of the tag is a list of macros of the form: name
-# or name=definition (no spaces). If the definition and the = are
-# omitted =1 is assumed. To prevent a macro definition from being
-# undefined via #undef or recursively expanded use the := operator
-# instead of the = operator.
+# The PREDEFINED tag can be used to specify one or more macro names that are
+# defined before the preprocessor is started (similar to the -D option of e.g.
+# gcc). The argument of the tag is a list of macros of the form: name or
+# name=definition (no spaces). If the definition and the "=" are omitted, "=1"
+# is assumed. To prevent a macro definition from being undefined via #undef or
+# recursively expanded use the := operator instead of the = operator.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
PREDEFINED =
-# If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then
-# this tag can be used to specify a list of macro names that should be expanded.
-# The macro definition that is found in the sources will be used.
-# Use the PREDEFINED tag if you want to use a different macro definition.
+# If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then this
+# tag can be used to specify a list of macro names that should be expanded. The
+# macro definition that is found in the sources will be used. Use the PREDEFINED
+# tag if you want to use a different macro definition that overrules the
+# definition found in the source code.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
EXPAND_AS_DEFINED =
-# If the SKIP_FUNCTION_MACROS tag is set to YES (the default) then
-# doxygen's preprocessor will remove all function-like macros that are alone
-# on a line, have an all uppercase name, and do not end with a semicolon. Such
-# function macros are typically used for boiler-plate code, and will confuse
-# the parser if not removed.
+# If the SKIP_FUNCTION_MACROS tag is set to YES then doxygen's preprocessor will
+# remove all references to function-like macros that are alone on a line, have
+# an all uppercase name, and do not end with a semicolon. Such function macros
+# are typically used for boiler-plate code, and will confuse the parser if not
+# removed.
+# The default value is: YES.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
SKIP_FUNCTION_MACROS = YES
#---------------------------------------------------------------------------
-# Configuration::additions related to external references
-#---------------------------------------------------------------------------
-
-# The TAGFILES option can be used to specify one or more tagfiles.
-# Optionally an initial location of the external documentation
-# can be added for each tagfile. The format of a tag file without
-# this location is as follows:
-#
+# Configuration options related to external references
+#---------------------------------------------------------------------------
+
+# The TAGFILES tag can be used to specify one or more tag files. For each tag
+# file the location of the external documentation should be added. The format of
+# a tag file without this location is as follows:
# TAGFILES = file1 file2 ...
# Adding location for the tag files is done as follows:
-#
# TAGFILES = file1=loc1 "file2 = loc2" ...
-# where "loc1" and "loc2" can be relative or absolute paths or
-# URLs. If a location is present for each tag, the installdox tool
-# does not have to be run to correct the links.
-# Note that each tag file must have a unique name
-# (where the name does NOT include the path)
-# If a tag file is not located in the directory in which doxygen
-# is run, you must also specify the path to the tagfile here.
+# where loc1 and loc2 can be relative or absolute paths or URLs. See the
+# section "Linking to external documentation" for more information about the use
+# of tag files.
+# Note: Each tag file must have a unique name (where the name does NOT include
+# the path). If a tag file is not located in the directory in which doxygen is
+# run, you must also specify the path to the tagfile here.
TAGFILES =
-# When a file name is specified after GENERATE_TAGFILE, doxygen will create
-# a tag file that is based on the input files it reads.
+# When a file name is specified after GENERATE_TAGFILE, doxygen will create a
+# tag file that is based on the input files it reads. See section "Linking to
+# external documentation" for more information about the usage of tag files.
GENERATE_TAGFILE =
-# If the ALLEXTERNALS tag is set to YES all external classes will be listed
-# in the class index. If set to NO only the inherited external classes
-# will be listed.
+# If the ALLEXTERNALS tag is set to YES all external class will be listed in the
+# class index. If set to NO only the inherited external classes will be listed.
+# The default value is: NO.
ALLEXTERNALS = NO
-# If the EXTERNAL_GROUPS tag is set to YES all external groups will be listed
-# in the modules index. If set to NO, only the current project's groups will
+# If the EXTERNAL_GROUPS tag is set to YES all external groups will be listed in
+# the modules index. If set to NO, only the current project's groups will be
+# listed.
+# The default value is: YES.
+
+EXTERNAL_GROUPS = YES
+
+# If the EXTERNAL_PAGES tag is set to YES all external pages will be listed in
+# the related pages index. If set to NO, only the current project's pages will
# be listed.
-
-EXTERNAL_GROUPS = YES
+# The default value is: YES.
+
+EXTERNAL_PAGES = YES
# The PERL_PATH should be the absolute path and name of the perl script
-# interpreter (i.e. the result of `which perl').
+# interpreter (i.e. the result of 'which perl').
+# The default file (with absolute path) is: /usr/bin/perl.
PERL_PATH = /usr/bin/perl
@@ -1329,16 +2031,16 @@
#---------------------------------------------------------------------------
-# If the CLASS_DIAGRAMS tag is set to YES (the default) Doxygen will
-# generate a inheritance diagram (in HTML, RTF and LaTeX) for classes with base
-# or super classes. Setting the tag to NO turns the diagrams off. Note that
-# this option is superseded by the HAVE_DOT option below. This is only a
-# fallback. It is recommended to install and use dot, since it yields more
+# If the CLASS_DIAGRAMS tag is set to YES doxygen will generate a class diagram
+# (in HTML and LaTeX) for classes with base or super classes. Setting the tag to
+# NO turns the diagrams off. Note that this option also works with HAVE_DOT
+# disabled, but it is recommended to install and use dot, since it yields more
# powerful graphs.
+# The default value is: YES.
CLASS_DIAGRAMS = YES
# You can define message sequence charts within doxygen comments using the \msc
-# command. Doxygen will then run the mscgen tool (see
-# http://www.mcternan.me.uk/mscgen/) to produce the chart and insert it in the
+# command. Doxygen will then run the mscgen tool (see:
+# http://www.mcternan.me.uk/mscgen/)) to produce the chart and insert it in the
# documentation. The MSCGEN_PATH tag allows you to specify the directory where
# the mscgen tool resides. If left empty the tool is assumed to be found in the
@@ -1347,56 +2049,81 @@
MSCGEN_PATH =
-# If set to YES, the inheritance and collaboration graphs will hide
-# inheritance and usage relations if the target is undocumented
-# or is not a class.
+# You can include diagrams made with dia in doxygen documentation. Doxygen will
+# then run dia to produce the diagram and insert it in the documentation. The
+# DIA_PATH tag allows you to specify the directory where the dia binary resides.
+# If left empty dia is assumed to be found in the default search path.
+
+DIA_PATH =
+
+# If set to YES, the inheritance and collaboration graphs will hide inheritance
+# and usage relations if the target is undocumented or is not a class.
+# The default value is: YES.
HIDE_UNDOC_RELATIONS = YES
# If you set the HAVE_DOT tag to YES then doxygen will assume the dot tool is
-# available from the path. This tool is part of Graphviz, a graph visualization
-# toolkit from AT&T and Lucent Bell Labs. The other options in this section
-# have no effect if this option is set to NO (the default)
-
-HAVE_DOT = YES
-
-# By default doxygen will write a font called FreeSans.ttf to the output
-# directory and reference it in all dot files that doxygen generates. This
-# font does not include all possible unicode characters however, so when you need
-# these (or just want a differently looking font) you can specify the font name
-# using DOT_FONTNAME. You need need to make sure dot is able to find the font,
-# which can be done by putting it in a standard location or by setting the
-# DOTFONTPATH environment variable or by setting DOT_FONTPATH to the directory
-# containing the font.
-
-DOT_FONTNAME = FreeSans
-
-# The DOT_FONTSIZE tag can be used to set the size of the font of dot graphs.
-# The default size is 10pt.
+# available from the path. This tool is part of Graphviz (see:
+# http://www.graphviz.org/), a graph visualization toolkit from AT&T and Lucent
+# Bell Labs. The other options in this section have no effect if this option is
+# set to NO
+# The default value is: NO.
+
+HAVE_DOT = YES
+
+# The DOT_NUM_THREADS specifies the number of dot invocations doxygen is allowed
+# to run in parallel. When set to 0 doxygen will base this on the number of
+# processors available in the system. You can set it explicitly to a value
+# larger than 0 to get control over the balance between CPU load and processing
+# speed.
+# Minimum value: 0, maximum value: 32, default value: 0.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_NUM_THREADS = 0
+
+# When you want a differently looking font in the dot files that doxygen
+# generates you can specify the font name using DOT_FONTNAME. You need to make
+# sure dot is able to find the font, which can be done by putting it in a
+# standard location or by setting the DOTFONTPATH environment variable or by
+# setting DOT_FONTPATH to the directory containing the font.
+# The default value is: Helvetica.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_FONTNAME = Helvetica
+
+# The DOT_FONTSIZE tag can be used to set the size (in points) of the font of
+# dot graphs.
+# Minimum value: 4, maximum value: 24, default value: 10.
+# This tag requires that the tag HAVE_DOT is set to YES.
DOT_FONTSIZE = 10
-# By default doxygen will tell dot to use the output directory to look for the
-# FreeSans.ttf font (which doxygen will put there itself). If you specify a
-# different font using DOT_FONTNAME you can set the path where dot
-# can find it using this tag.
+# By default doxygen will tell dot to use the default font as specified with
+# DOT_FONTNAME. If you specify a different font using DOT_FONTNAME you can set
+# the path where dot can find it using this tag.
+# This tag requires that the tag HAVE_DOT is set to YES.
DOT_FONTPATH =
-# If the CLASS_GRAPH and HAVE_DOT tags are set to YES then doxygen
-# will generate a graph for each documented class showing the direct and
-# indirect inheritance relations. Setting this tag to YES will force the
-# the CLASS_DIAGRAMS tag to NO.
+# If the CLASS_GRAPH tag is set to YES then doxygen will generate a graph for
+# each documented class showing the direct and indirect inheritance relations.
+# Setting this tag to YES will force the CLASS_DIAGRAMS tag to NO.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
CLASS_GRAPH = YES
-# If the COLLABORATION_GRAPH and HAVE_DOT tags are set to YES then doxygen
-# will generate a graph for each documented class showing the direct and
-# indirect implementation dependencies (inheritance, containment, and
-# class references variables) of the class with other documented classes.
+# If the COLLABORATION_GRAPH tag is set to YES then doxygen will generate a
+# graph for each documented class showing the direct and indirect implementation
+# dependencies (inheritance, containment, and class references variables) of the
+# class with other documented classes.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
COLLABORATION_GRAPH = YES
-# If the GROUP_GRAPHS and HAVE_DOT tags are set to YES then doxygen
-# will generate a graph for groups, showing the direct groups dependencies
+# If the GROUP_GRAPHS tag is set to YES then doxygen will generate a graph for
+# groups, showing the direct groups dependencies.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
GROUP_GRAPHS = YES
@@ -1405,96 +2132,176 @@
# collaboration diagrams in a style similar to the OMG's Unified Modeling
# Language.
-
-UML_LOOK = NO
-
-# If set to YES, the inheritance and collaboration graphs will show the
-# relations between templates and their instances.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+UML_LOOK = YES
+
+# If the UML_LOOK tag is enabled, the fields and methods are shown inside the
+# class node. If there are many fields or methods and many nodes the graph may
+# become too big to be useful. The UML_LIMIT_NUM_FIELDS threshold limits the
+# number of items for each type to make the size more manageable. Set this to 0
+# for no limit. Note that the threshold may be exceeded by 50% before the limit
+# is enforced. So when you set the threshold to 10, up to 15 fields may appear,
+# but if the number exceeds 15, the total amount of fields shown is limited to
+# 10.
+# Minimum value: 0, maximum value: 100, default value: 10.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+UML_LIMIT_NUM_FIELDS = 10
+
+# If the TEMPLATE_RELATIONS tag is set to YES then the inheritance and
+# collaboration graphs will show the relations between templates and their
+# instances.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
TEMPLATE_RELATIONS = NO
-# If the ENABLE_PREPROCESSING, SEARCH_INCLUDES, INCLUDE_GRAPH, and HAVE_DOT
-# tags are set to YES then doxygen will generate a graph for each documented
-# file showing the direct and indirect include dependencies of the file with
-# other documented files.
+# If the INCLUDE_GRAPH, ENABLE_PREPROCESSING and SEARCH_INCLUDES tags are set to
+# YES then doxygen will generate a graph for each documented file showing the
+# direct and indirect include dependencies of the file with other documented
+# files.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
INCLUDE_GRAPH = YES
-# If the ENABLE_PREPROCESSING, SEARCH_INCLUDES, INCLUDED_BY_GRAPH, and
-# HAVE_DOT tags are set to YES then doxygen will generate a graph for each
-# documented header file showing the documented files that directly or
-# indirectly include this file.
+# If the INCLUDED_BY_GRAPH, ENABLE_PREPROCESSING and SEARCH_INCLUDES tags are
+# set to YES then doxygen will generate a graph for each documented file showing
+# the direct and indirect include dependencies of the file with other documented
+# files.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
INCLUDED_BY_GRAPH = YES
-# If the CALL_GRAPH and HAVE_DOT options are set to YES then
-# doxygen will generate a call dependency graph for every global function
-# or class method. Note that enabling this option will significantly increase
-# the time of a run. So in most cases it will be better to enable call graphs
-# for selected functions only using the \callgraph command.
-
-CALL_GRAPH = YES
-
-# If the CALLER_GRAPH and HAVE_DOT tags are set to YES then
-# doxygen will generate a caller dependency graph for every global function
-# or class method. Note that enabling this option will significantly increase
-# the time of a run. So in most cases it will be better to enable caller
-# graphs for selected functions only using the \callergraph command.
-
-CALLER_GRAPH = YES
-
-# If the GRAPHICAL_HIERARCHY and HAVE_DOT tags are set to YES then doxygen
-# will graphical hierarchy of all classes instead of a textual one.
+# If the CALL_GRAPH tag is set to YES then doxygen will generate a call
+# dependency graph for every global function or class method.
+#
+# Note that enabling this option will significantly increase the time of a run.
+# So in most cases it will be better to enable call graphs for selected
+# functions only using the \callgraph command.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+CALL_GRAPH = NO
+
+# If the CALLER_GRAPH tag is set to YES then doxygen will generate a caller
+# dependency graph for every global function or class method.
+#
+# Note that enabling this option will significantly increase the time of a run.
+# So in most cases it will be better to enable caller graphs for selected
+# functions only using the \callergraph command.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+CALLER_GRAPH = NO
+
+# If the GRAPHICAL_HIERARCHY tag is set to YES then doxygen will graphical
+# hierarchy of all classes instead of a textual one.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
GRAPHICAL_HIERARCHY = YES
-# If the DIRECTORY_GRAPH, SHOW_DIRECTORIES and HAVE_DOT tags are set to YES
-# then doxygen will show the dependencies a directory has on other directories
-# in a graphical way. The dependency relations are determined by the #include
-# relations between the files in the directories.
+# If the DIRECTORY_GRAPH tag is set to YES then doxygen will show the
+# dependencies a directory has on other directories in a graphical way. The
+# dependency relations are determined by the #include relations between the
+# files in the directories.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
DIRECTORY_GRAPH = YES
# The DOT_IMAGE_FORMAT tag can be used to set the image format of the images
-# generated by dot. Possible values are png, jpg, or gif
-# If left blank png will be used.
+# generated by dot.
+# Note: If you choose svg you need to set HTML_FILE_EXTENSION to xhtml in order
+# to make the SVG files visible in IE 9+ (other browsers do not have this
+# requirement).
+# Possible values are: png, jpg, gif and svg.
+# The default value is: png.
+# This tag requires that the tag HAVE_DOT is set to YES.
DOT_IMAGE_FORMAT = png
-# The tag DOT_PATH can be used to specify the path where the dot tool can be
+# If DOT_IMAGE_FORMAT is set to svg, then this option can be set to YES to
+# enable generation of interactive SVG images that allow zooming and panning.
+#
+# Note that this requires a modern browser other than Internet Explorer. Tested
+# and working are Firefox, Chrome, Safari, and Opera.
+# Note: For IE 9+ you need to set HTML_FILE_EXTENSION to xhtml in order to make
+# the SVG files visible. Older versions of IE do not have SVG support.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+INTERACTIVE_SVG = NO
+
+# The DOT_PATH tag can be used to specify the path where the dot tool can be
# found. If left blank, it is assumed the dot tool can be found in the path.
+# This tag requires that the tag HAVE_DOT is set to YES.
DOT_PATH =
# The DOTFILE_DIRS tag can be used to specify one or more directories that
-# contain dot files that are included in the documentation (see the
-# \dotfile command).
+# contain dot files that are included in the documentation (see the \dotfile
+# command).
+# This tag requires that the tag HAVE_DOT is set to YES.
DOTFILE_DIRS =
-# The DOT_GRAPH_MAX_NODES tag can be used to set the maximum number of
-# nodes that will be shown in the graph. If the number of nodes in a graph
-# becomes larger than this value, doxygen will truncate the graph, which is
-# visualized by representing a node as a red box. Note that doxygen if the
-# number of direct children of the root node in a graph is already larger than
-# DOT_GRAPH_MAX_NODES then the graph will not be shown at all. Also note
-# that the size of a graph can be further restricted by MAX_DOT_GRAPH_DEPTH.
+# The MSCFILE_DIRS tag can be used to specify one or more directories that
+# contain msc files that are included in the documentation (see the \mscfile
+# command).
+
+MSCFILE_DIRS =
+
+# The DIAFILE_DIRS tag can be used to specify one or more directories that
+# contain dia files that are included in the documentation (see the \diafile
+# command).
+
+DIAFILE_DIRS =
+
+# When using plantuml, the PLANTUML_JAR_PATH tag should be used to specify the
+# path where java can find the plantuml.jar file. If left blank, it is assumed
+# PlantUML is not used or called during a preprocessing step. Doxygen will
+# generate a warning when it encounters a \startuml command in this case and
+# will not generate output for the diagram.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+PLANTUML_JAR_PATH =
+
+# The DOT_GRAPH_MAX_NODES tag can be used to set the maximum number of nodes
+# that will be shown in the graph. If the number of nodes in a graph becomes
+# larger than this value, doxygen will truncate the graph, which is visualized
+# by representing a node as a red box. Note that doxygen if the number of direct
+# children of the root node in a graph is already larger than
+# DOT_GRAPH_MAX_NODES then the graph will not be shown at all. Also note that
+# the size of a graph can be further restricted by MAX_DOT_GRAPH_DEPTH.
+# Minimum value: 0, maximum value: 10000, default value: 50.
+# This tag requires that the tag HAVE_DOT is set to YES.
DOT_GRAPH_MAX_NODES = 50
-# The MAX_DOT_GRAPH_DEPTH tag can be used to set the maximum depth of the
-# graphs generated by dot. A depth value of 3 means that only nodes reachable
-# from the root by following a path via at most 3 edges will be shown. Nodes
-# that lay further from the root node will be omitted. Note that setting this
-# option to 1 or 2 may greatly reduce the computation time needed for large
-# code bases. Also note that the size of a graph can be further restricted by
+# The MAX_DOT_GRAPH_DEPTH tag can be used to set the maximum depth of the graphs
+# generated by dot. A depth value of 3 means that only nodes reachable from the
+# root by following a path via at most 3 edges will be shown. Nodes that lay
+# further from the root node will be omitted. Note that setting this option to 1
+# or 2 may greatly reduce the computation time needed for large code bases. Also
+# note that the size of a graph can be further restricted by
# DOT_GRAPH_MAX_NODES. Using a depth of 0 means no depth restriction.
+# Minimum value: 0, maximum value: 1000, default value: 0.
+# This tag requires that the tag HAVE_DOT is set to YES.
MAX_DOT_GRAPH_DEPTH = 0
# Set the DOT_TRANSPARENT tag to YES to generate images with a transparent
-# background. This is disabled by default, because dot on Windows does not
-# seem to support this out of the box. Warning: Depending on the platform used,
-# enabling this option may lead to badly anti-aliased labels on the edges of
-# a graph (i.e. they become hard to read).
+# background. This is disabled by default, because dot on Windows does not seem
+# to support this out of the box.
+#
+# Warning: Depending on the platform used, enabling this option may lead to
+# badly anti-aliased labels on the edges of a graph (i.e. they become hard to
+# read).
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
DOT_TRANSPARENT = NO
@@ -1502,18 +2309,23 @@
# Set the DOT_MULTI_TARGETS tag to YES allow dot to generate multiple output
# files in one run (i.e. multiple -o and -T options on the command line). This
-# makes dot run faster, but since only newer versions of dot (>1.8.10)
-# support this, this feature is disabled by default.
+# makes dot run faster, but since only newer versions of dot (>1.8.10) support
+# this, this feature is disabled by default.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
DOT_MULTI_TARGETS = NO
-# If the GENERATE_LEGEND tag is set to YES (the default) Doxygen will
-# generate a legend page explaining the meaning of the various boxes and
-# arrows in the dot generated graphs.
+# If the GENERATE_LEGEND tag is set to YES doxygen will generate a legend page
+# explaining the meaning of the various boxes and arrows in the dot generated
+# graphs.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
GENERATE_LEGEND = YES
-# If the DOT_CLEANUP tag is set to YES (the default) Doxygen will
-# remove the intermediate dot files that are used to generate
-# the various graphs.
+# If the DOT_CLEANUP tag is set to YES doxygen will remove the intermediate dot
+# files that are used to generate the various graphs.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
DOT_CLEANUP = YES
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/attribute.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/attribute.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/attribute.f90 (revision 5214)
@@ -8,23 +8,60 @@
!> @brief
!> This module manage attribute of variable or file.
-!
+!>
!> @details
!> define type TATT:
-!> TYPE(TATT) :: tl_att
+!> @code
+!> TYPE(TATT) :: tl_att
+!> @endcode
!>
!> the attribute value inside attribute structure will be
-!> character or real(8) 1D table.
-!> However the attribute value could be initialised with:
+!> character or real(8) 1D array.
+!> However the attribute value could be initialized with:
!> - character
!> - scalar (real(4), real(8), integer(4) or integer(8))
-!> - table 1D (real(4), real(8), integer(4) or integer(8))
+!> - array 1D (real(4), real(8), integer(4) or integer(8))
!>
-!> to initialise an attribute structure :
-!> tl_att=att_init('attname',value)
-!> tl_att=att_init('attname',tab_value)
+!> to initialize an attribute structure :
+!> @code
+!> tl_att=att_init('attname',value)
+!> @endcode
+!> - value is a character, scalar value or table of value
!>
-!> to print attribute information of one attribute structure:
+!> to print attribute information of one or array of attribute structure:
+!> @code
!> CALL att_print(td_att)
+!> @endcode
!>
+!> to clean attribute structure:
+!> @code
+!> CALL att_clean(td_att)
+!> @endcode
+!>
+!> to copy attribute structure in another one (using different memory cell):
+!> @code
+!> tl_att2=att_copy(tl_att1)
+!> @endcode
+!> @note as we use pointer for the value array of the attribute structure,
+!> the use of the assignment operator (=) to copy attribute structure
+!> create a pointer on the same array.
+!> This is not the case with this copy function.
+!>
+!> to get attribute index, in an array of attribute structure:
+!> @code
+!> il_index=att_get_index( td_att, cd_name )
+!> @endcode
+!> - td_att array of attribute structure
+!> - cd_name attribute name
+!>
+!> to get attribute id, read from a file:
+!>@code
+!> il_id=att_get_id( td_att, cd_name )
+!>@endcode
+!> - td_att array of attribute structure
+!> - cd_name attribute name
+!>
+!> to get attribute name
+!> - tl_att\%c_name
+!>
!> to get character length or the number of value store in attribute
!> - tl_att\%i_len
@@ -38,15 +75,13 @@
!> - tl_att\%i_type
!>
-!> to get attribute id (affected when attributes will be added to
-!> variable or file):
+!> to get attribute id (read from file):
!> - tl_att\%i_id
!>
-!> @author
-!> J.Paul
+!> @author J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
+!> @date November, 2013 - Initial Version
+!> @date November, 2014 - Fix memory leaks bug
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!> @todo
!----------------------------------------------------------------------
MODULE att
@@ -54,42 +89,44 @@
USE global ! global variable
USE kind ! F90 kind parameter
- USE logger ! log file manager
+ USE logger ! log file manager
USE fct ! basic useful function
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! type and variable
- PUBLIC :: TATT ! attribute structure
+ PUBLIC :: TATT !< attribute structure
! function and subroutine
- PUBLIC :: ASSIGNMENT(=) ! copy attribute structure
- PUBLIC :: att_init ! initialize attribute structure
- PUBLIC :: att_print ! print attribute structure
- PUBLIC :: att_get_id ! get attribute id in table of attribute structure
- PUBLIC :: att_clean ! clean attribute strcuture
-
- PRIVATE :: att__init_c ! initialise an attribute structure with character value
- PRIVATE :: att__init_dp ! initialise an attribute structure with table of real(8) value
- PRIVATE :: att__init_dp_0d ! initialise an attribute structure with real(8) value
- PRIVATE :: att__init_sp ! initialise an attribute structure with table of real(4) value
- PRIVATE :: att__init_sp_0d ! initialise an attribute structure with real(4) value
- PRIVATE :: att__init_i1 ! initialise an attribute structure with table of integer(1) value
- PRIVATE :: att__init_i1_0d ! initialise an attribute structure with integer(1) value
- PRIVATE :: att__init_i2 ! initialise an attribute structure with table of integer(2) value
- PRIVATE :: att__init_i2_0d ! initialise an attribute structure with integer(2) value
- PRIVATE :: att__init_i4 ! initialise an attribute structure with table of integer(4) value
- PRIVATE :: att__init_i4_0d ! initialise an attribute structure with integer(4) value
- PRIVATE :: att__init_i8 ! initialise an attribute structure with table of integer(8) value
- PRIVATE :: att__init_i8_0d ! initialise an attribute structure with integer(8) value
- PRIVATE :: att__copy_unit ! copy attribute structure
- PRIVATE :: att__copy_tab ! copy attribute structure
-
- !> @struct TATT
- TYPE TATT
- !CHARACTER(LEN=lc) :: c_name = 'unknown' !< attribute name
- CHARACTER(LEN=lc) :: c_name = '' !< attribute name
- INTEGER(i4) :: i_id = 0 !< attribute id
- INTEGER(i4) :: i_type = 0 !< attribute type
+ PUBLIC :: att_init !< initialize attribute structure
+ PUBLIC :: att_print !< print attribute structure
+ PUBLIC :: att_clean !< clean attribute strcuture
+ PUBLIC :: att_copy !< copy attribute structure
+ PUBLIC :: att_get_index !< get attribute index, in an array of attribute structure
+ PUBLIC :: att_get_id !< get attribute id, read from file
+
+ PRIVATE :: att__clean_unit ! clean attribute strcuture
+ PRIVATE :: att__clean_arr ! clean array of attribute strcuture
+ PRIVATE :: att__print_unit ! print information on one attribute
+ PRIVATE :: att__print_arr ! print information on a array of attribute
+ PRIVATE :: att__init_c ! initialize an attribute structure with character value
+ PRIVATE :: att__init_dp ! initialize an attribute structure with array of real(8) value
+ PRIVATE :: att__init_dp_0d ! initialize an attribute structure with real(8) value
+ PRIVATE :: att__init_sp ! initialize an attribute structure with array of real(4) value
+ PRIVATE :: att__init_sp_0d ! initialize an attribute structure with real(4) value
+ PRIVATE :: att__init_i1 ! initialize an attribute structure with array of integer(1) value
+ PRIVATE :: att__init_i1_0d ! initialize an attribute structure with integer(1) value
+ PRIVATE :: att__init_i2 ! initialize an attribute structure with array of integer(2) value
+ PRIVATE :: att__init_i2_0d ! initialize an attribute structure with integer(2) value
+ PRIVATE :: att__init_i4 ! initialize an attribute structure with array of integer(4) value
+ PRIVATE :: att__init_i4_0d ! initialize an attribute structure with integer(4) value
+ PRIVATE :: att__init_i8 ! initialize an attribute structure with array of integer(8) value
+ PRIVATE :: att__init_i8_0d ! initialize an attribute structure with integer(8) value
+ PRIVATE :: att__copy_unit ! copy attribute structure
+ PRIVATE :: att__copy_arr ! copy array of attribute structure
+
+ TYPE TATT !< attribute structure
+ CHARACTER(LEN=lc) :: c_name = '' !< attribute name
+ INTEGER(i4) :: i_id = 0 !< attribute id
+ INTEGER(i4) :: i_type = 0 !< attribute type
INTEGER(i4) :: i_len = 0 !< number of value store in attribute
CHARACTER(LEN=lc) :: c_value = "none" !< attribute value if type CHAR
@@ -113,34 +150,47 @@
END INTERFACE att_init
- INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE att__copy_unit ! copy attribute structure
- MODULE PROCEDURE att__copy_tab ! copy attribute structure
+ INTERFACE att_print
+ MODULE PROCEDURE att__print_unit ! print information on one attribute
+ MODULE PROCEDURE att__print_arr ! print information on a array of attribute
+ END INTERFACE att_print
+
+ INTERFACE att_clean
+ MODULE PROCEDURE att__clean_unit
+ MODULE PROCEDURE att__clean_arr
END INTERFACE
+ INTERFACE att_copy
+ MODULE PROCEDURE att__copy_unit ! copy attribute structure
+ MODULE PROCEDURE att__copy_arr ! copy array of attribute structure
+ END INTERFACE
+
CONTAINS
!-------------------------------------------------------------------
!> @brief
- !> This function copy attribute structure in another attribute
- !> structure
+ !> This subroutine copy a array of attribute structure in another one
!> @details
- !> attribute value are copied in a temporary table, so input and output
- !> attribute structure value do not point on the same "memory cell", and so
- !> on are independant.
- !>
+ !> see att__copy_unit
+ !>
+ !> @warning do not use on the output of a function who create or read an
+ !> attribute (ex: tl_att=att_copy(att_init()) is forbidden).
+ !> This will create memory leaks.
!> @warning to avoid infinite loop, do not use any function inside
!> this subroutine
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[out] td_att1 : attribute structure
- !> @param[in] td_att2 : attribute structure
- !-------------------------------------------------------------------
- ! @code
- SUBROUTINE att__copy_tab( td_att1, td_att2 )
- IMPLICIT NONE
- ! Argument
- TYPE(TATT), DIMENSION(:) , INTENT(IN) :: td_att2
- TYPE(TATT), DIMENSION(SIZE(td_att2(:))),INTENT(OUT) :: td_att1
+ !> @date November, 2013 - Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator
+ !> (to avoid memory leak)
+ !
+ !> @param[in] td_att array of attribute structure
+ !> @return copy of input array of attribute structure
+ !-------------------------------------------------------------------
+ FUNCTION att__copy_arr( td_att )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TATT), DIMENSION(:), INTENT(IN) :: td_att
+ ! function
+ TYPE(TATT), DIMENSION(SIZE(td_att(:))) :: att__copy_arr
! local variable
@@ -149,34 +199,37 @@
!----------------------------------------------------------------
- DO ji=1,SIZE(td_att2(:))
- td_att1(ji)=td_att2(ji)
+ DO ji=1,SIZE(td_att(:))
+ att__copy_arr(ji)=att_copy(td_att(ji))
ENDDO
- END SUBROUTINE att__copy_tab
- ! @endcode
+ END FUNCTION att__copy_arr
!-------------------------------------------------------------------
!> @brief
- !> This function copy attribute structure in another attribute
- !> structure
+ !> This subroutine copy an attribute structure in another one.
!> @details
- !> attribute value are copied in a temporary table, so input and output
+ !> attribute value are copied in a temporary array, so input and output
!> attribute structure value do not point on the same "memory cell", and so
!> on are independant.
!>
+ !> @warning do not use on the output of a function who create or read an
+ !> attribute (ex: tl_att=att_copy(att_init()) is forbidden).
+ !> This will create memory leaks.
!> @warning to avoid infinite loop, do not use any function inside
!> this subroutine
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[out] td_att1 : attribute structure
- !> @param[in] td_att2 : attribute structure
- !-------------------------------------------------------------------
- ! @code
- SUBROUTINE att__copy_unit( td_att1, td_att2 )
- IMPLICIT NONE
- ! Argument
- TYPE(TATT), INTENT(OUT) :: td_att1
- TYPE(TATT), INTENT(IN) :: td_att2
+ !> @date November, 2013 - Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator (to avoid memory leak)
+ !>
+ !> @param[in] td_att attribute structure
+ !> @return copy of input attribute structure
+ !-------------------------------------------------------------------
+ FUNCTION att__copy_unit( td_att )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TATT), INTENT(IN) :: td_att
+ ! function
+ TYPE(TATT) :: att__copy_unit
! local variable
@@ -184,40 +237,38 @@
!----------------------------------------------------------------
- CALL logger_trace("COPY: attribute "//TRIM(td_att2%c_name) )
-
! copy attribute variable
- td_att1%c_name = TRIM(td_att2%c_name)
- td_att1%i_id = td_att2%i_id
- td_att1%i_type = td_att2%i_type
- td_att1%i_len = td_att2%i_len
- td_att1%c_value = TRIM(td_att2%c_value)
+ att__copy_unit%c_name = TRIM(td_att%c_name)
+ att__copy_unit%i_id = td_att%i_id
+ att__copy_unit%i_type = td_att%i_type
+ att__copy_unit%i_len = td_att%i_len
+ att__copy_unit%c_value = TRIM(td_att%c_value)
! copy attribute pointer in an independant variable
- IF( ASSOCIATED(td_att1%d_value) ) DEALLOCATE(td_att1%d_value)
- IF( ASSOCIATED(td_att2%d_value) )THEN
- ALLOCATE( dl_value(td_att2%i_len) )
- dl_value(:) = td_att2%d_value(:)
-
- ALLOCATE( td_att1%d_value(td_att1%i_len) )
- td_att1%d_value(:) = dl_value(:)
+ IF( ASSOCIATED(att__copy_unit%d_value) ) DEALLOCATE(att__copy_unit%d_value)
+ IF( ASSOCIATED(td_att%d_value) )THEN
+ ALLOCATE( dl_value(td_att%i_len) )
+ dl_value(:) = td_att%d_value(:)
+
+ ALLOCATE( att__copy_unit%d_value(att__copy_unit%i_len) )
+ att__copy_unit%d_value(:) = dl_value(:)
DEALLOCATE( dl_value )
ENDIF
- END SUBROUTINE att__copy_unit
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function get attribute id, in a table of attribute structure,
- !> given attribute name
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_att : attribute structure
- !> @param[in] cd_name : attribute name
- !> @return attribute id
- !-------------------------------------------------------------------
- ! @code
- INTEGER(i4) FUNCTION att_get_id( td_att, cd_name )
+ END FUNCTION att__copy_unit
+ !-------------------------------------------------------------------
+ !> @brief This function return attribute index, in a array of attribute structure,
+ !> given attribute name.
+ !> @details
+ !> if attribute name do not exist, return 0.
+ !>
+ !> @author J.Paul
+ !> @date Septempber, 2014 - Initial Version
+ !
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] cd_name attribute name
+ !> @return attribute index
+ !-------------------------------------------------------------------
+ INTEGER(i4) FUNCTION att_get_index( td_att, cd_name )
IMPLICIT NONE
! Argument
@@ -231,28 +282,62 @@
INTEGER(i4) :: ji
!----------------------------------------------------------------
- att_get_id=0
+ att_get_index=0
il_size=SIZE(td_att(:))
DO ji=1,il_size
IF( TRIM(td_att(ji)%c_name) == TRIM(cd_name) )THEN
- att_get_id=ji
+ att_get_index=ji
EXIT
ENDIF
ENDDO
+ END FUNCTION att_get_index
+ !-------------------------------------------------------------------
+ !> @brief This function return attribute id, read from a file.
+ !> @details
+ !> if attribute name do not exist, return 0.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !> @date September, 2014 - bug fix with use of id read from attribute structure
+ !
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] cd_name attribute name
+ !> @return attribute id
+ !-------------------------------------------------------------------
+ INTEGER(i4) FUNCTION att_get_id( td_att, cd_name )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TATT), DIMENSION(:), INTENT(IN) :: td_att
+ CHARACTER(LEN=*), INTENT(IN) :: cd_name
+
+ ! local variable
+ INTEGER(i4) :: il_size
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ att_get_id=0
+
+ il_size=SIZE(td_att(:))
+ DO ji=1,il_size
+ IF( TRIM(td_att(ji)%c_name) == TRIM(cd_name) )THEN
+ att_get_id=td_att(ji)%i_id
+ EXIT
+ ENDIF
+ ENDDO
+
END FUNCTION att_get_id
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with character
- !> value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] cd_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with character
+ !> value.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] cd_value attribute value
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
TYPE(TATT) FUNCTION att__init_c( cd_name, cd_value )
IMPLICIT NONE
@@ -265,5 +350,5 @@
CALL att_clean(att__init_c)
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attribute value "//TRIM(ADJUSTL(cd_value)) )
@@ -276,18 +361,19 @@
END FUNCTION att__init_c
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with table
- !> of real(8) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] dd_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with array
+ !> of real(8) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @dtae November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] dd_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_dp( cd_name, dd_value )
+ TYPE(TATT) FUNCTION att__init_dp( cd_name, dd_value, id_type )
IMPLICIT NONE
@@ -295,4 +381,5 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
! local value
@@ -307,5 +394,5 @@
CALL att_clean(att__init_dp)
- ! table size
+ ! array size
il_len=size(dd_value(:))
@@ -316,5 +403,5 @@
cl_value=TRIM(cl_value)//TRIM(fct_str(dd_value(il_len)))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attribute value "//TRIM(ADJUSTL(cl_value)) )
@@ -322,5 +409,9 @@
att__init_dp%c_name=TRIM(ADJUSTL(cd_name))
- att__init_dp%i_type=NF90_DOUBLE
+ IF( PRESENT(id_type) )THEN
+ att__init_dp%i_type=id_type
+ ELSE
+ att__init_dp%i_type=NF90_DOUBLE
+ ENDIF
IF( ASSOCIATED(att__init_dp%d_value) )THEN
@@ -333,22 +424,24 @@
END FUNCTION att__init_dp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with
!> real(8) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] dd_value: attribute value
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] dd_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_dp_0d( cd_name, dd_value )
+ TYPE(TATT) FUNCTION att__init_dp_0d( cd_name, dd_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
REAL(dp), INTENT(IN) :: dd_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
! local value
@@ -361,5 +454,5 @@
cl_value="(/"//TRIM(fct_str(dd_value))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attribute value "//TRIM(ADJUSTL(cl_value)) )
@@ -367,5 +460,9 @@
att__init_dp_0d%c_name=TRIM(ADJUSTL(cd_name))
- att__init_dp_0d%i_type=NF90_DOUBLE
+ IF( PRESENT(id_type) )THEN
+ att__init_dp_0d%i_type=id_type
+ ELSE
+ att__init_dp_0d%i_type=NF90_DOUBLE
+ ENDIF
IF( ASSOCIATED(att__init_dp_0d%d_value) )THEN
@@ -378,22 +475,24 @@
END FUNCTION att__init_dp_0d
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with table
- !> of real(4) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] rd_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with array
+ !> of real(4) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] rd_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_sp( cd_name, rd_value )
+ TYPE(TATT) FUNCTION att__init_sp( cd_name, rd_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
REAL(sp), DIMENSION(:), INTENT(IN) :: rd_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
! local value
@@ -408,5 +507,5 @@
CALL att_clean(att__init_sp)
- ! table size
+ ! array size
il_len=size(rd_value(:))
@@ -417,5 +516,5 @@
cl_value=TRIM(cl_value)//TRIM(fct_str(rd_value(il_len)))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attribute value "//TRIM(ADJUSTL(cl_value)) )
@@ -423,5 +522,9 @@
att__init_sp%c_name=TRIM(ADJUSTL(cd_name))
- att__init_sp%i_type=NF90_FLOAT
+ IF( PRESENT(id_type) )THEN
+ att__init_sp%i_type=id_type
+ ELSE
+ att__init_sp%i_type=NF90_FLOAT
+ ENDIF
IF( ASSOCIATED(att__init_sp%d_value) )THEN
@@ -434,22 +537,24 @@
END FUNCTION att__init_sp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with
- !> real(4) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] rd_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with
+ !> real(4) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] rd_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_sp_0d( cd_name, rd_value )
+ TYPE(TATT) FUNCTION att__init_sp_0d( cd_name, rd_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
REAL(sp), INTENT(IN) :: rd_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
! local value
@@ -462,5 +567,5 @@
cl_value="(/"//TRIM(fct_str(rd_value))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attribute value "//TRIM(ADJUSTL(cl_value)) )
@@ -468,5 +573,9 @@
att__init_sp_0d%c_name=TRIM(ADJUSTL(cd_name))
- att__init_sp_0d%i_type=NF90_FLOAT
+ IF( PRESENT(id_type) )THEN
+ att__init_sp_0d%i_type=id_type
+ ELSE
+ att__init_sp_0d%i_type=NF90_FLOAT
+ ENDIF
IF( ASSOCIATED(att__init_sp_0d%d_value) )THEN
@@ -479,22 +588,24 @@
END FUNCTION att__init_sp_0d
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with table
- !> of integer(1) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] bd_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with array
+ !> of integer(1) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] bd_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_i1( cd_name, bd_value )
+ TYPE(TATT) FUNCTION att__init_i1( cd_name, bd_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i1), DIMENSION(:), INTENT(IN) :: bd_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
! local value
@@ -509,5 +620,5 @@
CALL att_clean(att__init_i1)
- ! table size
+ ! array size
il_len=size(bd_value(:))
@@ -518,5 +629,5 @@
cl_value=TRIM(cl_value)//TRIM(fct_str(bd_value(il_len)))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attribute value "//TRIM(ADJUSTL(cl_value)) )
@@ -524,5 +635,9 @@
att__init_i1%c_name=TRIM(ADJUSTL(cd_name))
- att__init_i1%i_type=NF90_BYTE
+ IF( PRESENT(id_type) )THEN
+ att__init_i1%i_type=id_type
+ ELSE
+ att__init_i1%i_type=NF90_BYTE
+ ENDIF
IF( ASSOCIATED(att__init_i1%d_value) )THEN
@@ -535,22 +650,24 @@
END FUNCTION att__init_i1
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with
- !> integer(1) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] bd_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with
+ !> integer(1) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] bd_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_i1_0d( cd_name, bd_value )
+ TYPE(TATT) FUNCTION att__init_i1_0d( cd_name, bd_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i1), INTENT(IN) :: bd_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
!local value
@@ -563,5 +680,5 @@
cl_value="(/"//TRIM(fct_str(bd_value))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attibute value "//TRIM(ADJUSTL(cl_value)) )
@@ -569,5 +686,9 @@
att__init_i1_0d%c_name=TRIM(ADJUSTL(cd_name))
- att__init_i1_0d%i_type=NF90_BYTE
+ IF( PRESENT(id_type) )THEN
+ att__init_i1_0d%i_type=id_type
+ ELSE
+ att__init_i1_0d%i_type=NF90_BYTE
+ ENDIF
IF( ASSOCIATED(att__init_i1_0d%d_value) )THEN
@@ -580,22 +701,24 @@
END FUNCTION att__init_i1_0d
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with table
- !> of integer(2) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] sd_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with array
+ !> of integer(2) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] sd_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_i2( cd_name, sd_value )
+ TYPE(TATT) FUNCTION att__init_i2( cd_name, sd_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i2), DIMENSION(:), INTENT(IN) :: sd_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
! local value
@@ -610,5 +733,5 @@
CALL att_clean(att__init_i2)
- ! table size
+ ! array size
il_len=size(sd_value(:))
@@ -619,5 +742,5 @@
cl_value=TRIM(cl_value)//TRIM(fct_str(sd_value(il_len)))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attribute value "//TRIM(ADJUSTL(cl_value)) )
@@ -625,5 +748,9 @@
att__init_i2%c_name=TRIM(ADJUSTL(cd_name))
- att__init_i2%i_type=NF90_SHORT
+ IF( PRESENT(id_type) )THEN
+ att__init_i2%i_type=id_type
+ ELSE
+ att__init_i2%i_type=NF90_SHORT
+ ENDIF
IF( ASSOCIATED(att__init_i2%d_value) )THEN
@@ -636,22 +763,24 @@
END FUNCTION att__init_i2
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with
- !> integer(2) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] sd_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with
+ !> integer(2) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] sd_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_i2_0d( cd_name, sd_value )
+ TYPE(TATT) FUNCTION att__init_i2_0d( cd_name, sd_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i2), INTENT(IN) :: sd_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
!local value
@@ -664,5 +793,5 @@
cl_value="(/"//TRIM(fct_str(sd_value))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attibute value "//TRIM(ADJUSTL(cl_value)) )
@@ -670,5 +799,9 @@
att__init_i2_0d%c_name=TRIM(ADJUSTL(cd_name))
- att__init_i2_0d%i_type=NF90_SHORT
+ IF( PRESENT(id_type) )THEN
+ att__init_i2_0d%i_type=id_type
+ ELSE
+ att__init_i2_0d%i_type=NF90_SHORT
+ ENDIF
IF( ASSOCIATED(att__init_i2_0d%d_value) )THEN
@@ -681,22 +814,24 @@
END FUNCTION att__init_i2_0d
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with table
- !> of integer(4) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] id_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with array
+ !> of integer(4) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] id_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_i4( cd_name, id_value )
+ TYPE(TATT) FUNCTION att__init_i4( cd_name, id_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
! local value
@@ -711,5 +846,5 @@
CALL att_clean(att__init_i4)
- ! table size
+ ! array size
il_len=size(id_value(:))
@@ -720,5 +855,5 @@
cl_value=TRIM(cl_value)//TRIM(fct_str(id_value(il_len)))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attribute value "//TRIM(ADJUSTL(cl_value)) )
@@ -726,5 +861,9 @@
att__init_i4%c_name=TRIM(ADJUSTL(cd_name))
- att__init_i4%i_type=NF90_INT
+ IF( PRESENT(id_type) )THEN
+ att__init_i4%i_type=id_type
+ ELSE
+ att__init_i4%i_type=NF90_INT
+ ENDIF
IF( ASSOCIATED(att__init_i4%d_value) )THEN
@@ -737,22 +876,24 @@
END FUNCTION att__init_i4
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with
- !> integer(4) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] id_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with
+ !> integer(4) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !>
+ !> @param[in] cd_name attribute name
+ !> @param[in] id_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_i4_0d( cd_name, id_value )
+ TYPE(TATT) FUNCTION att__init_i4_0d( cd_name, id_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i4), INTENT(IN) :: id_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
!local value
@@ -765,5 +906,5 @@
cl_value="(/"//TRIM(fct_str(id_value))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attibute value "//TRIM(ADJUSTL(cl_value)) )
@@ -771,5 +912,9 @@
att__init_i4_0d%c_name=TRIM(ADJUSTL(cd_name))
- att__init_i4_0d%i_type=NF90_INT
+ IF( PRESENT(id_type) )THEN
+ att__init_i4_0d%i_type=id_type
+ ELSE
+ att__init_i4_0d%i_type=NF90_INT
+ ENDIF
IF( ASSOCIATED(att__init_i4_0d%d_value) )THEN
@@ -782,22 +927,24 @@
END FUNCTION att__init_i4_0d
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with table
- !> of integer(8) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] kd_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with array
+ !> of integer(8) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] kd_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_i8( cd_name, kd_value )
+ TYPE(TATT) FUNCTION att__init_i8( cd_name, kd_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i8), DIMENSION(:), INTENT(IN) :: kd_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
! local value
@@ -812,5 +959,5 @@
CALL att_clean(att__init_i8)
- ! table size
+ ! array size
il_len=size(kd_value(:))
@@ -821,5 +968,5 @@
cl_value=TRIM(cl_value)//TRIM(fct_str(kd_value(il_len)))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attibute value "//TRIM(ADJUSTL(cl_value)) )
@@ -827,5 +974,9 @@
att__init_i8%c_name=TRIM(ADJUSTL(cd_name))
- att__init_i8%i_type=NF90_INT
+ IF( PRESENT(id_type) )THEN
+ att__init_i8%i_type=id_type
+ ELSE
+ att__init_i8%i_type=NF90_INT
+ ENDIF
IF( ASSOCIATED(att__init_i8%d_value) )THEN
@@ -838,22 +989,24 @@
END FUNCTION att__init_i8
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise an attribute structure with
- !> integer(8) value
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : attribute name
- !> @param[in] kd_value: attribute value
+ !-------------------------------------------------------------------
+ !> @brief This function initialize an attribute structure with
+ !> integer(8) value.
+ !> @details
+ !> Optionaly you could specify the type of the variable to be saved.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name attribute name
+ !> @param[in] kd_value attribute value
+ !> @param[in] id_type type of the variable to be saved
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION att__init_i8_0d( cd_name, kd_value )
+ TYPE(TATT) FUNCTION att__init_i8_0d( cd_name, kd_value, id_type )
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i8), INTENT(IN) :: kd_value
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
! local value
@@ -866,5 +1019,5 @@
cl_value="(/"//TRIM(fct_str(kd_value))//"/)"
- CALL logger_info( &
+ CALL logger_trace( &
& " ATT INIT: attribute name: "//TRIM(ADJUSTL(cd_name))//&
& " attibute value "//TRIM(ADJUSTL(cl_value)) )
@@ -872,5 +1025,9 @@
att__init_i8_0d%c_name=TRIM(ADJUSTL(cd_name))
- att__init_i8_0d%i_type=NF90_INT
+ IF( PRESENT(id_type) )THEN
+ att__init_i8_0d%i_type=id_type
+ ELSE
+ att__init_i8_0d%i_type=NF90_INT
+ ENDIF
IF( ASSOCIATED(att__init_i8_0d%d_value) )THEN
@@ -883,15 +1040,37 @@
END FUNCTION att__init_i8_0d
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine print attribute information
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_att : attribute structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE att_print(td_att)
+ !-------------------------------------------------------------------
+ !> @brief This subroutine print informations of an array of attribute.
+ !>
+ !> @author J.Paul
+ !> @date June, 2014 - Initial Version
+ !>
+ !> @param[in] td_att array of attribute structure
+ !-------------------------------------------------------------------
+ SUBROUTINE att__print_arr(td_att)
+ IMPLICIT NONE
+
+ ! Argument
+ TYPE(TATT), DIMENSION(:), INTENT(IN) :: td_att
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ DO ji=1,SIZE(td_att(:))
+ CALL att_print(td_att(ji))
+ ENDDO
+
+ END SUBROUTINE att__print_arr
+ !-------------------------------------------------------------------
+ !> @brief This subroutine print attribute information.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !> @date September, 2014 - take into account type of attribute.
+ !
+ !> @param[in] td_att attribute structure
+ !-------------------------------------------------------------------
+ SUBROUTINE att__print_unit(td_att)
IMPLICIT NONE
@@ -902,5 +1081,10 @@
CHARACTER(LEN=lc) :: cl_type
CHARACTER(LEN=lc) :: cl_value
- CHARACTER(LEN=lc) :: cl_tmp
+
+ INTEGER(i8) :: kl_tmp
+ INTEGER(i2) :: sl_tmp
+ INTEGER(i1) :: bl_tmp
+ REAL(sp) :: rl_tmp
+ REAL(dp) :: dl_tmp
! loop indices
@@ -924,5 +1108,5 @@
CASE DEFAULT
cl_type=''
- !cl_type='unknown'
+
END SELECT
@@ -932,21 +1116,69 @@
cl_value=td_att%c_value
- CASE(NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE)
+ CASE(NF90_BYTE)
IF( td_att%i_len > 1 )THEN
-
- cl_tmp=','
cl_value='(/'
DO ji=1,td_att%i_len-1
- cl_value=TRIM(cl_value)//&
- & TRIM(fct_str(td_att%d_value(ji)))//TRIM(cl_tmp)
+ bl_tmp=INT(td_att%d_value(ji),i1)
+ cl_value=TRIM(cl_value)//TRIM(fct_str(bl_tmp))//','
ENDDO
- cl_value=TRIM(cl_value)//&
- & TRIM(fct_str(td_att%d_value(td_att%i_len)))//'/)'
-
+ bl_tmp=INT(td_att%d_value(td_att%i_len),i1)
+ cl_value=TRIM(cl_value)//TRIM(fct_str(bl_tmp))//'/)'
ELSE
-
cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)'
-
ENDIF
+
+ CASE(NF90_SHORT)
+ IF( td_att%i_len > 1 )THEN
+ cl_value='(/'
+ DO ji=1,td_att%i_len-1
+ sl_tmp=INT(td_att%d_value(ji),i2)
+ cl_value=TRIM(cl_value)//TRIM(fct_str(sl_tmp))//','
+ ENDDO
+ sl_tmp=INT(td_att%d_value(td_att%i_len),i2)
+ cl_value=TRIM(cl_value)//TRIM(fct_str(sl_tmp))//'/)'
+ ELSE
+ cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)'
+ ENDIF
+
+ CASE(NF90_INT)
+ IF( td_att%i_len > 1 )THEN
+ cl_value='(/'
+ DO ji=1,td_att%i_len-1
+ kl_tmp=INT(td_att%d_value(ji),i8)
+ cl_value=TRIM(cl_value)//TRIM(fct_str(kl_tmp))//','
+ ENDDO
+ kl_tmp=INT(td_att%d_value(td_att%i_len),i8)
+ cl_value=TRIM(cl_value)//TRIM(fct_str(kl_tmp))//'/)'
+ ELSE
+ cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)'
+ ENDIF
+
+ CASE(NF90_FLOAT)
+ IF( td_att%i_len > 1 )THEN
+ cl_value='(/'
+ DO ji=1,td_att%i_len-1
+ rl_tmp=REAL(td_att%d_value(ji),sp)
+ cl_value=TRIM(cl_value)//TRIM(fct_str(rl_tmp))//','
+ ENDDO
+ rl_tmp=REAL(td_att%d_value(td_att%i_len),sp)
+ cl_value=TRIM(cl_value)//TRIM(fct_str(rl_tmp))//'/)'
+ ELSE
+ cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)'
+ ENDIF
+
+ CASE(NF90_DOUBLE)
+ IF( td_att%i_len > 1 )THEN
+ cl_value='(/'
+ DO ji=1,td_att%i_len-1
+ dl_tmp=REAL(td_att%d_value(ji),dp)
+ cl_value=TRIM(cl_value)//TRIM(fct_str(dl_tmp))//','
+ ENDDO
+ dl_tmp=REAL(td_att%d_value(td_att%i_len),dp)
+ cl_value=TRIM(cl_value)//TRIM(fct_str(dl_tmp))//'/)'
+ ELSE
+ cl_value='(/'//TRIM(fct_str(td_att%d_value(1)))//'/)'
+ ENDIF
+
CASE DEFAULT
cl_value="none"
@@ -960,6 +1192,5 @@
& " value : ",TRIM(ADJUSTL(cl_value))
- END SUBROUTINE att_print
- !> @endcode
+ END SUBROUTINE att__print_unit
!-------------------------------------------------------------------
!> @brief
@@ -967,10 +1198,9 @@
!
!> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_att : attribute strcuture
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE att_clean( td_att )
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_att attribute strcuture
+ !-------------------------------------------------------------------
+ SUBROUTINE att__clean_unit( td_att )
IMPLICIT NONE
! Argument
@@ -981,5 +1211,5 @@
!----------------------------------------------------------------
- CALL logger_info( &
+ CALL logger_trace( &
& " CLEAN: reset attribute "//TRIM(td_att%c_name) )
@@ -990,8 +1220,31 @@
! replace by empty structure
- td_att=tl_att
-
- END SUBROUTINE att_clean
- !> @endcode
+ td_att=att_copy(tl_att)
+
+ END SUBROUTINE att__clean_unit
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine clean array of attribute strcuture.
+ !
+ !> @author J.Paul
+ !> @date September, 2014 - Initial Version
+ !
+ !> @param[inout] td_att attribute strcuture
+ !-------------------------------------------------------------------
+ SUBROUTINE att__clean_arr( td_att )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TATT), DIMENSION(:), INTENT(INOUT) :: td_att
+
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ DO ji=SIZE(td_att(:)),1,-1
+ CALL att_clean(td_att(ji) )
+ ENDDO
+
+ END SUBROUTINE att__clean_arr
END MODULE att
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/boundary.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/boundary.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/boundary.f90 (revision 5214)
@@ -8,17 +8,105 @@
!> @brief
!> This module manage boundary.
-!
+!>
!> @details
+!> define type TBDY:
+!> @code
+!> TYPE(TBDY) :: tl_bdy
+!> @endcode
!>
+!> to initialise boundary structure:
+!> @code
+!> tl_bdy=boundary_init(td_var, [ld_north,] [ld_south,] [ld_east,] [ld_west,]
+!> [cd_north,] [cd_south,] [cd_east,] [cd_west,] [ld_oneseg])
+!> @endcode
+!> - td_var is variable structure
+!> - ld_north is logical to force used of north boundary [optional]
+!> - ld_south is logical to force used of north boundary [optional]
+!> - ld_east is logical to force used of north boundary [optional]
+!> - ld_west is logical to force used of north boundary [optional]
+!> - cd_north is string character description of north boundary [optional]
+!> - cd_south is string character description of north boundary [optional]
+!> - cd_east is string character description of north boundary [optional]
+!> - cd_west is string character description of north boundary [optional]
+!> - ld_oneseg is logical to force to use only one segment for each boundary [optional]
!>
+!> to get boundary cardinal:
+!> - tl_bdy\%c_card
!>
+!> to know if boundary is use:
+!> - tl_bdy\%l_use
!>
+!> to get the number of segment in boundary:
+!> - tl_bdy\%i_nseg
!>
-!> @author
-!> J.Paul
+!> to get array of segment in boundary:
+!> - tl_bdy\%t_seg(:)
+!>
+!> to get orthogonal segment index of north boundary:
+!> - tl_bdy\%t_seg(jp_north)%\i_index
+!>
+!> to get segment width of south boundary:
+!> - tl_bdy\%t_seg(jp_south)%\i_width
+!>
+!> to get segment first indice of east boundary:
+!> - tl_bdy\%t_seg(jp_east)%\i_first
+!>
+!> to get segment last indice of west boundary:
+!> - tl_bdy\%t_seg(jp_west)%\i_last
+!>
+!> to print information about boundary:
+!> @code
+!> CALL boundary_print(td_bdy)
+!> @endcode
+!> - td_bdy is boundary structure or a array of boundary structure
+!>
+!> to clean boundary structure:
+!> @code
+!> CALL boundary_clean(td_bdy)
+!> @endcode
+!>
+!> to get indices of each semgent for each boundary:
+!> @code
+!> CALL boundary_get_indices( td_bdy, td_var, ld_oneseg)
+!> @endcode
+!> - td_bdy is boundary structure
+!> - td_var is variable structure
+!> - ld_oneseg is logical to force to use only one segment for each boundary [optional]
+!>
+!> to check boundary indices and corner:
+!> @code
+!> CALL boundary_check(td_bdy, td_var)
+!> @endcode
+!> - td_bdy is boundary structure
+!> - td_var is variable structure
+!>
+!> to check boundary corner:
+!> @code
+!> CALL boundary_check_corner(td_bdy, td_var)
+!> @endcode
+!> - td_bdy is boundary structure
+!> - td_var is variable structure
+!>
+!> to create filename with cardinal name inside:
+!> @code
+!> cl_filename=boundary_set_filename(cd_file, cd_card)
+!> @endcode
+!> - cd_file = original file name
+!> - cd_card = cardinal name
+!>
+!> to swap array for east and north boundary:
+!> @code
+!> CALL boundary_swap( td_var, td_bdy )
+!> @endcode
+!> - td_var is variable strucutre
+!> - td_bdy is boundary strucutre
+!>
+!> @author J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!> @todo
-!> - add description generique de l'objet boundary
+!> @date November, 2013 - Initial Version
+!> @date September, 2014 - add boundary description
+!> @date November, 2014 - Fix memory leaks bug
+!>
+!> @todo add schematic to boundary structure description
!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
@@ -29,31 +117,19 @@
USE phycst ! physical constant
USE kind ! F90 kind parameter
- USE logger ! log file manager
+ USE logger ! log file manager
USE fct ! basic useful function
-! USE date ! date manager
-! USE att ! attribute manager
-! USE dim ! dimension manager
USE var ! variable manager
-! USE file ! file manager
-! USE iom ! I/O manager
-! USE dom ! domain manager
-! USE grid ! grid manager
-! USE extrap ! extrapolation manager
-! USE interp ! interpolation manager
-! USE filter ! filter manager
-! USE mpp ! MPP manager
-! USE iom_mpp ! MPP I/O manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! type and variable
- PUBLIC :: ip_ncard !< number of cardinal point
- PUBLIC :: ip_card !< table of cardinal point
PUBLIC :: TBDY !< boundary structure
PUBLIC :: TSEG !< segment structure
+ PRIVATE :: im_width !< boundary width
+
! function and subroutine
+ PUBLIC :: boundary_copy !< copy boundary structure
PUBLIC :: boundary_init !< initialise boundary structure
PUBLIC :: boundary_print !< print information about boundary
@@ -63,26 +139,29 @@
PUBLIC :: boundary_check_corner !< check boundary corner
PUBLIC :: boundary_set_filename !< set boundary filename
- PUBLIC :: boundary_clean_interp !< clean interpolated boundary
PUBLIC :: boundary_swap !< swap array for north and east boundary
- PRIVATE :: boundary__init_wrapper !< initialise a boundary structure
- PRIVATE :: boundary__init !< initialise basically a boundary structure
-! PRIVATE :: boundary__copy !< copy boundary structure in another
- PRIVATE :: boundary__copy_unit !< copy boundary structure in another
- PRIVATE :: boundary__copy_tab !< copy boundary structure in another
- PRIVATE :: boundary__add_seg !< add one segment structure to a boundary
- PRIVATE :: boundary__del_seg !< remove all segments of a boundary
- PRIVATE :: boundary__get_info !< get boundary information from boundary description string character.
- PRIVATE :: boundary__get_seg_number !< compute the number of sea segment for one boundary
- PRIVATE :: boundary__get_seg_indices !< get segment indices for one boundary
- PRIVATE :: boundary__print_unit !< print information about one boundary
- PRIVATE :: boundary__print_tab !< print information about a table of boundary
+ PRIVATE :: boundary__clean_unit ! clean boundary structure
+ PRIVATE :: boundary__clean_arr ! clean array of boundary structure
+ PRIVATE :: boundary__init_wrapper ! initialise a boundary structure
+ PRIVATE :: boundary__init ! initialise basically a boundary structure
+ PRIVATE :: boundary__copy_unit ! copy boundary structure in another
+ PRIVATE :: boundary__copy_arr ! copy boundary structure in another
+ PRIVATE :: boundary__add_seg ! add one segment structure to a boundary
+ PRIVATE :: boundary__del_seg ! remove all segments of a boundary
+ PRIVATE :: boundary__get_info ! get boundary information from boundary description string character.
+ PRIVATE :: boundary__get_seg_number ! compute the number of sea segment for one boundary
+ PRIVATE :: boundary__get_seg_indices ! get segment indices for one boundary
+ PRIVATE :: boundary__print_unit ! print information about one boundary
+ PRIVATE :: boundary__print_arr ! print information about a array of boundary
- PRIVATE :: seg__init !< initialise segment structure
- PRIVATE :: seg__clean !< clean segment structure
- PRIVATE :: seg__copy !< copy segment structure in another
-
- !> @struct
- TYPE TSEG
+ PRIVATE :: seg__init ! initialise segment structure
+ PRIVATE :: seg__clean ! clean segment structure
+ PRIVATE :: seg__clean_unit ! clean segment structure
+ PRIVATE :: seg__clean_arr ! clean array of segment structure
+ PRIVATE :: seg__copy ! copy segment structure in another
+ PRIVATE :: seg__copy_unit ! copy segment structure in another
+ PRIVATE :: seg__copy_arr ! copy array of segment structure in another
+
+ TYPE TSEG !< segment structure
INTEGER(i4) :: i_index = 0 !< segment index
INTEGER(i4) :: i_width = 0 !< segment width
@@ -91,23 +170,10 @@
END TYPE TSEG
- !> @struct
- TYPE TBDY
- CHARACTER(LEN=lc) :: c_card = ''
- LOGICAL :: l_use = .FALSE.
- INTEGER(i4) :: i_nseg = 0
- TYPE(TSEG), DIMENSION(:), POINTER :: t_seg => NULL()
+ TYPE TBDY !< boundary structure
+ CHARACTER(LEN=lc) :: c_card = '' !< boundary cardinal
+ LOGICAL :: l_use = .FALSE. !< boundary use or not
+ INTEGER(i4) :: i_nseg = 0 !< number of segment in boundary
+ TYPE(TSEG), DIMENSION(:), POINTER :: t_seg => NULL() !< array of segment structure
END TYPE TBDY
-
- INTEGER(i4), PARAMETER :: ip_ncard=4
- CHARACTER(LEN=lc), DIMENSION(ip_ncard), PARAMETER :: ip_card = &
- & (/ 'north', &
- & 'south', &
- & 'east ', &
- & 'west ' /)
-
- INTEGER(i4), PARAMETER :: jp_north=1
- INTEGER(i4), PARAMETER :: jp_south=2
- INTEGER(i4), PARAMETER :: jp_east =3
- INTEGER(i4), PARAMETER :: jp_west =4
INTEGER(i4), PARAMETER :: im_width=10
@@ -119,11 +185,25 @@
INTERFACE boundary_print
MODULE PROCEDURE boundary__print_unit
- MODULE PROCEDURE boundary__print_tab
+ MODULE PROCEDURE boundary__print_arr
END INTERFACE boundary_print
- INTERFACE ASSIGNMENT(=)
+ INTERFACE boundary_clean
+ MODULE PROCEDURE boundary__clean_unit
+ MODULE PROCEDURE boundary__clean_arr
+ END INTERFACE
+
+ INTERFACE seg__clean
+ MODULE PROCEDURE seg__clean_unit
+ MODULE PROCEDURE seg__clean_arr
+ END INTERFACE
+
+ INTERFACE boundary_copy
MODULE PROCEDURE boundary__copy_unit
- MODULE PROCEDURE boundary__copy_tab
- MODULE PROCEDURE seg__copy ! copy segment structure
+ MODULE PROCEDURE boundary__copy_arr
+ END INTERFACE
+
+ INTERFACE seg__copy
+ MODULE PROCEDURE seg__copy_unit ! copy segment structure
+ MODULE PROCEDURE seg__copy_arr ! copy array of segment structure
END INTERFACE
@@ -131,23 +211,28 @@
!-------------------------------------------------------------------
!> @brief
- !> This subroutine copy boundary structure in another boundary
- !> structure
+ !> This subroutine copy a array of boundary structure in another one
!> @details
!>
+ !> @warning do not use on the output of a function who create or read an
+ !> attribute (ex: tl_bdy=boundary_copy(boundary_init()) is forbidden).
+ !> This will create memory leaks.
!> @warning to avoid infinite loop, do not use any function inside
!> this subroutine
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> @date November, 2013 - Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator
+ !> (to avoid memory leak)
!
- !> @param[out] td_bdy1 : boundary structure
- !> @param[in] td_bdy2 : boundary structure
+ !> @param[in] td_bdy array of boundary structure
+ !> @return copy of input array of boundary structure
!-------------------------------------------------------------------
- !> @code
- SUBROUTINE boundary__copy_tab( td_bdy1, td_bdy2 )
+ FUNCTION boundary__copy_arr( td_bdy )
IMPLICIT NONE
! Argument
- TYPE(TBDY), DIMENSION(:), INTENT(OUT) :: td_bdy1
- TYPE(TBDY), DIMENSION(:), INTENT(IN) :: td_bdy2
+ TYPE(TBDY), DIMENSION(:), INTENT(IN) :: td_bdy
+ ! function
+ TYPE(TBDY), DIMENSION(SIZE(td_bdy(:))) :: boundary__copy_arr
! local variable
@@ -156,34 +241,35 @@
!----------------------------------------------------------------
- IF( SIZE(td_bdy1(:)) /= SIZE(td_bdy2(:)) )THEN
- CALL logger_error("BOUNDARY COPY: dimension of table of boundary differ")
- ELSE
- DO jk=1,SIZE(td_bdy1(:))
- td_bdy1(jk)=td_bdy2(jk)
- ENDDO
- ENDIF
- END SUBROUTINE boundary__copy_tab
- !> @endcode
+ DO jk=1,SIZE(td_bdy(:))
+ boundary__copy_arr(jk)=boundary_copy(td_bdy(jk))
+ ENDDO
+
+ END FUNCTION boundary__copy_arr
!-------------------------------------------------------------------
!> @brief
- !> This subroutine copy boundary structure in another boundary
- !> structure
+ !> This subroutine copy boundary structure in another one
!> @details
!>
+ !> @warning do not use on the output of a function who create or read an
+ !> attribute (ex: tl_bdy=boundary_copy(boundary_init()) is forbidden).
+ !> This will create memory leaks.
!> @warning to avoid infinite loop, do not use any function inside
!> this subroutine
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> @date November, 2013 - Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator
+ !> (to avoid memory leak)
!
- !> @param[out] td_bdy1 : boundary structure
- !> @param[in] td_bdy2 : boundary structure
+ !> @param[in] td_bdy boundary structure
+ !> @return copy of input boundary structure
!-------------------------------------------------------------------
- !> @code
- SUBROUTINE boundary__copy_unit( td_bdy1, td_bdy2 )
+ FUNCTION boundary__copy_unit( td_bdy )
IMPLICIT NONE
! Argument
- TYPE(TBDY), INTENT(OUT) :: td_bdy1
- TYPE(TBDY), INTENT(IN) :: td_bdy2
+ TYPE(TBDY), INTENT(IN) :: td_bdy
+ ! function
+ TYPE(TBDY) :: boundary__copy_unit
! local variable
@@ -193,29 +279,30 @@
! copy variable name, id, ..
- td_bdy1%c_card = TRIM(td_bdy2%c_card)
- td_bdy1%i_nseg = td_bdy2%i_nseg
- td_bdy1%l_use = td_bdy2%l_use
+ boundary__copy_unit%c_card = TRIM(td_bdy%c_card)
+ boundary__copy_unit%i_nseg = td_bdy%i_nseg
+ boundary__copy_unit%l_use = td_bdy%l_use
! copy segment
- IF( ASSOCIATED(td_bdy1%t_seg) ) DEALLOCATE(td_bdy1%t_seg)
- IF( ASSOCIATED(td_bdy2%t_seg) .AND. td_bdy1%i_nseg > 0 )THEN
- ALLOCATE( td_bdy1%t_seg(td_bdy1%i_nseg) )
- DO ji=1,td_bdy1%i_nseg
- td_bdy1%t_seg(ji)=td_bdy2%t_seg(ji)
+ IF( ASSOCIATED(boundary__copy_unit%t_seg) )THEN
+ CALL seg__clean(boundary__copy_unit%t_seg(:))
+ DEALLOCATE(boundary__copy_unit%t_seg)
+ ENDIF
+ IF( ASSOCIATED(td_bdy%t_seg) .AND. boundary__copy_unit%i_nseg > 0 )THEN
+ ALLOCATE( boundary__copy_unit%t_seg(boundary__copy_unit%i_nseg) )
+ DO ji=1,boundary__copy_unit%i_nseg
+ boundary__copy_unit%t_seg(ji)=td_bdy%t_seg(ji)
ENDDO
ENDIF
- END SUBROUTINE boundary__copy_unit
- !> @endcode
+ END FUNCTION boundary__copy_unit
!-------------------------------------------------------------------
!> @brief This subroutine clean boundary structure
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> @date November, 2013 - Initial Version
!
- !> @param[inout] td_bdy : boundary strucutre
+ !> @param[inout] td_bdy boundary strucutre
!-------------------------------------------------------------------
- !> @code
- SUBROUTINE boundary_clean( td_bdy )
+ SUBROUTINE boundary__clean_unit( td_bdy )
IMPLICIT NONE
! Argument
@@ -226,42 +313,64 @@
! loop indices
+ !----------------------------------------------------------------
+
+ CALL logger_info( &
+ & " CLEAN: reset boundary "//TRIM(td_bdy%c_card) )
+
+ ! del segment
+ IF( ASSOCIATED(td_bdy%t_seg) )THEN
+ ! clean each segment
+ CALL seg__clean(td_bdy%t_seg(:) )
+ DEALLOCATE( td_bdy%t_seg )
+ ENDIF
+
+ ! replace by empty structure
+ td_bdy=boundary_copy(tl_bdy)
+
+ END SUBROUTINE boundary__clean_unit
+ !-------------------------------------------------------------------
+ !> @brief This subroutine clean array of boundary structure
+ !
+ !> @author J.Paul
+ !> @date September, 2014 - Initial Version
+ !
+ !> @param[inout] td_bdy boundary strucutre
+ !-------------------------------------------------------------------
+ SUBROUTINE boundary__clean_arr( td_bdy )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TBDY), DIMENSION(:), INTENT(INOUT) :: td_bdy
+
+ ! local variable
+ ! loop indices
INTEGER(i4) :: ji
!----------------------------------------------------------------
- CALL logger_info( &
- & " CLEAN: reset boundary "//TRIM(td_bdy%c_card) )
-
- ! del segment
- IF( ASSOCIATED(td_bdy%t_seg) )THEN
- ! clean each attribute
- DO ji=td_bdy%i_nseg,1,-1
- CALL seg__clean(td_bdy%t_seg(ji) )
- ENDDO
- DEALLOCATE( td_bdy%t_seg )
- ENDIF
-
- ! replace by empty structure
- td_bdy=tl_bdy
-
- END SUBROUTINE boundary_clean
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function put cardinal name inside file name
+ DO ji=SIZE(td_bdy(:)),1,-1
+ CALL boundary_clean( td_bdy(ji) )
+ ENDDO
+
+ END SUBROUTINE boundary__clean_arr
+ !-------------------------------------------------------------------
+ !> @brief This function put cardinal name inside file name.
!
!> @details
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_file : file name
- !> @param[in] cd_card : cardinal name
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_file file name
+ !> @param[in] cd_card cardinal name
+ !> @param[in] id_seg segment number
+ !> @param[in] cd_date file date (format: y????m??d??)
!> @return file name with cardinal name inside
!-------------------------------------------------------------------
- !> @code
- FUNCTION boundary_set_filename(cd_file, cd_card)
+ FUNCTION boundary_set_filename(cd_file, cd_card, id_seg, cd_date)
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_file
CHARACTER(LEN=*), INTENT(IN) :: cd_card
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_seg
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_date
! function
@@ -273,4 +382,6 @@
CHARACTER(LEN=lc) :: cl_base
CHARACTER(LEN=lc) :: cl_suffix
+ CHARACTER(LEN=lc) :: cl_segnum
+ CHARACTER(LEN=lc) :: cl_date
CHARACTER(LEN=lc) :: cl_name
! loop indices
@@ -288,6 +399,19 @@
cl_base =fct_split(TRIM(cl_basename),1,'.')
cl_suffix=fct_split(TRIM(cl_basename),2,'.')
-
- cl_name=TRIM(cl_base)//"_"//TRIM(cd_card)//"."//TRIM(cl_suffix)
+
+ IF( PRESENT(id_seg) )THEN
+ cl_segnum="_"//TRIM(fct_str(id_seg))//"_"
+ ELSE
+ cl_segnum=""
+ ENDIF
+
+ IF( PRESENT(cd_date) )THEN
+ cl_date=TRIM(ADJUSTL(cd_date))
+ ELSE
+ cl_date=""
+ ENDIF
+
+ cl_name=TRIM(cl_base)//"_"//TRIM(cd_card)//TRIM(cl_segnum)//&
+ & TRIM(cl_date)//"."//TRIM(cl_suffix)
boundary_set_filename=TRIM(cl_dirname)//"/"//TRIM(cl_name)
@@ -298,7 +422,6 @@
END FUNCTION boundary_set_filename
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise a boundary structure
+ !-------------------------------------------------------------------
+ !> @brief This function initialise a boundary structure.
!
!> @details
@@ -318,21 +441,26 @@
!> specify it for each segment.
!> ex : cn_north='index1,first1,last1(width)|index2,first2,last2'
- !
+ !>
+ !> @note boundaries are compute on T point. change will be done to get data
+ !> on other point when need be.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : variable structure
- !> @param[in] ld_north : use north boundary or not
- !> @param[in] ld_south : use south boundary or not
- !> @param[in] ld_east : use east boundary or not
- !> @param[in] ld_west : use west boundary or not
- !> @param[in] cd_north : north boundary description
- !> @param[in] cd_south : south boundary description
- !> @param[in] cd_east : east boundary description
- !> @param[in] cd_west : west boundary description
+ !> @date November, 2013 - Initial Version
+ !> @date September, 2014
+ !> - add boolean to use only one segment for each boundary
+ !> - check boundary width
+ !
+ !> @param[in] td_var variable structure
+ !> @param[in] ld_north use north boundary or not
+ !> @param[in] ld_south use south boundary or not
+ !> @param[in] ld_east use east boundary or not
+ !> @param[in] ld_west use west boundary or not
+ !> @param[in] cd_north north boundary description
+ !> @param[in] cd_south south boundary description
+ !> @param[in] cd_east east boundary description
+ !> @param[in] cd_west west boundary description
+ !> @param[in] ld_oneseg force to use only one segment for each boundary
!> @return boundary structure
- !> @todo use bondary_get_indices !!!!
- !-------------------------------------------------------------------
- !> @code
+ !-------------------------------------------------------------------
FUNCTION boundary__init_wrapper(td_var, &
& ld_north, ld_south, ld_east, ld_west, &
@@ -356,4 +484,6 @@
! local variable
+ INTEGER(i4) :: il_width
+ INTEGER(i4) , DIMENSION(ip_ncard) :: il_max_width
INTEGER(i4) , DIMENSION(ip_ncard) :: il_index
INTEGER(i4) , DIMENSION(ip_ncard) :: il_min
@@ -390,16 +520,20 @@
tl_bdy(jp_west )=boundary__init('west ',ld_west )
- ! if EW cyclic no east west boundary
+ ! if EW cyclic no east west boundary and force to use one segment
IF( td_var%i_ew >= 0 )THEN
- CALL logger_debug("BOUNDARY INIT: cyclic no East West boundary")
+ CALL logger_info("BOUNDARY INIT: cyclic domain, "//&
+ & "no East West boundary")
tl_bdy(jp_east )%l_use=.FALSE.
tl_bdy(jp_west )%l_use=.FALSE.
+
+ CALL logger_info("BOUNDARY INIT: force to use one segment due"//&
+ & " to EW cyclic domain")
+ ll_oneseg=.TRUE.
ENDIF
- ! attention cas U /= T ???
- il_index(jp_north)=td_var%t_dim(2)%i_len-ig_ghost
- il_index(jp_south)=1+ig_ghost
- il_index(jp_east )=td_var%t_dim(1)%i_len-ig_ghost
- il_index(jp_west )=1+ig_ghost
+ il_index(jp_north)=td_var%t_dim(2)%i_len-ip_ghost
+ il_index(jp_south)=1+ip_ghost
+ il_index(jp_east )=td_var%t_dim(1)%i_len-ip_ghost
+ il_index(jp_west )=1+ip_ghost
il_min(jp_north)=1
@@ -419,8 +553,28 @@
IF( PRESENT(cd_west ) ) cl_card(jp_west )=TRIM(cd_west )
+ il_max_width(jp_north)=INT(0.5*(td_var%t_dim(2)%i_len-2*ip_ghost))
+ il_max_width(jp_south)=INT(0.5*(td_var%t_dim(2)%i_len-2*ip_ghost))
+ il_max_width(jp_east )=INT(0.5*(td_var%t_dim(1)%i_len-2*ip_ghost))
+ il_max_width(jp_west )=INT(0.5*(td_var%t_dim(1)%i_len-2*ip_ghost))
+
DO jk=1,ip_ncard
+ ! check boundary width
+ IF( il_max_width(jk) <= im_width )THEN
+ IF( il_max_width(jk) <= 0 )THEN
+ CALL logger_fatal("BOUNDARY INIT: domain too small to define"//&
+ & " boundaries.")
+ ELSE
+ CALL logger_warn("BOUNDARY INIT: default boundary width too "//&
+ & "large for boundaries. force to use boundary"//&
+ & " on one point")
+ il_width=1
+ ENDIF
+ ELSE
+ il_width=im_width
+ ENDIF
+
! define default segment
- tl_seg=seg__init(il_index(jk),im_width,il_min(jk),il_max(jk))
+ tl_seg=seg__init(il_index(jk),il_width,il_min(jk),il_max(jk))
IF( tl_bdy(jk)%l_use )THEN
@@ -453,4 +607,6 @@
ENDIF
+ ! clean
+ CALL seg__clean(tl_seg)
ENDDO
@@ -460,5 +616,5 @@
CALL boundary_check(tl_bdy, td_var)
- boundary__init_wrapper(:)=tl_bdy(:)
+ boundary__init_wrapper(:)=boundary_copy(tl_bdy(:))
! clean
@@ -470,5 +626,4 @@
END FUNCTION boundary__init_wrapper
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function initialise basically a boundary structure with
@@ -480,12 +635,11 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_card : cardinal name
- !> @param[in] ld_use : boundary use or not
- !> @param[in] td_seg : segment structure
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_card cardinal name
+ !> @param[in] ld_use boundary use or not
+ !> @param[in] td_seg segment structure
!> @return boundary structure
!-------------------------------------------------------------------
- !> @code
FUNCTION boundary__init( cd_card, ld_use, td_seg )
IMPLICIT NONE
@@ -520,5 +674,4 @@
END FUNCTION boundary__init
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine add one segment structure to a boundary structure
@@ -527,10 +680,9 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_bdy : boundary structure
- !> @param[in] td_seg : segment structure
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_bdy boundary structure
+ !> @param[in] td_seg segment structure
+ !-------------------------------------------------------------------
SUBROUTINE boundary__add_seg(td_bdy, td_seg)
IMPLICIT NONE
@@ -554,6 +706,7 @@
ELSE
! save temporary segment
- tl_seg(:)=td_bdy%t_seg(:)
-
+ tl_seg(:)=seg__copy(td_bdy%t_seg(:))
+
+ CALL seg__clean(td_bdy%t_seg(:))
DEALLOCATE( td_bdy%t_seg )
ALLOCATE( td_bdy%t_seg(td_bdy%i_nseg+1), stat=il_status )
@@ -564,6 +717,8 @@
! copy segment in boundary before
- td_bdy%t_seg(1:td_bdy%i_nseg)=tl_seg(:)
-
+ td_bdy%t_seg(1:td_bdy%i_nseg)=seg__copy(tl_seg(:))
+
+ ! clean
+ CALL seg__clean(tl_seg(:))
DEALLOCATE(tl_seg)
@@ -572,4 +727,5 @@
! no segment in boundary structure
IF( ASSOCIATED(td_bdy%t_seg) )THEN
+ CALL seg__clean(td_bdy%t_seg(:))
DEALLOCATE(td_bdy%t_seg)
ENDIF
@@ -585,8 +741,7 @@
! add new segment
- td_bdy%t_seg(td_bdy%i_nseg)=td_seg
+ td_bdy%t_seg(td_bdy%i_nseg)=seg__copy(td_seg)
END SUBROUTINE boundary__add_seg
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine remove all segments of a boundary structure
@@ -595,9 +750,8 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_bdy : boundary structure
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_bdy boundary structure
+ !-------------------------------------------------------------------
SUBROUTINE boundary__del_seg(td_bdy)
IMPLICIT NONE
@@ -610,4 +764,5 @@
IF( ASSOCIATED(td_bdy%t_seg) )THEN
+ CALL seg__clean(td_bdy%t_seg(:))
DEALLOCATE(td_bdy%t_seg)
ENDIF
@@ -616,5 +771,4 @@
END SUBROUTINE boundary__del_seg
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function get information about boundary from string character.
@@ -627,10 +781,9 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_card : boundary description
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_card boundary description
!> @return boundary structure
!-------------------------------------------------------------------
- !> @code
FUNCTION boundary__get_info(cd_card)
IMPLICIT NONE
@@ -737,8 +890,10 @@
ji=ji+1
cl_seg=fct_split(cd_card,ji)
+
+ ! clean
+ CALL seg__clean(tl_seg)
ENDDO
END FUNCTION boundary__get_info
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine get indices of each semgent for each boundary.
@@ -757,11 +912,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_bdy : boundary structure
- !> @param[in] td_var : variable structure
- !> @param[in] ld_onseg : use only one sgment for each boundary
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_bdy boundary structure
+ !> @param[in] td_var variable structure
+ !> @param[in] ld_onseg use only one sgment for each boundary
+ !-------------------------------------------------------------------
SUBROUTINE boundary_get_indices( td_bdy, td_var, ld_oneseg)
IMPLICIT NONE
@@ -811,5 +965,5 @@
IF( ll_oneseg .AND. td_bdy(jk)%l_use )THEN
- tl_seg=td_bdy(jk)%t_seg(1)
+ tl_seg=seg__copy(td_bdy(jk)%t_seg(1))
! use last indice of last segment
tl_seg%i_last=td_bdy(jk)%t_seg(td_bdy(jk)%i_nseg)%i_last
@@ -820,4 +974,7 @@
! add one segment
CALL boundary__add_seg(td_bdy(jk),tl_seg)
+
+ ! clean
+ CALL seg__clean(tl_seg)
ENDIF
@@ -829,5 +986,4 @@
END SUBROUTINE boundary_get_indices
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine compute the number of sea segment.
@@ -841,10 +997,9 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_bdy : boundary structure
- !> @param[in] td_var : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_bdy boundary structure
+ !> @param[in] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE boundary__get_seg_number( td_bdy, td_var)
IMPLICIT NONE
@@ -927,8 +1082,6 @@
END SELECT
ENDIF
-
-
+
END SUBROUTINE boundary__get_seg_number
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine get segment indices for one boundary.
@@ -937,14 +1090,13 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_bdy : boundary structure
- !> @param[in] td_var : variable structure
- !> @param[in] id_index : boundary orthogonal index
- !> @param[in] id_width : bounary width
- !> @param[in] id_first : boundary first indice
- !> @param[in] id_last : boundary last indice
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_bdy boundary structure
+ !> @param[in] td_var variable structure
+ !> @param[in] id_index boundary orthogonal index
+ !> @param[in] id_width bounary width
+ !> @param[in] id_first boundary first indice
+ !> @param[in] id_last boundary last indice
+ !-------------------------------------------------------------------
SUBROUTINE boundary__get_seg_indices( td_bdy, td_var, &
& id_index, id_width, id_first, id_last)
@@ -1004,13 +1156,13 @@
END SELECT
- il_max(jp_north)=td_var%t_dim(1)%i_len-ig_ghost
- il_max(jp_south)=td_var%t_dim(1)%i_len-ig_ghost
- il_max(jp_east )=td_var%t_dim(2)%i_len-ig_ghost
- il_max(jp_west )=td_var%t_dim(2)%i_len-ig_ghost
-
- il_min(jp_north)=1+ig_ghost
- il_min(jp_south)=1+ig_ghost
- il_min(jp_east )=1+ig_ghost
- il_min(jp_west )=1+ig_ghost
+ il_max(jp_north)=td_var%t_dim(1)%i_len-ip_ghost
+ il_max(jp_south)=td_var%t_dim(1)%i_len-ip_ghost
+ il_max(jp_east )=td_var%t_dim(2)%i_len-ip_ghost
+ il_max(jp_west )=td_var%t_dim(2)%i_len-ip_ghost
+
+ il_min(jp_north)=1+ip_ghost
+ il_min(jp_south)=1+ip_ghost
+ il_min(jp_east )=1+ip_ghost
+ il_min(jp_west )=1+ip_ghost
! special case for EW cyclic
@@ -1074,4 +1226,5 @@
CALL boundary__add_seg(td_bdy,tl_seg)
+ ! clean
CALL seg__clean(tl_seg)
@@ -1081,5 +1234,4 @@
END SUBROUTINE boundary__get_seg_indices
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine check if there is boundary at corner, and
@@ -1094,12 +1246,9 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_bdy : boundary structure
- !> @param[in] td_var : variable structure
- !>
- !> @todo add schematic to description
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_bdy boundary structure
+ !> @param[in] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE boundary_check_corner( td_bdy, td_var )
IMPLICIT NONE
@@ -1126,6 +1275,6 @@
! check north west corner
IF( td_bdy(jp_north)%l_use .AND. td_bdy(jp_west)%l_use )THEN
- tl_west =td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg)
- tl_north=td_bdy(jp_north)%t_seg(1)
+ tl_west =seg__copy(td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg))
+ tl_north=seg__copy(td_bdy(jp_north)%t_seg(1))
IF( tl_west%i_last >= tl_north%i_index .AND. &
@@ -1148,6 +1297,6 @@
ENDIF
- td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg)=tl_west
- td_bdy(jp_north)%t_seg(1) =tl_north
+ td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg)=seg__copy(tl_west)
+ td_bdy(jp_north)%t_seg(1) =seg__copy(tl_north)
ELSE
@@ -1169,6 +1318,6 @@
! check north east corner
IF( td_bdy(jp_north)%l_use .AND. td_bdy(jp_east)%l_use )THEN
- tl_east =td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg)
- tl_north=td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg)
+ tl_east =seg__copy(td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg))
+ tl_north=seg__copy(td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg))
IF( tl_east%i_last >= tl_north%i_index .AND. &
@@ -1191,6 +1340,6 @@
ENDIF
- td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg)=tl_east
- td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg)=tl_north
+ td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg)=seg__copy(tl_east)
+ td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg)=seg__copy(tl_north)
ELSE
@@ -1211,6 +1360,6 @@
! check south east corner
IF( td_bdy(jp_south)%l_use .AND. td_bdy(jp_east)%l_use )THEN
- tl_east =td_bdy(jp_east )%t_seg(1)
- tl_south=td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg)
+ tl_east =seg__copy(td_bdy(jp_east )%t_seg(1))
+ tl_south=seg__copy(td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg))
IF( tl_east%i_first <= tl_south%i_index .AND. &
@@ -1233,6 +1382,6 @@
ENDIF
- td_bdy(jp_east )%t_seg(1) =tl_east
- td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg)=tl_south
+ td_bdy(jp_east )%t_seg(1) =seg__copy(tl_east)
+ td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg)=seg__copy(tl_south)
ELSE
@@ -1253,6 +1402,6 @@
! check south west corner
IF( td_bdy(jp_south)%l_use .AND. td_bdy(jp_west)%l_use )THEN
- tl_west =td_bdy(jp_west )%t_seg(1)
- tl_south=td_bdy(jp_south)%t_seg(1)
+ tl_west =seg__copy(td_bdy(jp_west )%t_seg(1))
+ tl_south=seg__copy(td_bdy(jp_south)%t_seg(1))
IF( tl_west%i_first <= tl_south%i_index .AND. &
@@ -1275,6 +1424,6 @@
ENDIF
- td_bdy(jp_west )%t_seg(1) = tl_west
- td_bdy(jp_south)%t_seg(1) = tl_south
+ td_bdy(jp_west )%t_seg(1) = seg__copy(tl_west)
+ td_bdy(jp_south)%t_seg(1) = seg__copy(tl_south)
ELSE
@@ -1293,6 +1442,11 @@
ENDIF
+ ! clean
+ CALL seg__clean(tl_north)
+ CALL seg__clean(tl_south)
+ CALL seg__clean(tl_east )
+ CALL seg__clean(tl_west )
+
END SUBROUTINE boundary_check_corner
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine check boundary.
@@ -1303,10 +1457,9 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_bdy : boundary structure
- !> @param[in] td_var : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_bdy boundary structure
+ !> @param[in] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE boundary_check(td_bdy, td_var)
IMPLICIT NONE
@@ -1328,8 +1481,8 @@
il_max(jp_west )=td_var%t_dim(2)%i_len
- il_maxindex(jp_north)=td_var%t_dim(2)%i_len-ig_ghost
- il_maxindex(jp_south)=td_var%t_dim(2)%i_len-ig_ghost
- il_maxindex(jp_east )=td_var%t_dim(1)%i_len-ig_ghost
- il_maxindex(jp_west )=td_var%t_dim(1)%i_len-ig_ghost
+ il_maxindex(jp_north)=td_var%t_dim(2)%i_len-ip_ghost
+ il_maxindex(jp_south)=td_var%t_dim(2)%i_len-ip_ghost
+ il_maxindex(jp_east )=td_var%t_dim(1)%i_len-ip_ghost
+ il_maxindex(jp_west )=td_var%t_dim(1)%i_len-ip_ghost
DO jk=1,ip_ncard
@@ -1366,127 +1519,4 @@
END SUBROUTINE boundary_check
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine clean interpolated boundary in variable structure.
- !
- !> @detail
- !> interpolation could create more point than needed for boundary (depending
- !> on refinement factor). This subroutine keep only useful point on variable
- !>
- !> @note we use width define in first segment, cause every segment of a
- !> boundary should have the same width
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable strucutre
- !> @param[in ] td_bdy : boundary strucutre
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE boundary_clean_interp( td_var, td_bdy )
- IMPLICIT NONE
- ! Argument
- TYPE(TVAR), INTENT(INOUT) :: td_var
- TYPE(TBDY), INTENT(IN ) :: td_bdy
-
- ! local variable
- TYPE(TVAR) :: tl_var
-
- INTEGER(i4) :: il_imin
- INTEGER(i4) :: il_imax
- INTEGER(i4) :: il_jmin
- INTEGER(i4) :: il_jmax
-
- ! loop indices
- !----------------------------------------------------------------
-
- ! copy input variable
- tl_var=td_var
-
- DEALLOCATE(td_var%d_value)
-
- SELECT CASE(TRIM(td_bdy%c_card))
- CASE('north')
-
- il_imin=1
- il_imax=tl_var%t_dim(1)%i_len
- SELECT CASE(td_var%c_point)
- CASE('V','F')
- il_jmin=td_bdy%t_seg(1)%i_width+1
- il_jmax=2
- CASE DEFAULT ! 'T','U'
- il_jmin=td_bdy%t_seg(1)%i_width
- il_jmax=1
- END SELECT
-
- ! use width as dimension length
- td_var%t_dim(2)%i_len=td_bdy%t_seg(1)%i_width
-
- CASE('south')
-
- il_imin=1
- il_imax=tl_var%t_dim(1)%i_len
-
- il_jmin=1
- il_jmax=td_bdy%t_seg(1)%i_width
-
- ! use width as dimension length
- td_var%t_dim(2)%i_len=td_bdy%t_seg(1)%i_width
-
- CASE('east')
-
- SELECT CASE(td_var%c_point)
- CASE('U','F')
- il_imin=td_bdy%t_seg(1)%i_width+1
- il_imax=2
- CASE DEFAULT ! 'T','V'
- il_imin=td_bdy%t_seg(1)%i_width
- il_imax=1
- END SELECT
-
- il_jmin=1
- il_jmax=tl_var%t_dim(2)%i_len
-
- ! use width as dimension length
- td_var%t_dim(1)%i_len=td_bdy%t_seg(1)%i_width
-
- CASE('west')
-
- il_imin=1
- il_imax=td_bdy%t_seg(1)%i_width
-
- il_jmin=1
- il_jmax=tl_var%t_dim(2)%i_len
-
- ! use width as dimension length
- td_var%t_dim(1)%i_len=td_bdy%t_seg(1)%i_width
-
- END SELECT
-
-
- ALLOCATE( td_var%d_value(td_var%t_dim(1)%i_len, &
- & td_var%t_dim(2)%i_len, &
- & td_var%t_dim(3)%i_len, &
- & td_var%t_dim(4)%i_len) )
-
- IF( il_imin > il_imax )THEN
- il_imin=tl_var%t_dim(1)%i_len-il_imin+1
- il_imax=tl_var%t_dim(1)%i_len-il_imax+1
- ENDIF
-
- IF( il_jmin > il_jmax )THEN
- il_jmin=tl_var%t_dim(2)%i_len-il_jmin+1
- il_jmax=tl_var%t_dim(2)%i_len-il_jmax+1
- ENDIF
-
- td_var%d_value(:,:,:,:)=tl_var%d_value( il_imin:il_imax, &
- & il_jmin:il_jmax, &
- & :,: )
-
- CALL var_clean(tl_var)
-
-
- END SUBROUTINE boundary_clean_interp
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine swap array for east and north boundary.
@@ -1495,10 +1525,9 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> @date November, 2013 - Initial Version
!
- !> @param[inout] td_var : variable strucutre
- !> @param[in ] td_bdy : boundary strucutre
+ !> @param[inout] td_var variable strucutre
+ !> @param[in ] td_bdy boundary strucutre
!-------------------------------------------------------------------
- !> @code
SUBROUTINE boundary_swap( td_var, td_bdy )
IMPLICIT NONE
@@ -1516,5 +1545,5 @@
IF( .NOT. ASSOCIATED(td_var%d_value) )THEN
- CALL logger_error("BOUNDARY SWAP: no table of value "//&
+ CALL logger_error("BOUNDARY SWAP: no array of value "//&
& "associted to variable "//TRIM(td_var%c_name) )
ELSE
@@ -1555,16 +1584,12 @@
ENDIF
END SUBROUTINE boundary_swap
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine print information about one boundary
- !
- !> @details
+ !-------------------------------------------------------------------
+ !> @brief This subroutine print information about one boundary.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_bdy : boundary structure
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_bdy boundary structure
+ !-------------------------------------------------------------------
SUBROUTINE boundary__print_unit( td_bdy )
IMPLICIT NONE
@@ -1588,17 +1613,15 @@
END SUBROUTINE boundary__print_unit
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine print information about a table of boundary
+ !-------------------------------------------------------------------
+ !> @brief This subroutine print information about a array of boundary
!
!> @details
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_bdy : boundary structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE boundary__print_tab( td_bdy )
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_bdy boundary structure
+ !-------------------------------------------------------------------
+ SUBROUTINE boundary__print_arr( td_bdy )
IMPLICIT NONE
! Argument
@@ -1613,27 +1636,30 @@
ENDDO
- END SUBROUTINE boundary__print_tab
- !> @endcode
+ END SUBROUTINE boundary__print_arr
!-------------------------------------------------------------------
!> @brief
- !> This subroutine copy segment structure in another segment
- !> structure
- !> @details
+ !> This subroutine copy segment structure in another one.
!>
+ !> @warning do not use on the output of a function who create or read a
+ !> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden).
+ !> This will create memory leaks.
!> @warning to avoid infinite loop, do not use any function inside
!> this subroutine
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> @date November, 2013 - Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator
+ !> (to avoid memory leak)
!
- !> @param[out] td_seg1 : segment structure
- !> @param[in] td_seg2 : segment structure
+ !> @param[in] td_seg segment structure
+ !> @return copy of input segment structure
!-------------------------------------------------------------------
- !> @code
- SUBROUTINE seg__copy( td_seg1, td_seg2 )
+ FUNCTION seg__copy_unit( td_seg )
IMPLICIT NONE
! Argument
- TYPE(TSEG), INTENT(OUT) :: td_seg1
- TYPE(TSEG), INTENT(IN) :: td_seg2
+ TYPE(TSEG), INTENT(IN) :: td_seg
+ ! function
+ TYPE(TSEG) :: seg__copy_unit
! local variable
@@ -1642,11 +1668,46 @@
! copy segment index, width, ..
- td_seg1%i_index = td_seg2%i_index
- td_seg1%i_width = td_seg2%i_width
- td_seg1%i_first = td_seg2%i_first
- td_seg1%i_last = td_seg2%i_last
-
- END SUBROUTINE seg__copy
- !> @endcode
+ seg__copy_unit%i_index = td_seg%i_index
+ seg__copy_unit%i_width = td_seg%i_width
+ seg__copy_unit%i_first = td_seg%i_first
+ seg__copy_unit%i_last = td_seg%i_last
+
+ END FUNCTION seg__copy_unit
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine copy segment structure in another one.
+ !>
+ !> @warning do not use on the output of a function who create or read a
+ !> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden).
+ !> This will create memory leaks.
+ !> @warning to avoid infinite loop, do not use any function inside
+ !> this subroutine
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator
+ !> (to avoid memory leak)
+ !
+ !> @param[in] td_seg segment structure
+ !> @return copy of input array of segment structure
+ !-------------------------------------------------------------------
+ FUNCTION seg__copy_arr( td_seg )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TSEG), DIMENSION(:), INTENT(IN) :: td_seg
+ ! function
+ TYPE(TSEG), DIMENSION(SIZE(td_seg(:))) :: seg__copy_arr
+
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ DO ji=1,SIZE(td_seg(:))
+ seg__copy_arr(ji)=seg__copy(td_seg(ji))
+ ENDDO
+
+ END FUNCTION seg__copy_arr
!-------------------------------------------------------------------
!> @brief This function initialise segment structure.
@@ -1657,13 +1718,12 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] id_index : orthogonal index
- !> @param[in] id_width : width of the segment
- !> @param[in] id_first : first indices
- !> @param[in] id_last : last indices
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] id_index orthogonal index
+ !> @param[in] id_width width of the segment
+ !> @param[in] id_first first indices
+ !> @param[in] id_last last indices
!> @return segment structure
!-------------------------------------------------------------------
- !> @code
FUNCTION seg__init( id_index, id_width, id_first, id_last )
IMPLICIT NONE
@@ -1689,17 +1749,13 @@
END FUNCTION seg__init
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine clean segment structure.
!
- !> @details
- !
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_seg : segment structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE seg__clean(td_seg)
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_seg segment structure
+ !-------------------------------------------------------------------
+ SUBROUTINE seg__clean_unit(td_seg)
IMPLICIT NONE
! Argument
@@ -1710,48 +1766,28 @@
!----------------------------------------------------------------
- td_seg=tl_seg
+ td_seg=seg__copy(tl_seg)
- END SUBROUTINE seg__clean
- !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This function
-! !
-! !> @details
-! !
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !-------------------------------------------------------------------
-! !> @code
-! FUNCTION boundary_()
-! IMPLICIT NONE
-! ! Argument
-! ! function
-! ! local variable
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END FUNCTION boundary_
-! !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This subroutine
-! !
-! !> @details
-! !
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !-------------------------------------------------------------------
-! !> @code
-! SUBROUTINE boundary_()
-! IMPLICIT NONE
-! ! Argument
-! ! local variable
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END SUBROUTINE boundary_
-! !> @endcode
+ END SUBROUTINE seg__clean_unit
+ !-------------------------------------------------------------------
+ !> @brief This subroutine clean segment structure.
+ !
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_seg array of segment structure
+ !-------------------------------------------------------------------
+ SUBROUTINE seg__clean_arr(td_seg)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TSEG), DIMENSION(:), INTENT(INOUT) :: td_seg
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ DO ji=SIZE(td_seg(:)),1,-1
+ CALL seg__clean(td_seg(ji))
+ ENDDO
+
+ END SUBROUTINE seg__clean_arr
END MODULE boundary
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_bathy.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_bathy.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_bathy.f90 (revision 5214)
@@ -3,29 +3,125 @@
!----------------------------------------------------------------------
!
-!
! PROGRAM: create_bathy
!
! DESCRIPTION:
+!> @file
!> @brief
-!> This program create bathymetry file.
+!> This program create fine grid bathymetry file.
!>
!> @details
-!> Bathymetry could be extracted from fine grid Bathymetry file, or interpolated
-!> from coarse grid Bathymetry file.
-!>
-!> @author
-!> J.Paul
+!> @section sec1 method
+!> Bathymetry could be extracted from fine grid Bathymetry file, interpolated
+!> from coarse grid Bathymetry file, or manually written.
+!>
+!> @section sec2 how to
+!> to create fine grid bathymetry file:
+!> @code{.sh}
+!> ./SIREN/bin/create_bathy create_bathy.nam
+!> @endcode
+!>
+!> create_bathy.nam comprise 7 namelists:
+!> - logger namelist (namlog)
+!> - config namelist (namcfg)
+!> - coarse grid namelist (namcrs)
+!> - fine grid namelist (namfin)
+!> - variable namelist (namvar)
+!> - nesting namelist (namnst)
+!> - output namelist (namout)
+!>
+!> @note
+!> All namelists have to be in file create_bathy.nam, however variables of
+!> those namelists are all optional.
+!>
+!> * _logger namelist (namlog)_:
+!> - cn_logfile : log filename
+!> - cn_verbosity : verbosity ('trace','debug','info',
+!> 'warning','error','fatal')
+!> - in_maxerror : maximum number of error allowed
+!>
+!> * _config namelist (namcfg)_:
+!> - cn_varcfg : variable configuration file
+!> (see ./SIREN/cfg/variable.cfg)
+!>
+!> * _coarse grid namelist (namcrs)_:
+!> - cn_coord0 : coordinate file
+!> - in_perio0 : NEMO periodicity index (see Model Boundary Condition in
+!> [NEMO documentation](http://www.nemo-ocean.eu/About-NEMO/Reference-manuals))
+!>
+!> * _fine grid namelist (namfin)_:
+!> - cn_coord1 : coordinate file
+!> - in_perio1 : periodicity index
+!> - ln_fillclosed : fill closed sea or not
+!>
+!> * _variable namelist (namvar)_:
+!> - cn_varinfo : list of variable and extra information about request(s)
+!> to be used.
+!> each elements of *cn_varinfo* is a string character.
+!> it is composed of the variable name follow by ':',
+!> then request(s) to be used on this variable.
+!> request could be:
+!> - interpolation method
+!> - extrapolation method
+!> - filter method
+!> - > minimum value
+!> - < maximum value
+!>
+!> requests must be separated by ';'.
+!> order of requests does not matter.
+!>
+!> informations about available method could be find in @ref interp,
+!> @ref extrap and @ref filter modules.
+!> Example: 'Bathymetry: 2*hamming(2,3); > 0'
+!> @note
+!> If you do not specify a method which is required,
+!> default one is apply.
+!> @warning
+!> variable name must be __Bathymetry__ here.
+!> - cn_varfile : list of variable, and corresponding file.
+!> *cn_varfile* is the path and filename of the file where find
+!> variable.
+!> @note
+!> *cn_varfile* could be a matrix of value, if you want to filled
+!> manually variable value.
+!> the variable array of value is split into equal subdomain.
+!> Each subdomain is filled with the corresponding value
+!> of the matrix.
+!> separators used to defined matrix are:
+!> - ',' for line
+!> - '/' for row
+!> - '\' for level
+!> Example:
+!> 3,2,3/1,4,5 => @f$ \left( \begin{array}{ccc}
+!> 3 & 2 & 3 \\
+!> 1 & 4 & 5 \end{array} \right) @f$
+!>
+!> Examples:
+!> - 'Bathymetry:gridT.nc'
+!> - 'Bathymetry:5000,5000,5000/5000,3000,5000/5000,5000,5000'
+!>
+!> \image html bathy_40.png
+!> \image latex bathy_30.png
+!>
+!> * _nesting namelist (namnst)_:
+!> - in_rhoi : refinement factor in i-direction
+!> - in_rhoj : refinement factor in j-direction
+!> @note
+!> coarse grid indices will be deduced from fine grid
+!> coordinate file.
+!>
+!> * _output namelist (namout)_:
+!> - cn_fileout : output bathymetry file
+!>
+!> @author J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
+!> @date November, 2013 - Initial Version
+!> @date Sepember, 2014
+!> - add header for user
+!> - Bug fix, compute offset depending of grid point
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!>
-!> @todo
-!> - add attributes indices and refinement in output file
!----------------------------------------------------------------------
-!> @code
PROGRAM create_bathy
-! USE netcdf ! nf90 library
USE global ! global variable
USE kind ! F90 kind parameter
@@ -39,5 +135,4 @@
USE multi ! multi file manager
USE iom ! I/O manager
- USE dom ! domain manager
USE grid ! grid manager
USE extrap ! extrapolation manager
@@ -45,5 +140,7 @@
USE filter ! filter manager
USE mpp ! MPP manager
+ USE dom ! domain manager
USE iom_mpp ! MPP I/O manager
+ USE iom_dom ! DOM I/O manager
IMPLICIT NONE
@@ -57,19 +154,20 @@
INTEGER(i4) :: il_status
INTEGER(i4) :: il_fileid
+ INTEGER(i4) :: il_varid
INTEGER(i4) :: il_attid
- INTEGER(i4) :: il_imin
- INTEGER(i4) :: il_imax
- INTEGER(i4) :: il_jmin
- INTEGER(i4) :: il_jmax
+ INTEGER(i4) :: il_imin0
+ INTEGER(i4) :: il_imax0
+ INTEGER(i4) :: il_jmin0
+ INTEGER(i4) :: il_jmax0
INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho
INTEGER(i4) , DIMENSION(2,2) :: il_offset
- INTEGER(i4) , DIMENSION(2,2,2) :: il_ind
+ INTEGER(i4) , DIMENSION(2,2) :: il_ind
INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_mask
LOGICAL :: ll_exist
- TYPE(TFILE) :: tl_coord0
- TYPE(TFILE) :: tl_coord1
- TYPE(TFILE) :: tl_file
+ TYPE(TMPP) :: tl_coord0
+ TYPE(TMPP) :: tl_coord1
+ TYPE(TMPP) :: tl_mpp
TYPE(TFILE) :: tl_fileout
@@ -88,4 +186,6 @@
TYPE(TMULTI) :: tl_multi
+ REAL(dp) :: dl_minbat
+
! loop indices
INTEGER(i4) :: ji
@@ -94,35 +194,40 @@
! namelist variable
+ ! namlog
CHARACTER(LEN=lc) :: cn_logfile = 'create_bathy.log'
CHARACTER(LEN=lc) :: cn_verbosity = 'warning'
-
+ INTEGER(i4) :: in_maxerror = 5
+
+ ! namcfg
CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg'
+ ! namcrs
CHARACTER(LEN=lc) :: cn_coord0 = ''
INTEGER(i4) :: in_perio0 = -1
+ ! namfin
CHARACTER(LEN=lc) :: cn_coord1 = ''
INTEGER(i4) :: in_perio1 = -1
LOGICAL :: ln_fillclosed = .TRUE.
- CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varinfo = ''
- CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varfile = ''
-
- INTEGER(i4) :: in_imin0 = 0
- INTEGER(i4) :: in_imax0 = 0
- INTEGER(i4) :: in_jmin0 = 0
- INTEGER(i4) :: in_jmax0 = 0
+ ! namvar
+ CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''
+ CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''
+
+ ! namnst
INTEGER(i4) :: in_rhoi = 1
INTEGER(i4) :: in_rhoj = 1
+ ! namout
CHARACTER(LEN=lc) :: cn_fileout = 'bathy_fine.nc'
!-------------------------------------------------------------------
- NAMELIST /namlog/ & !< logger namelist
- & cn_logfile, & !< log file
- & cn_verbosity !< log verbosity
-
- NAMELIST /namcfg/ & !< configuration namelist
- & cn_varcfg !< variable configuration file
+ NAMELIST /namlog/ & !< logger namelist
+ & cn_logfile, & !< log file
+ & cn_verbosity, & !< log verbosity
+ & in_maxerror !< logger maximum error
+
+ NAMELIST /namcfg/ & !< configuration namelist
+ & cn_varcfg !< variable configuration file
NAMELIST /namcrs/ & !< coarse grid namelist
@@ -135,22 +240,18 @@
& ln_fillclosed !< fill closed sea
- NAMELIST /namvar/ & !< variable namelist
- & cn_varinfo, & !< list of variable and interpolation method to be used. (ex: 'votemper:linear','vosaline:cubic' )
- & cn_varfile !< list of variable file
+ NAMELIST /namvar/ & !< variable namelist
+ & cn_varinfo, & !< list of variable and interpolation method to be used. (ex: 'votemper:linear','vosaline:cubic' )
+ & cn_varfile !< list of variable file
- NAMELIST /namnst/ & !< nesting namelist
- & in_imin0, & !< i-direction lower left point indice
- & in_imax0, & !< i-direction upper right point indice
- & in_jmin0, & !< j-direction lower left point indice
- & in_jmax0, & !< j-direction upper right point indice
- & in_rhoi, & !< refinement factor in i-direction
- & in_rhoj !< refinement factor in j-direction
-
- NAMELIST /namout/ & !< output namlist
- & cn_fileout !< fine grid bathymetry file
+ NAMELIST /namnst/ & !< nesting namelist
+ & in_rhoi, & !< refinement factor in i-direction
+ & in_rhoj !< refinement factor in j-direction
+
+ NAMELIST /namout/ & !< output namlist
+ & cn_fileout !< fine grid bathymetry file
!-------------------------------------------------------------------
- !1- namelist
- !1-1 get namelist
+ ! namelist
+ ! get namelist
il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
IF( il_narg/=1 )THEN
@@ -160,9 +261,9 @@
CALL GET_COMMAND_ARGUMENT(1,cl_namelist) !f03 intrinsec
ENDIF
-
- !1-2 read namelist
+
+ ! read namelist
INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist)
IF( ll_exist )THEN
-
+
il_fileid=fct_getunit()
@@ -180,10 +281,10 @@
READ( il_fileid, NML = namlog )
- !1-2-1 define log file
- CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity))
+ ! define log file
+ CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror)
CALL logger_header()
READ( il_fileid, NML = namcfg )
- !1-2-2 get variable extra information
+ ! get variable extra information
CALL var_def_extra(TRIM(cn_varcfg))
@@ -191,7 +292,7 @@
READ( il_fileid, NML = namfin )
READ( il_fileid, NML = namvar )
- !1-2-3 add user change in extra information
- CALL var_chg_extra(cn_varinfo)
- !1-2-4 match variable with file
+ ! add user change in extra information
+ CALL var_chg_extra( cn_varinfo )
+ ! match variable with file
tl_multi=multi_init(cn_varfile)
@@ -211,8 +312,10 @@
ENDIF
- !2- open files
+ CALL multi_print(tl_multi)
+
+ ! open files
IF( cn_coord0 /= '' )THEN
- tl_coord0=file_init(TRIM(cn_coord0),id_perio=in_perio0)
- CALL iom_open(tl_coord0)
+ tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0)
+ CALL grid_get_info(tl_coord0)
ELSE
CALL logger_fatal("CREATE BATHY: no coarse grid coordinate found. "//&
@@ -221,6 +324,6 @@
IF( TRIM(cn_coord1) /= '' )THEN
- tl_coord1=file_init(TRIM(cn_coord1),id_perio=in_perio1)
- CALL iom_open(tl_coord1)
+ tl_coord1=mpp_init( file_init(TRIM(cn_coord1)),id_perio=in_perio1)
+ CALL grid_get_info(tl_coord1)
ELSE
CALL logger_fatal("CREATE BATHY: no fine grid coordinate found. "//&
@@ -228,6 +331,6 @@
ENDIF
- !3- check
- !3-1 check output file do not already exist
+ ! check
+ ! check output file do not already exist
INQUIRE(FILE=TRIM(cn_fileout), EXIST=ll_exist)
IF( ll_exist )THEN
@@ -236,6 +339,6 @@
ENDIF
- !3-2 check namelist
- !3-2-1 check refinement factor
+ ! check namelist
+ ! check refinement factor
il_rho(:)=1
IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN
@@ -247,116 +350,132 @@
ENDIF
- !3-2-2 check domain indices
- IF( in_imin0 < 1 .OR. in_imax0 < 1 .OR. &
- & in_jmin0 < 1 .OR. in_jmax0 < 1)THEN
- ! compute coarse grid indices around fine grid
- IF( cn_coord0 /= '' )THEN
- il_ind(:,:,:)=grid_get_coarse_index( tl_coord0, tl_coord1, &
- & id_rho=il_rho(:) )
- ENDIF
-
- il_imin=il_ind(1,1,1) ; il_imax=il_ind(1,2,1)
- il_jmin=il_ind(2,1,1) ; il_jmax=il_ind(2,2,1)
-
- il_offset(:,:)=il_ind(:,:,2)
- ELSE
- il_imin=in_imin0 ; il_imax=in_imax0
- il_jmin=in_jmin0 ; il_jmax=in_jmax0
-
- il_offset(jp_I,:)=FLOOR(REAL(il_rho(jp_I)-1,dp)*0.5)
- il_offset(jp_J,:)=FLOOR(REAL(il_rho(jp_J)-1,dp)*0.5)
- ENDIF
-
- !3-2-3 check domain validity
- IF( cn_coord0 /= '' )THEN
- CALL grid_check_dom(tl_coord0, il_imin, il_imax, il_jmin, il_jmax)
- ENDIF
-
- !3-2-4 check coincidence between coarse and fine grid
- IF( cn_coord0 /= '' )THEN
- CALL grid_check_coincidence( tl_coord0, tl_coord1, &
- & il_imin, il_imax, &
- & il_jmin, il_jmax, &
- & il_rho(:) )
- ENDIF
-
- IF( .NOT. ASSOCIATED(tl_multi%t_file) )THEN
- CALL logger_error("CREATE BATHY: no file to work on. "//&
+ ! check domain indices
+ ! compute coarse grid indices around fine grid
+ il_ind(:,:)=grid_get_coarse_index( tl_coord0, tl_coord1, &
+ & id_rho=il_rho(:) )
+
+ il_imin0=il_ind(jp_I,1) ; il_imax0=il_ind(jp_I,2)
+ il_jmin0=il_ind(jp_J,1) ; il_jmax0=il_ind(jp_J,2)
+
+ ! check domain validity
+ CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0)
+
+ ! check coincidence between coarse and fine grid
+ CALL grid_check_coincidence( tl_coord0, tl_coord1, &
+ & il_imin0, il_imax0, &
+ & il_jmin0, il_jmax0, &
+ & il_rho(:) )
+
+ IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN
+ CALL logger_error("CREATE BATHY: no mpp file to work on. "//&
& "check cn_varfile in namelist.")
ELSE
+
ALLOCATE( tl_var( tl_multi%i_nvar ) )
jk=0
- DO ji=1,tl_multi%i_nfile
- WRITE(cl_data,'(a,i2.2)') 'data_',jk+1
- IF( .NOT. ASSOCIATED(tl_multi%t_file(ji)%t_var) )THEN
- CALL logger_error("CREATE BATHY: no variable to work on for "//&
- & "file"//TRIM(tl_multi%t_file(ji)%c_name)//&
+ DO ji=1,tl_multi%i_nmpp
+
+ WRITE(cl_data,'(a,i2.2)') 'data-',jk+1
+ IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
+
+ CALL logger_fatal("CREATE BATHY: no variable to work on for "//&
+ & "mpp file"//TRIM(tl_multi%t_mpp(ji)%c_name)//&
& ". check cn_varfile in namelist.")
- ELSEIF( TRIM(tl_multi%t_file(ji)%c_name) == TRIM(cl_data) )THEN
- DO jj=1,tl_multi%t_file(ji)%i_nvar
+
+ ELSEIF( TRIM(tl_multi%t_mpp(ji)%c_name) == TRIM(cl_data) )THEN
+
+ !- use input matrix to initialise variable
+ DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
jk=jk+1
- tl_tmp=tl_multi%t_file(ji)%t_var(jj)
- !- use input matrix to initialise variable
+ tl_tmp=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj))
+
tl_var(jk)=create_bathy_matrix(tl_tmp, tl_coord1)
ENDDO
+ ! clean
+ CALL var_clean(tl_tmp)
+
ELSE
- ! open file
- tl_file=file_init(TRIM(tl_multi%t_file(ji)%c_name))
- CALL iom_open(tl_file)
+
+ tl_mpp=mpp_init( file_init(TRIM(tl_multi%t_mpp(ji)%c_name)) )
+ CALL grid_get_info(tl_mpp)
+
+ ! open mpp file
+ CALL iom_mpp_open(tl_mpp)
! get or check depth value
- IF( tl_file%i_depthid /= 0 )THEN
+ IF( tl_multi%t_mpp(ji)%t_proc(1)%i_depthid /= 0 )THEN
+ il_varid=tl_multi%t_mpp(ji)%t_proc(1)%i_depthid
IF( ASSOCIATED(tl_depth%d_value) )THEN
+ tl_tmp=iom_mpp_read_var(tl_mpp,il_varid)
IF( ANY( tl_depth%d_value(:,:,:,:) /= &
& tl_tmp%d_value(:,:,:,:) ) )THEN
CALL logger_fatal("CREATE BATHY: depth value from "//&
- & TRIM(tl_multi%t_file(ji)%c_name)//" not conform "//&
+ & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//&
& " to those from former file(s).")
ENDIF
+ CALL var_clean(tl_tmp)
ELSE
- tl_depth=iom_read_var(tl_file,tl_file%i_depthid)
+ tl_depth=iom_mpp_read_var(tl_mpp,il_varid)
ENDIF
ENDIF
! get or check time value
- IF( tl_file%i_timeid /= 0 )THEN
+ IF( tl_multi%t_mpp(ji)%t_proc(1)%i_timeid /= 0 )THEN
+ il_varid=tl_multi%t_mpp(ji)%t_proc(1)%i_timeid
IF( ASSOCIATED(tl_time%d_value) )THEN
+ tl_tmp=iom_mpp_read_var(tl_mpp,il_varid)
IF( ANY( tl_time%d_value(:,:,:,:) /= &
& tl_tmp%d_value(:,:,:,:) ) )THEN
CALL logger_fatal("CREATE BATHY: time value from "//&
- & TRIM(tl_multi%t_file(ji)%c_name)//" not conform "//&
+ & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//&
& " to those from former file(s).")
ENDIF
+ CALL var_clean(tl_tmp)
ELSE
- tl_time=iom_read_var(tl_file,tl_file%i_timeid)
+ tl_time=iom_mpp_read_var(tl_mpp,il_varid)
ENDIF
ENDIF
- IF( ANY( tl_file%t_dim(1:2)%i_len /= &
- & tl_coord0%t_dim(1:2)%i_len) )THEN
- DO jj=1,tl_multi%t_file(ji)%i_nvar
+ ! close mpp file
+ CALL iom_mpp_close(tl_mpp)
+
+ IF( ANY( tl_mpp%t_dim(1:2)%i_len /= &
+ & tl_coord0%t_dim(1:2)%i_len) )THEN
+ !- extract bathymetry from fine grid bathymetry
+ DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
jk=jk+1
- tl_tmp=tl_multi%t_file(ji)%t_var(jj)
- !- extract bathymetry from fine grid bathymetry
- tl_var(jk)=create_bathy_extract( tl_tmp, tl_file, &
+ tl_tmp=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj))
+
+ tl_var(jk)=create_bathy_extract( tl_tmp, tl_mpp, &
& tl_coord1 )
ENDDO
+ ! clean
+ CALL var_clean(tl_tmp)
ELSE
- DO jj=1,tl_multi%t_file(ji)%i_nvar
+ !- get bathymetry from coarse grid bathymetry
+ DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
jk=jk+1
- tl_tmp=tl_multi%t_file(ji)%t_var(jj)
- !- get bathymetry from coarse grid bathymetry
- tl_var(jk)=create_bathy_get_var( tl_tmp, tl_file, &
- & il_imin, il_jmin, &
- & il_imax, il_jmax, &
- & il_offset(:,:), &
+ tl_tmp=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj))
+
+ il_offset(:,:)= grid_get_fine_offset(tl_coord0, &
+ & il_imin0, il_jmin0, &
+ & il_imax0, il_jmax0, &
+ & tl_coord1, &
+ & il_rho(:), &
+ & TRIM(tl_tmp%c_point) )
+
+ tl_var(jk)=create_bathy_get_var( tl_tmp, tl_mpp, &
+ & il_imin0, il_jmin0, &
+ & il_imax0, il_jmax0, &
+ & il_offset(:,:), &
& il_rho(:) )
ENDDO
+ ! clean
+ CALL var_clean(tl_tmp)
ENDIF
- ! close file
- CALL iom_close(tl_file)
! clean structure
- CALL file_clean(tl_file)
+ CALL mpp_clean(tl_mpp)
+
ENDIF
ENDDO
@@ -364,17 +483,16 @@
DO jk=1,tl_multi%i_nvar
- !6- forced min and max value
+ ! forced min and max value
CALL var_limit_value(tl_var(jk))
- !7- fill closed sea
- IF( TRIM(tl_var(jk)%c_stdname) == 'bathymetry' .AND. &
- ln_fillclosed )THEN
+ ! fill closed sea
+ IF( ln_fillclosed )THEN
ALLOCATE( il_mask(tl_var(jk)%t_dim(1)%i_len, &
& tl_var(jk)%t_dim(2)%i_len) )
- !7-1 split domain in N sea subdomain
+ ! split domain in N sea subdomain
il_mask(:,:)=grid_split_domain(tl_var(jk))
- !7-2 fill smallest domain
+ ! fill smallest domain
CALL grid_fill_small_dom( tl_var(jk), il_mask(:,:) )
@@ -382,19 +500,21 @@
ENDIF
- !8- filter
+ ! filter
CALL filter_fill_value(tl_var(jk))
- !9- check bathymetry
+ ! check bathymetry
+ dl_minbat=MINVAL(tl_var(jk)%d_value(:,:,:,:))
IF( TRIM(tl_var(jk)%c_stdname) == 'bathymetry' .AND. &
- & MINVAL(tl_var(jk)%d_value(:,:,:,:)) <= 0._dp )THEN
+ & dl_minbat <= 0._dp )THEN
+ CALL logger_debug("CREATE BATHY: min value "//TRIM(fct_str(dl_minbat)))
CALL logger_error("CREATE BATHY: Bathymetry has value <= 0")
ENDIF
+
ENDDO
-
- !10- create file
- tl_fileout=file_init(TRIM(cn_fileout),id_perio=in_perio1)
-
- !10-1 add dimension
+ ! create file
+ tl_fileout=file_init(TRIM(cn_fileout))
+
+ ! add dimension
tl_dim(:)=var_max_dim(tl_var(:))
@@ -403,16 +523,22 @@
ENDDO
- !10-2 add variables
+ ! add variables
IF( ALL( tl_dim(1:2)%l_use ) )THEN
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord1)
+
! add longitude
- tl_lon=iom_read_var(tl_coord1,'longitude')
+ tl_lon=iom_mpp_read_var(tl_coord1,'longitude')
CALL file_add_var(tl_fileout, tl_lon)
CALL var_clean(tl_lon)
! add latitude
- tl_lat=iom_read_var(tl_coord1,'latitude')
+ tl_lat=iom_mpp_read_var(tl_coord1,'latitude')
CALL file_add_var(tl_fileout, tl_lat)
CALL var_clean(tl_lat)
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_coord1)
ENDIF
@@ -435,6 +561,7 @@
CALL var_clean(tl_var(jk))
ENDDO
-
- !10-3 add some attribute
+ DEALLOCATE(tl_var)
+
+ ! add some attribute
tl_att=att_init("Created_by","SIREN create_bathy")
CALL file_add_att(tl_fileout, tl_att)
@@ -447,5 +574,5 @@
il_attid=0
IF( ASSOCIATED(tl_fileout%t_att) )THEN
- il_attid=att_get_id(tl_fileout%t_att(:),'periodicity')
+ il_attid=att_get_index(tl_fileout%t_att(:),'periodicity')
ENDIF
IF( tl_coord1%i_perio >= 0 .AND. il_attid == 0 )THEN
@@ -454,7 +581,8 @@
ENDIF
+ ! add attribute east west overlap
il_attid=0
IF( ASSOCIATED(tl_fileout%t_att) )THEN
- il_attid=att_get_id(tl_fileout%t_att(:),'ew_overlap')
+ il_attid=att_get_index(tl_fileout%t_att(:),'ew_overlap')
ENDIF
IF( tl_coord1%i_ew >= 0 .AND. il_attid == 0 )THEN
@@ -462,21 +590,20 @@
CALL file_add_att(tl_fileout,tl_att)
ENDIF
-
- !10-4 create file
+
+ ! create file
CALL iom_create(tl_fileout)
- !10-5 write file
+ ! write file
CALL iom_write_file(tl_fileout)
- !10-6 close file
+ ! close file
CALL iom_close(tl_fileout)
- IF( cn_coord0 /= '' ) CALL iom_close(tl_coord0)
-
- !11- clean
- DEALLOCATE(tl_var)
+
+ ! clean
+ CALL att_clean(tl_att)
CALL file_clean(tl_fileout)
- CALL file_clean(tl_coord1)
- CALL file_clean(tl_coord0)
+ CALL mpp_clean(tl_coord1)
+ CALL mpp_clean(tl_coord0)
! close log file
@@ -484,23 +611,27 @@
CALL logger_close()
-!> @endcode
CONTAINS
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This function create variable, filled with matrix value
!>
!> @details
+ !> A variable is create with the same name that the input variable,
+ !> and with dimension of the coordinate file.
+ !> Then the variable array of value is split into equal subdomain.
+ !> Each subdomain is filled with the corresponding value of the matrix.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!>
- !> @param[in]
+ !> @param[in] td_var variable structure
+ !> @param[in] td_coord coordinate file structure
+ !> @return variable structure
!-------------------------------------------------------------------
- !> @code
FUNCTION create_bathy_matrix(td_var, td_coord)
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(IN) :: td_var
- TYPE(TFILE), INTENT(IN) :: td_coord
+ TYPE(TVAR), INTENT(IN) :: td_var
+ TYPE(TMPP), INTENT(IN) :: td_coord
! function
@@ -508,7 +639,5 @@
! local variable
- INTEGER(i4) :: il_ighost
- INTEGER(i4) :: il_jghost
- INTEGER(i4) , DIMENSION(2) :: il_xghost
+ INTEGER(i4) , DIMENSION(2,2) :: il_xghost
INTEGER(i4) , DIMENSION(3) :: il_dim
INTEGER(i4) , DIMENSION(3) :: il_size
@@ -522,7 +651,7 @@
TYPE(TVAR) :: tl_lon
- TYPE(TVAR) :: tl_lat
- TYPE(TVAR) :: tl_var
TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
+
+ TYPE(TMPP) :: tl_coord
! loop indices
@@ -532,25 +661,36 @@
!----------------------------------------------------------------
- !1- read output grid
- tl_lon=iom_read_var(td_coord,'longitude')
- tl_lat=iom_read_var(td_coord,'latitude')
-
- !2- look for ghost cell
- il_xghost(:)=grid_get_ghost( tl_lon, tl_lat )
-
- il_ighost=il_xghost(1)*ig_ghost
- il_jghost=il_xghost(2)*ig_ghost
-
- !3- write value on grid
- !3-1 get matrix dimension
+ ! copy structure
+ tl_coord=mpp_copy(td_coord)
+
+ ! use only edge processor
+ CALL mpp_get_contour(tl_coord)
+
+ ! open useful processor
+ CALL iom_mpp_open(tl_coord)
+
+ ! read output grid
+ tl_lon=iom_mpp_read_var(tl_coord,'longitude')
+
+ ! look for ghost cell
+ il_xghost(:,:)=grid_get_ghost( tl_coord )
+
+ ! close processor
+ CALL iom_mpp_close(tl_coord)
+ ! clean
+ CALL mpp_clean(tl_coord)
+
+ ! remove ghost cell
+ CALL grid_del_ghost(tl_lon, il_xghost(:,:))
+
+ ! write value on grid
+ ! get matrix dimension
il_dim(:)=td_var%t_dim(1:3)%i_len
- !3-2 output dimension
- tl_dim(:)=tl_lon%t_dim(:)
-
- ! remove ghost cell
- tl_dim(1)%i_len=tl_dim(1)%i_len - 2*il_xghost(1)*ig_ghost
- tl_dim(2)%i_len=tl_dim(2)%i_len - 2*il_xghost(2)*ig_ghost
-
- !3-3 split output domain in N subdomain depending of matrix dimension
+ ! output dimension
+ tl_dim(:)=dim_copy(tl_lon%t_dim(:))
+ ! clean
+ CALL var_clean(tl_lon)
+
+ ! split output domain in N subdomain depending of matrix dimension
il_size(:) = tl_dim(1:3)%i_len / il_dim(:)
il_rest(:) = MOD(tl_dim(1:3)%i_len, il_dim(:))
@@ -563,5 +703,4 @@
! add rest to last cell
il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1)
-
ALLOCATE( il_jshape(il_dim(2)+1) )
@@ -581,5 +720,5 @@
il_kshape(il_dim(3)+1)=il_kshape(il_dim(3)+1)+il_rest(3)
- !3-3 write ouput table of value
+ ! write ouput array of value
ALLOCATE(dl_value( tl_dim(1)%i_len, &
& tl_dim(2)%i_len, &
@@ -602,36 +741,36 @@
ENDDO
- !3-4 initialise variable with value
- tl_var=var_init(TRIM(td_var%c_name),dl_value(:,:,:,:))
+ ! initialise variable with value
+ create_bathy_matrix=var_init(TRIM(td_var%c_name),dl_value(:,:,:,:))
DEALLOCATE(dl_value)
- !4- add ghost cell
- CALL grid_add_ghost(tl_var,il_ighost,il_jghost)
-
- !5- save result
- create_bathy_matrix=tl_var
+ ! add ghost cell
+ CALL grid_add_ghost(create_bathy_matrix, il_xghost(:,:))
+
+ ! clean
+ CALL dim_clean(tl_dim(:))
END FUNCTION create_bathy_matrix
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This function extract variable from file over coordinate domain and
+ !> return variable structure
!>
- !> @details
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
!>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !> @param[in]
+ !> @param[in] td_var variable structure
+ !> @param[in] td_mpp mpp file structure
+ !> @param[in] td_coord coordinate file structure
+ !> @return variable structure
!-------------------------------------------------------------------
- !> @code
- FUNCTION create_bathy_extract(td_var, td_file, &
+ FUNCTION create_bathy_extract(td_var, td_mpp, &
& td_coord)
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(IN) :: td_var
- TYPE(TFILE), INTENT(IN) :: td_file
- TYPE(TFILE), INTENT(IN) :: td_coord
+ TYPE(TVAR), INTENT(IN) :: td_var
+ TYPE(TMPP), INTENT(IN) :: td_mpp
+ TYPE(TMPP), INTENT(IN) :: td_coord
! function
@@ -639,8 +778,5 @@
! local variable
- INTEGER(i4), DIMENSION(2,2,2) :: il_ind
-
- INTEGER(i4) :: il_pivot
- INTEGER(i4) :: il_perio
+ INTEGER(i4), DIMENSION(2,2) :: il_ind
INTEGER(i4) :: il_imin
@@ -648,6 +784,4 @@
INTEGER(i4) :: il_imax
INTEGER(i4) :: il_jmax
-
- TYPE(TFILE) :: tl_file
TYPE(TMPP) :: tl_mpp
@@ -661,67 +795,42 @@
!----------------------------------------------------------------
- IF( td_file%i_id == 0 )THEN
- CALL logger_error("CREATE BATHY EXTRACT: file "//&
- & TRIM(td_file%c_name)//" not opened ")
+ IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
+ CALL logger_error("CREATE BATHY EXTRACT: no processor associated "//&
+ & "to mpp "//TRIM(td_mpp%c_name))
ELSE
!init
- tl_file=td_file
-
- !1- open file
- CALL iom_open(tl_file)
-
- ! get periodicity
- il_pivot=grid_get_pivot(tl_file)
- il_perio=grid_get_perio(tl_file,il_pivot)
-
- tl_file%i_perio=il_perio
-
- !2- compute file grid indices around coord grid
- il_ind(:,:,:)=grid_get_coarse_index(tl_file, td_coord )
-
- il_imin=il_ind(1,1,1) ; il_imax=il_ind(1,2,1)
- il_jmin=il_ind(2,1,1) ; il_jmax=il_ind(2,2,1)
-
- IF( ANY( il_ind(:,:,2) /= 0 ) )THEN
- CALL logger_error("CREATE BATHY EXTRACT: something wrong "//&
- & " find offset when extracting data")
- ENDIF
- !3- check grid coincidence
- CALL grid_check_coincidence( tl_file, td_coord, &
+ tl_mpp=mpp_copy(td_mpp)
+
+ ! compute file grid indices around coord grid
+ il_ind(:,:)=grid_get_coarse_index(tl_mpp, td_coord )
+
+ il_imin=il_ind(1,1) ; il_imax=il_ind(1,2)
+ il_jmin=il_ind(2,1) ; il_jmax=il_ind(2,2)
+
+ ! check grid coincidence
+ CALL grid_check_coincidence( tl_mpp, td_coord, &
& il_imin, il_imax, &
& il_jmin, il_jmax, &
& (/1, 1, 1/) )
- !4- compute domain
- tl_dom=dom_init(tl_file, &
+ ! compute domain
+ tl_dom=dom_init(tl_mpp, &
& il_imin, il_imax, &
& il_jmin, il_jmax)
- ! close file
- CALL iom_close(tl_file)
-
- !5- read bathymetry on domain (ugly way to do it, have to work on it)
- !5-1 init mpp structure
- tl_mpp=mpp_init(tl_file)
-
- CALL file_clean(tl_file)
-
- !5-2 get processor to be used
- CALL mpp_get_use( tl_mpp, tl_dom )
-
- !5-3 open mpp files
- CALL iom_mpp_open(tl_mpp)
-
- !5-4 read variable on domain
- tl_var=iom_mpp_read_var(tl_mpp,TRIM(td_var%c_name),td_dom=tl_dom)
-
- !5-5 close mpp file
- CALL iom_mpp_close(tl_mpp)
-
- !6- add ghost cell
- CALL grid_add_ghost(tl_var,tl_dom%i_ighost,tl_dom%i_jghost)
-
- !7- check result
+ ! open mpp files over domain
+ CALL iom_dom_open(tl_mpp, tl_dom)
+
+ ! read variable on domain
+ tl_var=iom_dom_read_var(tl_mpp,TRIM(td_var%c_name),tl_dom)
+
+ ! close mpp file
+ CALL iom_dom_close(tl_mpp)
+
+ ! add ghost cell
+ CALL grid_add_ghost(tl_var,tl_dom%i_ghost(:,:))
+
+ ! check result
IF( ANY( tl_var%t_dim(:)%l_use .AND. &
& tl_var%t_dim(:)%i_len /= td_coord%t_dim(:)%i_len) )THEN
@@ -743,18 +852,19 @@
ENDIF
- !8- add attribute to variable
+ ! add attribute to variable
tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
CALL var_move_att(tl_var, tl_att)
- tl_att=att_init('src_i-indices',(/tl_dom%i_imin, tl_dom%i_imax/))
+ tl_att=att_init('src_i_indices',(/tl_dom%i_imin, tl_dom%i_imax/))
CALL var_move_att(tl_var, tl_att)
- tl_att=att_init('src_j-indices',(/tl_dom%i_jmin, tl_dom%i_jmax/))
+ tl_att=att_init('src_j_indices',(/tl_dom%i_jmin, tl_dom%i_jmax/))
CALL var_move_att(tl_var, tl_att)
- !9- save result
- create_bathy_extract=tl_var
+ ! save result
+ create_bathy_extract=var_copy(tl_var)
! clean structure
+ CALL att_clean(tl_att)
CALL var_clean(tl_var)
CALL mpp_clean(tl_mpp)
@@ -762,24 +872,23 @@
END FUNCTION create_bathy_extract
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This function get coarse grid variable, interpolate variable, and return
+ !> variable structure over fine grid
!>
- !> @details
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
!>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !> @param[in] td_var : variable structure
- !> @param[in] td_file : file structure
- !> @param[in] id_imin : i-direction lower left corner indice
- !> @param[in] id_imax : i-direction upper right corner indice
- !> @param[in] id_jmin : j-direction lower left corner indice
- !> @param[in] id_jmax : j-direction upper right corner indice
- !> @param[in] id_rho : table of refinement factor
+ !> @param[in] td_var variable structure
+ !> @param[in] td_mpp mpp file structure
+ !> @param[in] id_imin i-direction lower left corner indice
+ !> @param[in] id_imax i-direction upper right corner indice
+ !> @param[in] id_jmin j-direction lower left corner indice
+ !> @param[in] id_jmax j-direction upper right corner indice
+ !> @param[in] id_offset offset between fine grid and coarse grid
+ !> @param[in] id_rho array of refinement factor
+ !> @return variable structure
!-------------------------------------------------------------------
- !> @code
- FUNCTION create_bathy_get_var(td_var, td_file, &
+ FUNCTION create_bathy_get_var(td_var, td_mpp, &
& id_imin, id_jmin, &
& id_imax, id_jmax, &
@@ -789,5 +898,5 @@
! Argument
TYPE(TVAR) , INTENT(IN) :: td_var
- TYPE(TFILE), INTENT(IN) :: td_file
+ TYPE(TMPP) , INTENT(IN) :: td_mpp
INTEGER(i4), INTENT(IN) :: id_imin
INTEGER(i4), INTENT(IN) :: id_imax
@@ -801,107 +910,91 @@
! local variable
- INTEGER(i4) :: il_pivot
- INTEGER(i4) :: il_perio
-
- TYPE(TFILE) :: tl_file
-
TYPE(TMPP) :: tl_mpp
-
TYPE(TATT) :: tl_att
-
TYPE(TVAR) :: tl_var
-
TYPE(TDOM) :: tl_dom
+
+ INTEGER(i4) :: il_size
+ INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho
! loop indices
!----------------------------------------------------------------
IF( ANY(SHAPE(id_offset(:,:)) /= 2) )THEN
- CALL logger_error("CREATE BATHY GET VAR: invalid dimensio of "//&
- & "offset table")
+ CALL logger_error("CREATE BATHY GET VAR: invalid dimension of "//&
+ & "offset array")
ENDIF
- !init
- tl_file=td_file
-
- !1- open file
- CALL iom_open(tl_file)
-
- ! get periodicity
- il_pivot=grid_get_pivot(tl_file)
- il_perio=grid_get_perio(tl_file,il_pivot)
-
- tl_file%i_perio=il_perio
-
- !2- compute domain
- tl_dom=dom_init(tl_file, &
+ ! copy structure
+ tl_mpp=mpp_copy(td_mpp)
+
+ !- compute domain
+ tl_dom=dom_init(tl_mpp, &
& id_imin, id_imax, &
& id_jmin, id_jmax)
- CALL dom_print(tl_dom)
- print *,'id_offset ',id_offset(:,:)
- !3- close file
- CALL iom_close(tl_file)
-
- !4- add extra band (if possible) to compute interpolation
+ !- add extra band (if possible) to compute interpolation
CALL dom_add_extra(tl_dom)
- !5- read bathymetry on domain (ugly way to do it, have to work on it)
- !5-1 init mpp sturcutre
- tl_mpp=mpp_init(tl_file)
-
- CALL file_clean(tl_file)
-
- !5-2 get processor to be used
- CALL mpp_get_use( tl_mpp, tl_dom )
-
- !5-3 open mpp files
- CALL iom_mpp_open(tl_mpp)
-
- !5-4 read variable value on domain
- tl_var=iom_mpp_read_var(tl_mpp,TRIM(td_var%c_name),td_dom=tl_dom)
-
- !5-5 close mpp files
- CALL iom_mpp_close(tl_mpp)
-
- !6- interpolate variable
- CALL create_bathy_interp(tl_var, id_rho(:), id_offset(:,:))
-
- !7- remove extraband added to domain
- CALL dom_del_extra( tl_var, tl_dom, id_rho(:) )
-
- !8- add ghost cell
- CALL grid_add_ghost(tl_var,tl_dom%i_ighost,tl_dom%i_jghost)
+ !- open mpp files over domain
+ CALL iom_dom_open(tl_mpp, tl_dom)
+
+ !- read variable value on domain
+ tl_var=iom_dom_read_var(tl_mpp,TRIM(td_var%c_name),tl_dom)
+
+ !- close mpp files
+ CALL iom_dom_close(tl_mpp)
+
+ il_size=SIZE(id_rho(:))
+ ALLOCATE( il_rho(il_size) )
+ il_rho(:)=id_rho(:)
+
+ !- interpolate variable
+ CALL create_bathy_interp(tl_var, il_rho(:), id_offset(:,:))
+
+ !- remove extraband added to domain
+ CALL dom_del_extra( tl_var, tl_dom, il_rho(:) )
+
+ !- add ghost cell
+ CALL grid_add_ghost(tl_var,tl_dom%i_ghost(:,:))
- !9- add attribute to variable
+ !- add attribute to variable
tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
CALL var_move_att(tl_var, tl_att)
- tl_att=att_init('src_i-indices',(/tl_dom%i_imin, tl_dom%i_imax/))
+ tl_att=att_init('src_i_indices',(/tl_dom%i_imin, tl_dom%i_imax/))
CALL var_move_att(tl_var, tl_att)
- tl_att=att_init('src_j-indices',(/tl_dom%i_jmin, tl_dom%i_jmax/))
+ tl_att=att_init('src_j_indices',(/tl_dom%i_jmin, tl_dom%i_jmax/))
CALL var_move_att(tl_var, tl_att)
- !10- save result
- create_bathy_get_var=tl_var
-
- !11- clean structure
+ IF( .NOT. ALL(id_rho(:)==1) )THEN
+ tl_att=att_init("refinment_factor",(/id_rho(jp_I),id_rho(jp_J)/))
+ CALL var_move_att(tl_var, tl_att)
+ ENDIF
+
+ DEALLOCATE( il_rho )
+
+ !- save result
+ create_bathy_get_var=var_copy(tl_var)
+
+ !- clean structure
+ CALL att_clean(tl_att)
+ CALL var_clean(tl_var)
CALL mpp_clean(tl_mpp)
END FUNCTION create_bathy_get_var
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This subroutine interpolate variable
!>
- !> @details
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
!>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !> @param[in]
- !> @todo
+ !> @param[inout] td_var variable structure
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] id_offset array of offset between fine and coarse grid
+ !> @param[in] id_iext i-direction size of extra bands (default=im_minext)
+ !> @param[in] id_jext j-direction size of extra bands (default=im_minext)
!-------------------------------------------------------------------
- !> @code
SUBROUTINE create_bathy_interp( td_var, &
& id_rho, &
@@ -919,5 +1012,4 @@
! local variable
- TYPE(TVAR) :: tl_var
TYPE(TVAR) :: tl_mask
@@ -929,7 +1021,4 @@
! loop indices
!----------------------------------------------------------------
-
- ! copy variable
- tl_var=td_var
!WARNING: two extrabands are required for cubic interpolation
@@ -952,60 +1041,55 @@
ENDIF
- !1- work on mask
- !1-1 create mask
- ALLOCATE(bl_mask(tl_var%t_dim(1)%i_len, &
- & tl_var%t_dim(2)%i_len, &
- & tl_var%t_dim(3)%i_len, &
- & tl_var%t_dim(4)%i_len) )
+ ! work on mask
+ ! create mask
+ ALLOCATE(bl_mask(td_var%t_dim(1)%i_len, &
+ & td_var%t_dim(2)%i_len, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len) )
bl_mask(:,:,:,:)=1
- WHERE(tl_var%d_value(:,:,:,:)==tl_var%d_fill) bl_mask(:,:,:,:)=0
-
- SELECT CASE(TRIM(tl_var%c_point))
+ WHERE(td_var%d_value(:,:,:,:)==td_var%d_fill) bl_mask(:,:,:,:)=0
+
+ SELECT CASE(TRIM(td_var%c_point))
CASE DEFAULT ! 'T'
- tl_mask=var_init('tmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
- CASE('U')
- tl_mask=var_init('umask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
- CASE('V')
- tl_mask=var_init('vmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
- CASE('F')
- tl_mask=var_init('fmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
+ tl_mask=var_init('tmask', bl_mask(:,:,:,:), td_dim=td_var%t_dim(:), &
+ & id_ew=td_var%i_ew )
+ CASE('U','V','F')
+ CALL logger_fatal("CREATE BATHY INTERP: can not computed "//&
+ & "interpolation on "//TRIM(td_var%c_point)//&
+ & " grid point (variable "//TRIM(td_var%c_name)//&
+ & "). check namelist.")
END SELECT
DEALLOCATE(bl_mask)
- !1-2 interpolate mask
+ ! interpolate mask
CALL interp_fill_value( tl_mask, id_rho(:), &
& id_offset=id_offset(:,:) )
- !2- work on variable
- !2-0 add extraband
- CALL extrap_add_extrabands(tl_var, il_iext, il_jext)
-
- !2-1 extrapolate variable
- CALL extrap_fill_value( tl_var, id_offset=id_offset(:,:), &
+ ! work on variable
+ ! add extraband
+ CALL extrap_add_extrabands(td_var, il_iext, il_jext)
+
+ ! extrapolate variable
+ CALL extrap_fill_value( td_var, id_offset=id_offset(:,:), &
& id_rho=id_rho(:), &
& id_iext=il_iext, id_jext=il_jext )
- !2-2 interpolate Bathymetry
- CALL interp_fill_value( tl_var, id_rho(:), &
+ ! interpolate Bathymetry
+ CALL interp_fill_value( td_var, id_rho(:), &
& id_offset=id_offset(:,:) )
- !2-3 remove extraband
- CALL extrap_del_extrabands(tl_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
-
- !2-2-5 keep original mask
+ ! remove extraband
+ CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
+
+ ! keep original mask
WHERE( tl_mask%d_value(:,:,:,:) == 0 )
- tl_var%d_value(:,:,:,:)=tl_var%d_fill
+ td_var%d_value(:,:,:,:)=td_var%d_fill
END WHERE
-
- !3- save result
- td_var=tl_var
! clean variable structure
CALL var_clean(tl_mask)
- CALL var_clean(tl_var)
END SUBROUTINE create_bathy_interp
- !> @endcode
END PROGRAM create_bathy
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_boundary.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_boundary.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_boundary.f90 (revision 5214)
@@ -7,21 +7,170 @@
!
! DESCRIPTION:
+!> @file
!> @brief
!> This program create boundary files.
!>
!> @details
-!> Variables are read from standard output.
-!> Then theses variables are interpolated on fine grid boundaries.
-!>
-!> @author
-!> J.Paul
+!> @section sec1 method
+!> Variables are read from coarse grid standard output
+!> and interpolated on fine grid or manually written.
+!> @note
+!> method could be different for each variable.
+!>
+!> @section sec2 how to
+!> to create boundaries files:
+!> @code{.sh}
+!> ./SIREN/bin/create_boundary create_boundary.nam
+!> @endcode
+!>
+!> create_boundary.nam comprise 9 namelists:
+!> - logger namelist (namlog)
+!> - config namelist (namcfg)
+!> - coarse grid namelist (namcrs)
+!> - fine grid namelist (namfin)
+!> - variable namelist (namvar)
+!> - nesting namelist (namnst)
+!> - boundary namelist (nambdy)
+!> - vertical grid namelist (namzgr)
+!> - output namelist (namout)
+!>
+!> @note
+!> All namelists have to be in file create_boundary.nam,
+!> however variables of those namelists are all optional.
+!>
+!> * _logger namelist (namlog)_:
+!> - cn_logfile : log filename
+!> - cn_verbosity : verbosity ('trace','debug','info',
+!> 'warning','error','fatal')
+!> - in_maxerror : maximum number of error allowed
+!>
+!> * _config namelist (namcfg)_:
+!> - cn_varcfg : variable configuration file
+!> (see ./SIREN/cfg/variable.cfg)
+!>
+!> * _coarse grid namelist (namcrs)_:
+!> - cn_coord0 : coordinate file
+!> - in_perio0 : NEMO periodicity index (see Model Boundary Condition in
+!> [NEMO documentation](http://www.nemo-ocean.eu/About-NEMO/Reference-manuals))
+!>
+!> * _fine grid namelist (namfin)_:
+!> - cn_coord1 : coordinate file
+!> - cn_bathy1 : bathymetry file
+!> - in_perio1 : periodicity index
+!>
+!> * _vertical grid namelist (namzgr)_:
+!> - dn_pp_to_be_computed :
+!> - dn_ppsur :
+!> - dn_ppa0 :
+!> - dn_ppa1 :
+!> - dn_ppa2 :
+!> - dn_ppkth :
+!> - dn_ppkth2 :
+!> - dn_ppacr :
+!> - dn_ppacr2 :
+!> - dn_ppdzmin :
+!> - dn_pphmax :
+!> - in_nlevel : number of vertical level
+!>
+!> * _partial step namelist (namzps)_:
+!> - dn_e3zps_mi :
+!> - dn_e3zps_rat :
+!>
+!> * _variable namelist (namvar)_:
+!> - cn_varinfo : list of variable and extra information about request(s)
+!> to be used.
+!> each elements of *cn_varinfo* is a string character.
+!> it is composed of the variable name follow by ':',
+!> then request(s) to be used on this variable.
+!> request could be:
+!> - interpolation method
+!> - extrapolation method
+!> - filter method
+!>
+!> requests must be separated by ';'.
+!> order of requests does not matter.
+!>
+!> informations about available method could be find in @ref interp,
+!> @ref extrap and @ref filter.
+!>
+!> Example: 'votemper:linear;hann;dist_weight', 'vosaline:cubic'
+!> @note
+!> If you do not specify a method which is required,
+!> default one is apply.
+!> - cn_varfile : list of variable, and corresponding file
+!> *cn_varfile* is the path and filename of the file where find
+!> variable.
+!> @note
+!> *cn_varfile* could be a matrix of value, if you want to filled
+!> manually variable value.
+!> the variable array of value is split into equal subdomain.
+!> Each subdomain is filled with the corresponding value
+!> of the matrix.
+!> separators used to defined matrix are:
+!> - ',' for line
+!> - '/' for row
+!> - '\' for level
+!> Example:
+!> 3,2,3/1,4,5 => @f$ \left( \begin{array}{ccc}
+!> 3 & 2 & 3 \\
+!> 1 & 4 & 5 \end{array} \right) @f$
+!> @warning
+!> the same matrix is used for all boundaries.
+!>
+!> Examples:
+!> - 'votemper:gridT.nc', 'vozocrtx:gridU.nc'
+!> - 'votemper:10\25', 'vozocrtx:gridU.nc'
+!>
+!> * _nesting namelist (namnst)_:
+!> - in_rhoi : refinement factor in i-direction
+!> - in_rhoj : refinement factor in j-direction
+!>
+!> * _boundary namelist (nambdy)_:
+!> - ln_north : use north boundary
+!> - ln_south : use south boundary
+!> - ln_east : use east boundary
+!> - ln_west : use west boundary
+!> - cn_north : north boundary indices on fine grid
+!> *cn_north* is a string character defining boundary
+!> segmentation.
+!> segments are separated by '|'.
+!> each segments of the boundary is composed of:
+!> - orthogonal indice (.ie. for north boundary,
+!> J-indice where boundary are).
+!> - first indice of boundary (I-indice for north boundary)
+!> - last indice of boundary (I-indice for north boundary)
+!> indices must be separated by ',' .
+!> - optionally, boundary size could be added between '(' and ')'
+!> in the first segment defined.
+!> @note
+!> boundary width is the same for all segments of one boundary.
+!>
+!> Examples:
+!> - cn_north='index1,first1,last1(width)'
+!> - cn_north='index1(width),first1,last1|index2,first2,last2'
+!>
+!> \image html boundary_50.png
+!> \image latex boundary_50.png
+!>
+!> - cn_south : south boundary indices on fine grid
+!> - cn_east : east boundary indices on fine grid
+!> - cn_west : west boundary indices on fine grid
+!> - ln_oneseg : use only one segment for each boundary or not
+!> - in_extrap : number of mask point to be extrapolated
+!>
+!> * _output namelist (namout)_:
+!> - cn_fileout : fine grid boundary basename
+!> (cardinal and segment number will be automatically added)
+!>
+!> @author J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
+!> @date November, 2013 - Initial Version
+!> @date September, 2014
+!> - add header for user
+!> - take into account grid point to compue boundaries
+!> - reorder output dimension for north and south boundaries
+!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!>
-!> @todo
!----------------------------------------------------------------------
-!> @code
PROGRAM create_boundary
@@ -57,9 +206,11 @@
CHARACTER(LEN=lc) :: cl_bdyout
CHARACTER(LEN=lc) :: cl_data
+ CHARACTER(LEN=lc) :: cl_dimorder
+ CHARACTER(LEN=lc) :: cl_point
+ CHARACTER(LEN=lc) :: cl_fmt
INTEGER(i4) :: il_narg
INTEGER(i4) :: il_status
INTEGER(i4) :: il_fileid
- INTEGER(i4) :: il_attid
INTEGER(i4) :: il_dim
INTEGER(i4) :: il_imin0
@@ -67,35 +218,23 @@
INTEGER(i4) :: il_jmin0
INTEGER(i4) :: il_jmax0
+ INTEGER(i4) :: il_shift
INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho
INTEGER(i4) , DIMENSION(2,2) :: il_offset
- INTEGER(i4) , DIMENSION(2,2,2) :: il_ind
+ INTEGER(i4) , DIMENSION(2,2) :: il_ind
LOGICAL :: ll_exist
-
- TYPE(TFILE) :: tl_coord0
- TYPE(TFILE) :: tl_bathy0
- TYPE(TFILE) :: tl_coord1
- TYPE(TFILE) :: tl_bathy1
- TYPE(TFILE) :: tl_file
- TYPE(TFILE) :: tl_fileout
-
- TYPE(TMPP) :: tl_mpp
-
- TYPE(TMULTI) :: tl_multi
TYPE(TATT) :: tl_att
+ TYPE(TVAR) :: tl_depth
+ TYPE(TVAR) :: tl_time
+ TYPE(TVAR) :: tl_var1
+ TYPE(TVAR) :: tl_var0
+ TYPE(TVAR) :: tl_lon1
+ TYPE(TVAR) :: tl_lat1
+ TYPE(TVAR) :: tl_lvl1
TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_level
TYPE(TVAR) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_seglvl1
- TYPE(TVAR) :: tl_var1
TYPE(TVAR) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_segvar1
- TYPE(TVAR) , DIMENSION(:,:) , ALLOCATABLE :: tl_seglon1
- TYPE(TVAR) , DIMENSION(:,:) , ALLOCATABLE :: tl_seglat1
- TYPE(TVAR) , DIMENSION(:,:) , ALLOCATABLE :: tl_var
- TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_lon1
- TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_lat1
- TYPE(TVAR) :: tl_depth
- TYPE(TVAR) :: tl_time
- TYPE(TVAR) :: tl_tmp
TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
@@ -104,8 +243,19 @@
TYPE(TDOM) :: tl_dom0
- TYPE(TDOM) , DIMENSION(:,:) , ALLOCATABLE :: tl_segdom1
+ TYPE(TDOM) :: tl_dom1
+ TYPE(TDOM) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_segdom1
+
+ TYPE(TFILE) :: tl_fileout
+
+ TYPE(TMPP) :: tl_coord0
+ TYPE(TMPP) :: tl_coord1
+ TYPE(TMPP) :: tl_bathy1
+ TYPE(TMPP) :: tl_mpp
+
+ TYPE(TMULTI) :: tl_multi
! loop indices
INTEGER(i4) :: jvar
+ INTEGER(i4) :: jpoint
INTEGER(i4) :: ji
INTEGER(i4) :: jj
@@ -117,4 +267,8 @@
CHARACTER(LEN=lc) :: cn_logfile = 'create_boundary.log'
CHARACTER(LEN=lc) :: cn_verbosity = 'warning'
+ INTEGER(i4) :: in_maxerror = 5
+
+ ! namcfg
+ CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg'
! namcrs
@@ -127,18 +281,14 @@
INTEGER(i4) :: in_perio1 = -1
- ! namcfg
- CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg'
+ !namzgr
+ INTEGER(i4) :: in_nlevel = 75
! namvar
- CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varinfo = ''
- CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varfile = ''
+ CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''
+ CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''
! namnst
- INTEGER(i4) :: in_imin0 = 0
- INTEGER(i4) :: in_imax0 = 0
- INTEGER(i4) :: in_jmin0 = 0
- INTEGER(i4) :: in_jmax0 = 0
- INTEGER(i4) :: in_rhoi = 1
- INTEGER(i4) :: in_rhoj = 1
+ INTEGER(i4) :: in_rhoi = 0
+ INTEGER(i4) :: in_rhoj = 0
! nambdy
@@ -160,5 +310,6 @@
NAMELIST /namlog/ & !< logger namelist
& cn_logfile, & !< log file
- & cn_verbosity !< log verbosity
+ & cn_verbosity, & !< log verbosity
+ & in_maxerror
NAMELIST /namcfg/ & !< config namelist
@@ -174,4 +325,7 @@
& in_perio1 !< periodicity index
+ NAMELIST /namzgr/ &
+ & in_nlevel
+
NAMELIST /namvar/ & !< variable namelist
& cn_varinfo, & !< list of variable and method to apply on. (ex: 'votemper:linear','vosaline:cubic' )
@@ -179,8 +333,4 @@
NAMELIST /namnst/ & !< nesting namelist
- & in_imin0, & !< i-direction lower left point indice on coarse grid
- & in_imax0, & !< i-direction upper right point indice on coarse grid
- & in_jmin0, & !< j-direction lower left point indice on coarse grid
- & in_jmax0, & !< j-direction upper right point indice on coarse grid
& in_rhoi, & !< refinement factor in i-direction
& in_rhoj !< refinement factor in j-direction
@@ -196,5 +346,5 @@
& cn_west , & !< west boundary indices on fine grid
& ln_oneseg, & !< use only one segment for each boundary or not
- & in_extrap !< number of mask point to extrapolate
+ & in_extrap !< number of mask point to be extrapolated
NAMELIST /namout/ & !< output namelist
@@ -202,6 +352,6 @@
!-------------------------------------------------------------------
- !1- namelist
- !1-1 get namelist
+ ! namelist
+ ! get namelist
il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
IF( il_narg/=1 )THEN
@@ -212,5 +362,5 @@
ENDIF
- !1-2 read namelist
+ ! read namelist
INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist)
IF( ll_exist )THEN
@@ -231,23 +381,23 @@
READ( il_fileid, NML = namlog )
- !1-2-1 define log file
- CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity))
+ ! define log file
+ CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror)
CALL logger_header()
READ( il_fileid, NML = namcfg )
- !1-2-2 get variable extra information
+ ! get variable extra information
CALL var_def_extra(TRIM(cn_varcfg))
READ( il_fileid, NML = namcrs )
READ( il_fileid, NML = namfin )
+ READ( il_fileid, NML = namzgr )
READ( il_fileid, NML = namvar )
- !1-2-3 add user change in extra information
+ ! add user change in extra information
CALL var_chg_extra(cn_varinfo)
- !1-2-4 match variable with file
+ ! match variable with file
tl_multi=multi_init(cn_varfile)
READ( il_fileid, NML = namnst )
READ( il_fileid, NML = nambdy )
-
READ( il_fileid, NML = namout )
@@ -261,11 +411,18 @@
PRINT *,"CREATE BOUNDARY: ERROR. can not find "//TRIM(cl_namelist)
+ STOP
ENDIF
- !2- open files
+ CALL multi_print(tl_multi)
+ IF( tl_multi%i_nvar <= 0 )THEN
+ CALL logger_fatal("CREATE BOUNDARY: no variable to be used."//&
+ & " check namelist.")
+ ENDIF
+
+ ! open files
IF( TRIM(cn_coord0) /= '' )THEN
- tl_coord0=file_init(TRIM(cn_coord0),id_perio=in_perio0)
- CALL iom_open(tl_coord0)
+ tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0)
+ CALL grid_get_info(tl_coord0)
ELSE
CALL logger_fatal("CREATE BOUNDARY: can not find coarse grid "//&
@@ -274,6 +431,6 @@
IF( TRIM(cn_coord1) /= '' )THEN
- tl_coord1=file_init(TRIM(cn_coord1),id_perio=in_perio1)
- CALL iom_open(tl_coord1)
+ tl_coord1=mpp_init( file_init(TRIM(cn_coord1)), id_perio=in_perio1)
+ CALL grid_get_info(tl_coord1)
ELSE
CALL logger_fatal("CREATE BOUNDARY: can not find fine grid coordinate "//&
@@ -282,6 +439,6 @@
IF( TRIM(cn_bathy1) /= '' )THEN
- tl_bathy1=file_init(TRIM(cn_bathy1),id_perio=in_perio1)
- CALL iom_open(tl_bathy1)
+ tl_bathy1=mpp_init( file_init(TRIM(cn_bathy1)), id_perio=in_perio1)
+ CALL grid_get_info(tl_bathy1)
ELSE
CALL logger_fatal("CREATE BOUNDARY: can not find fine grid bathymetry "//&
@@ -289,9 +446,9 @@
ENDIF
- !3- check
- !3-1 check output file do not already exist
+ ! check
+ ! check output file do not already exist
DO jk=1,ip_ncard
cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
- & TRIM(ip_card(jk)) )
+ & TRIM(cp_card(jk)), 1 )
INQUIRE(FILE=TRIM(cl_bdyout), EXIST=ll_exist)
IF( ll_exist )THEN
@@ -301,6 +458,6 @@
ENDDO
- !3-1 check namelist
- !3-1-1 check refinement factor
+ ! check namelist
+ ! check refinement factor
il_rho(:)=1
IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN
@@ -312,20 +469,16 @@
ENDIF
- !3-1-2
- IF( in_imin0 < 1 .OR. in_imax0 < 1 .OR. in_jmin0 < 1 .OR. in_jmax0 < 1)THEN
- ! compute coarse grid indices around fine grid
- il_ind(:,:,:)=grid_get_coarse_index(tl_bathy0, tl_bathy1 )
-
- il_imin0=il_ind(1,1,1) ; il_imax0=il_ind(1,2,1)
- il_jmin0=il_ind(2,1,1) ; il_jmax0=il_ind(2,2,1)
- ELSE
- il_imin0=in_imin0 ; il_imax0=in_imax0
- il_jmin0=in_jmin0 ; il_jmax0=in_jmax0
- ENDIF
-
- !3-2 check domain validity
+ !
+ ! compute coarse grid indices around fine grid
+ il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1, &
+ & id_rho=il_rho(:))
+
+ il_imin0=il_ind(1,1) ; il_imax0=il_ind(1,2)
+ il_jmin0=il_ind(2,1) ; il_jmax0=il_ind(2,2)
+
+ ! check domain validity
CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0)
- !3-3 check coordinate file
+ ! check coordinate file
CALL grid_check_coincidence( tl_coord0, tl_coord1, &
& il_imin0, il_imax0, &
@@ -333,6 +486,12 @@
& il_rho(:) )
- !4- read or compute boundary
- tl_var1=iom_read_var(tl_bathy1,'Bathymetry')
+ ! read or compute boundary
+ CALL mpp_get_contour(tl_bathy1)
+
+ CALL iom_mpp_open(tl_bathy1)
+
+ tl_var1=iom_mpp_read_var(tl_bathy1,'Bathymetry')
+
+ CALL iom_mpp_close(tl_bathy1)
tl_bdy(:)=boundary_init(tl_var1, ln_north, ln_south, ln_east, ln_west, &
@@ -342,25 +501,30 @@
CALL var_clean(tl_var1)
- !5- compute level
- ALLOCATE(tl_level(ig_npoint))
+ ! compute level
+ ALLOCATE(tl_level(ip_npoint))
tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist )
- !6- get coordinate on each segment of each boundary
- ALLOCATE( tl_seglon1(ip_ncard,ig_maxseg) )
- ALLOCATE( tl_seglat1(ip_ncard,ig_maxseg) )
- ALLOCATE( tl_segdom1(ip_ncard,ig_maxseg) )
- ALLOCATE( tl_segvar1(tl_multi%i_nvar,ip_ncard,ig_maxseg) )
- ALLOCATE( tl_seglvl1(ip_ncard,ig_maxseg,ig_npoint) )
- DO jk=1,ip_ncard
- IF( tl_bdy(jk)%l_use )THEN
- DO jl=1,tl_bdy(jk)%i_nseg
- !6-1 get fine grid segment domain
- tl_segdom1(jk,jl)=create_boundary_get_dom( tl_bathy1, tl_bdy(jk), jl )
-
- !6-2 get fine grid segment coordinate
- CALL create_boundary_get_coord( tl_bathy1, tl_segdom1(jk,jl), &
- & tl_seglon1(jk,jl), tl_seglat1(jk,jl) )
- !6-2 get fine grid segment coordinate
- tl_seglvl1(jk,jl,:)=create_bdy_get_level(tl_level(:), tl_segdom1(jk,jl))
+ ! get coordinate on each segment of each boundary
+ ALLOCATE( tl_segdom1(ip_npoint,ip_maxseg,ip_ncard) )
+ ALLOCATE( tl_seglvl1(ip_npoint,ip_maxseg,ip_ncard) )
+
+ DO jl=1,ip_ncard
+ IF( tl_bdy(jl)%l_use )THEN
+ DO jk=1,tl_bdy(jl)%i_nseg
+
+ ! get fine grid segment domain
+ tl_segdom1(:,jk,jl)=create_boundary_get_dom( tl_bathy1, &
+ & tl_bdy(jl), jk )
+
+ ! add extra band to fine grid domain (if possible)
+ ! to avoid dimension of one and so be able to compute offset
+ DO jj=1,ip_npoint
+ CALL dom_add_extra(tl_segdom1(jj,jk,jl), &
+ & il_rho(jp_I), il_rho(jp_J))
+ ENDDO
+
+ ! get fine grid level
+ tl_seglvl1(:,jk,jl)=create_boundary_get_level( tl_level(:), &
+ tl_segdom1(:,jk,jl))
ENDDO
@@ -368,253 +532,370 @@
ENDDO
+ ! clean
+ CALL var_clean(tl_level(:))
DEALLOCATE(tl_level)
- !7- compute boundary for variable to be used (see namelist)
- IF( .NOT. ASSOCIATED(tl_multi%t_file) )THEN
+ ! clean bathy
+ CALL mpp_clean(tl_bathy1)
+
+ ALLOCATE( tl_segvar1(tl_multi%i_nvar,ip_maxseg,ip_ncard) )
+ ! compute boundary for variable to be used (see namelist)
+ IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN
CALL logger_error("CREATE BOUNDARY: no file to work on. "//&
& "check cn_varfile in namelist.")
ELSE
+
jvar=0
! for each file
- DO ji=1,tl_multi%i_nfile
- WRITE(cl_data,'(a,i2.2)') 'data_',jvar+1
-
- IF( .NOT. ASSOCIATED(tl_multi%t_file(ji)%t_var) )THEN
+ DO ji=1,tl_multi%i_nmpp
+
+ WRITE(cl_data,'(a,i2.2)') 'data-',jvar+1
+
+ IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
+
CALL logger_error("CREATE BOUNDARY: no variable to work on for "//&
- & "file "//TRIM(tl_multi%t_file(ji)%c_name)//&
+ & "mpp "//TRIM(tl_multi%t_mpp(ji)%c_name)//&
& ". check cn_varfile in namelist.")
+
+ ELSEIF( TRIM(tl_multi%t_mpp(ji)%c_name) == TRIM(cl_data) )THEN
+ !- use input matrix to fill variable
+
+ WRITE(*,'(a)') "work on data"
+ ! for each variable initialise from matrix
+ DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
+
+ jvar=jvar+1
+ WRITE(*,'(2x,a,a)') "work on variable "//&
+ & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
+
+ tl_var1=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj))
+
+ SELECT CASE(TRIM(tl_var1%c_point))
+ CASE DEFAULT !'T'
+ jpoint=jp_T
+ CASE('U')
+ jpoint=jp_U
+ CASE('V')
+ jpoint=jp_V
+ CASE('F')
+ jpoint=jp_F
+ END SELECT
+
+ WRITE(*,'(4x,a,a)') 'work on '//TRIM(tl_var1%c_name)
+ DO jl=1,ip_ncard
+ IF( tl_bdy(jl)%l_use )THEN
+
+ DO jk=1,tl_bdy(jl)%i_nseg
+
+ ! fill value with matrix data
+ tl_segvar1(jvar,jk,jl)=create_boundary_matrix( &
+ & tl_var1, &
+ & tl_segdom1(jpoint,jk,jl), &
+ & in_nlevel )
+
+ ! use mask
+ CALL create_boundary_use_mask( tl_segvar1(jvar,jk,jl), &
+ & tl_seglvl1(jpoint,jk,jl))
+
+ !del extra
+ CALL dom_del_extra( tl_segvar1(jvar,jk,jl), &
+ & tl_segdom1(jpoint,jk,jl) )
+
+ ENDDO
+
+ ENDIF
+ ENDDO
+
+ ! clean
+ CALL var_clean(tl_var1)
+
+ ENDDO
+
+ !- end of use input matrix to fill variable
ELSE
- IF( .NOT. ASSOCIATED(tl_multi%t_file(ji)%t_var) )THEN
-
- CALL logger_error("CREATE BOUNDARY: no variable to work on for "//&
- & "file "//TRIM(tl_multi%t_file(ji)%c_name)//&
- & ". check cn_varfile in namelist.")
-
- ELSEIF( TRIM(tl_multi%t_file(ji)%c_name) == TRIM(cl_data) )THEN
- !- use input matrix to fill variable
-
- ! for each variable initialise from matrix
- DO jj=1,tl_multi%t_file(ji)%i_nvar
- jvar=jvar+1
- tl_tmp=tl_multi%t_file(ji)%t_var(jj)
- DO jk=1,ip_ncard
- IF( tl_bdy(jk)%l_use )THEN
- DO jl=1,tl_bdy(jk)%i_nseg
- !7-1 fill value with matrix data
- ! pb voir comment gerer nb de dimension
- tl_segvar1(jvar,jk,jl)=create_bdy_matrix(tl_tmp, tl_segdom1(jk,jl), tl_coord1)
-
- !7-2 use mask
- CALL create_bdy_use_mask(tl_segvar1(jvar,jk,jl), tl_seglvl1(jk,jl,:))
- ENDDO
- ENDIF
- ENDDO
- ENDDO
-
+ !- use file to fill variable
+
+ WRITE(*,'(a)') "work on file "//TRIM(tl_multi%t_mpp(ji)%c_name)
+ !
+ tl_mpp=mpp_init(file_init(TRIM(tl_multi%t_mpp(ji)%t_proc(1)%c_name)))
+ CALL grid_get_info(tl_mpp)
+
+ ! check vertical dimension
+ IF( tl_mpp%t_dim(jp_K)%l_use .AND. &
+ & tl_mpp%t_dim(jp_K)%i_len /= in_nlevel )THEN
+ CALL logger_error("CREATE BOUNDARY: dimension in file "//&
+ & TRIM(tl_mpp%c_name)//" not agree with namelist in_nlevel ")
+ ENDIF
+
+ ! open mpp file
+ CALL iom_mpp_open(tl_mpp)
+
+ ! get or check depth value
+ CALL create_boundary_check_depth( tl_mpp, tl_depth )
+
+ ! get or check time value
+ CALL create_boundary_check_time( tl_mpp, tl_time )
+
+ ! close mpp file
+ CALL iom_mpp_close(tl_mpp)
+
+ IF( ANY( tl_mpp%t_dim(1:2)%i_len /= &
+ & tl_coord0%t_dim(1:2)%i_len) )THEN
+ !- extract value from fine grid
+
+ IF( ANY( tl_mpp%t_dim(1:2)%i_len <= &
+ & tl_coord1%t_dim(1:2)%i_len) )THEN
+ CALL logger_fatal("CREATE BOUNDARY: dimension in file "//&
+ & TRIM(tl_mpp%c_name)//" smaller than those in fine"//&
+ & " grid coordinates.")
+ ENDIF
+
+ DO jl=1,ip_ncard
+ IF( tl_bdy(jl)%l_use )THEN
+
+ WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//' boundary'
+ DO jk=1,tl_bdy(jl)%i_nseg
+ ! compute domain on fine grid
+
+ ! for each variable of this file
+ DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
+
+ cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name
+ WRITE(*,'(4x,a,a)') "work on variable "//TRIM(cl_name)
+
+ cl_point=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_point
+ ! open mpp file on domain
+ SELECT CASE(TRIM(cl_point))
+ CASE DEFAULT !'T'
+ jpoint=jp_T
+ CASE('U')
+ jpoint=jp_U
+ CASE('V')
+ jpoint=jp_V
+ CASE('F')
+ jpoint=jp_F
+ END SELECT
+
+ tl_dom1=dom_copy(tl_segdom1(jpoint,jk,jl))
+ tl_lvl1=var_copy(tl_seglvl1(jpoint,jk,jl))
+
+ ! open mpp files
+ CALL iom_dom_open(tl_mpp, tl_dom1)
+
+ !7-5 read variable over domain
+ tl_segvar1(jvar+jj,jk,jl)=iom_dom_read_var( &
+ & tl_mpp, TRIM(cl_name), tl_dom1)
+
+ ! use mask
+ CALL create_boundary_use_mask( &
+ & tl_segvar1(jvar+jj,jk,jl), tl_lvl1)
+
+ ! del extra point
+ CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), &
+ & tl_dom1 )
+
+ ! clean extra point information on fine grid domain
+ CALL dom_clean_extra( tl_dom1 )
+
+ ! add attribute to variable
+ tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
+ CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
+
+ tl_att=att_init('src_i_indices',(/tl_dom1%i_imin, tl_dom1%i_imax/))
+ CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
+
+ tl_att=att_init('src_j_indices',(/tl_dom1%i_jmin, tl_dom1%i_jmax/))
+ CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
+
+ ! clean structure
+ CALL att_clean(tl_att)
+ CALL dom_clean(tl_dom1)
+
+ ! close mpp files
+ CALL iom_dom_close(tl_mpp)
+
+ ! clean
+ CALL var_clean(tl_lvl1)
+
+ ENDDO ! jj
+ ENDDO ! jk
+
+ ENDIF
+ ENDDO ! jl
+
+ ! clean
+ CALL mpp_clean(tl_mpp)
+
+ jvar=jvar+tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
+
+ !- end of extract value from fine grid
ELSE
- !- use file to fill variable
-
- ! open file
- tl_file=file_init(TRIM(tl_multi%t_file(ji)%c_name))
- CALL iom_open(tl_file)
-
- ! get or check depth value
- IF( tl_file%i_depthid /= 0 )THEN
- IF( ASSOCIATED(tl_depth%d_value) )THEN
- IF( ANY( tl_depth%d_value(:,:,:,:) /= &
- & tl_tmp%d_value(:,:,:,:) ) )THEN
- CALL logger_fatal("CREATE BOUNDARY: depth value from "//&
- & TRIM(tl_multi%t_file(ji)%c_name)//" not conform "//&
- & " to those from former file(s).")
- ENDIF
- ELSE
- tl_depth=iom_read_var(tl_file,tl_file%i_depthid)
- ENDIF
- ENDIF
-
- ! get or check time value
- IF( tl_file%i_timeid /= 0 )THEN
- IF( ASSOCIATED(tl_time%d_value) )THEN
- IF( ANY( tl_time%d_value(:,:,:,:) /= &
- & tl_tmp%d_value(:,:,:,:) ) )THEN
- CALL logger_fatal("CREATE BOUNDARY: time value from "//&
- & TRIM(tl_multi%t_file(ji)%c_name)//" not conform "//&
- & " to those from former file(s).")
- ENDIF
- ELSE
- tl_time=iom_read_var(tl_file,tl_file%i_timeid)
- ENDIF
- ENDIF
-
- IF( ANY( tl_file%t_dim(1:2)%i_len /= &
- & tl_coord0%t_dim(1:2)%i_len) )THEN
- !- extract value from fine grid
- DO jk=1,ip_ncard
- IF( tl_bdy(jk)%l_use )THEN
-
- DO jl=1,tl_bdy(jk)%i_nseg
- !7-1 compute domain on fine grid
+ !- interpolate value from coarse grid
+
+ DO jl=1,ip_ncard
+ IF( tl_bdy(jl)%l_use )THEN
+
+ WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//' boundary'
+ DO jk=1,tl_bdy(jl)%i_nseg
+
+ ! for each variable of this file
+ DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
+ WRITE(*,'(4x,a,a)') "work on variable "//&
+ & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
+
+ tl_var0=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj))
! open mpp file on domain
- !7-2 init mpp structure
- tl_mpp=mpp_init(tl_file)
-
- !7-3 get processor to be used
- CALL mpp_get_use( tl_mpp, tl_segdom1(jk,jl) )
- !7-4 open mpp files
- CALL iom_mpp_open(tl_mpp)
-
- ! for each variable of this file
- DO jj=1,tl_multi%t_file(ji)%i_nvar
-
- cl_name=tl_multi%t_file(ji)%t_var(jj)%c_name
- !7-5 read variable over domain
- tl_segvar1(jvar+jj,jk,jl)=iom_mpp_read_var( tl_mpp, TRIM(cl_name), &
- & td_dom=tl_segdom1(jk,jl) )
-
- !7-6 add attribute to variable
- tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
- CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
-
- tl_att=att_init('src_i-indices',(/tl_segdom1(jk,jl)%i_imin, tl_segdom1(jk,jl)%i_imax/))
- CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
-
- tl_att=att_init('src_j-indices',(/tl_segdom1(jk,jl)%i_jmin, tl_segdom1(jk,jl)%i_jmax/))
- CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
-
- ! clean structure
- CALL att_clean(tl_att)
-
- !7-7 use mask
- CALL create_bdy_use_mask(tl_segvar1(jvar+jj,jk,jl), tl_seglvl1(jk,jl,:))
- ENDDO
-
- !7-8 close mpp files
- CALL iom_mpp_close(tl_mpp)
-
- CALL mpp_clean(tl_mpp)
-
- ENDDO
- ENDIF
- ENDDO
- jvar=jvar+tl_multi%t_file(ji)%i_nvar
- ELSE
- !- interpolate value from coarse grid
-
- DO jk=1,ip_ncard
- IF( tl_bdy(jk)%l_use )THEN
-
- DO jl=1,tl_bdy(jk)%i_nseg
- !7-1 get coarse grid indices of this segment
- il_ind(:,:,:)=grid_get_coarse_index(tl_coord0, &
- & tl_seglon1(jk,jl), tl_seglat1(jk,jl), &
- & id_rho=il_rho(:) )
-
- IF( ANY(il_ind(:,:,:)==0) )THEN
- CALL logger_error("CREATE BOUNDARY: error computing "//&
- & " coarse grid indices")
+ SELECT CASE(TRIM(tl_var0%c_point))
+ CASE DEFAULT !'T'
+ jpoint=jp_T
+ CASE('U')
+ jpoint=jp_U
+ CASE('V')
+ jpoint=jp_V
+ CASE('F')
+ jpoint=jp_F
+ END SELECT
+
+ tl_dom1=dom_copy(tl_segdom1(jpoint,jk,jl))
+ tl_lvl1=var_copy(tl_seglvl1(jpoint,jk,jl))
+
+ CALL create_boundary_get_coord( tl_coord1, tl_dom1, &
+ & tl_var0%c_point, &
+ & tl_lon1, tl_lat1 )
+
+ ! get coarse grid indices of this segment
+ il_ind(:,:)=grid_get_coarse_index(tl_coord0, &
+ & tl_lon1, tl_lat1, &
+ & id_rho=il_rho(:) )
+
+ IF( ANY(il_ind(:,:)==0) )THEN
+ CALL logger_error("CREATE BOUNDARY: error "//&
+ & "computing coarse grid indices")
ELSE
- il_imin0=il_ind(1,1,1)
- il_imax0=il_ind(1,2,1)
-
- il_jmin0=il_ind(2,1,1)
- il_jmax0=il_ind(2,2,1)
-
- il_offset(:,:)=il_ind(:,:,2)
+ il_imin0=il_ind(1,1)
+ il_imax0=il_ind(1,2)
+
+ il_jmin0=il_ind(2,1)
+ il_jmax0=il_ind(2,2)
ENDIF
- !7-2 compute coarse grid segment domain
+ il_offset(:,:)= grid_get_fine_offset( &
+ & tl_coord0, &
+ & il_imin0, il_jmin0,&
+ & il_imax0, il_jmax0,&
+ & tl_lon1%d_value(:,:,1,1),&
+ & tl_lat1%d_value(:,:,1,1),&
+ & il_rho(:),&
+ & TRIM(tl_var0%c_point) )
+
+ ! compute coarse grid segment domain
tl_dom0=dom_init( tl_coord0, &
& il_imin0, il_imax0,&
& il_jmin0, il_jmax0 )
- !7-3 add extra band (if possible) to compute interpolation
+ ! add extra band (if possible) to compute interpolation
CALL dom_add_extra(tl_dom0)
- !7-4 read variables on domain (ugly way to do it, have to work on it)
- !7-4-1 init mpp structure
- tl_mpp=mpp_init(tl_file)
-
- !7-4-2 get processor to be used
- CALL mpp_get_use( tl_mpp, tl_dom0 )
-
- !7-4-3 open mpp files
- CALL iom_mpp_open(tl_mpp)
-
- ! check file dimension
- IF( ANY(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) )THEN
- CALL logger_error("CREATE BOUNDARY INTERP: dimension of file "//&
- & TRIM(tl_mpp%c_name)//" not conform to those of "//&
- & TRIM(tl_coord0%c_name))
- ELSE
-
- ! for each variable of this file
- DO jj=1,tl_multi%t_file(ji)%i_nvar
-
- cl_name=tl_multi%t_file(ji)%t_var(jj)%c_name
- !7-4-4 read variable value on domain
- tl_segvar1(jvar+jj,jk,jl)=iom_mpp_read_var( tl_mpp, TRIM(cl_name), &
- & td_dom=tl_dom0 )
-
- !7-4-5 work on variable
- CALL create_boundary_interp(tl_segvar1(jvar+jj,jk,jl), &
- & il_rho(:), &
- & il_offset(:,:) )
-
- !7-4-6 remove extraband added to domain
- CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), tl_dom0, il_rho(:) )
-
- !7-4-7 keep only useful point (width)
- ! interpolation could create more point than necessary
- CALL boundary_clean_interp(tl_segvar1(jvar+jj,jk,jl), tl_bdy(jk) )
-
- !7-4-8 add attribute to variable
- tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
- CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
-
- tl_att=att_init('src_i-indices',(/tl_dom0%i_imin, tl_dom0%i_imax/))
- CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
-
- tl_att=att_init('src_j-indices',(/tl_dom0%i_jmin, tl_dom0%i_jmax/))
- CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
-
- ! clean structure
- CALL att_clean(tl_att)
-
- !7-4-9 use mask
- CALL create_bdy_use_mask(tl_segvar1(jvar+jj,jk,jl), tl_seglvl1(jk,jl,:))
- ENDDO
+ ! read variables on domain
+ ! open mpp files
+ CALL iom_dom_open(tl_mpp, tl_dom0)
+
+ cl_name=tl_var0%c_name
+ ! read variable value on domain
+ tl_segvar1(jvar+jj,jk,jl)= &
+ & iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom0)
+
+ ! work on variable
+ CALL create_boundary_interp( &
+ & tl_segvar1(jvar+jj,jk,jl),&
+ & il_rho(:), il_offset(:,:) )
+
+ ! remove extraband added to domain
+ CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), &
+ & tl_dom0, il_rho(:) )
+
+ ! use mask
+ CALL create_boundary_use_mask( &
+ & tl_segvar1(jvar+jj,jk,jl), tl_lvl1)
+
+ ! del extra point on fine grid
+ CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), &
+ & tl_dom1 )
+ ! clean extra point information on coarse grid domain
+ CALL dom_clean_extra( tl_dom0 )
+
+ ! add attribute to variable
+ tl_att=att_init('src_file',&
+ & TRIM(fct_basename(tl_mpp%c_name)))
+ CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), &
+ & tl_att)
+
+ ! use clean extra avt creer attribut
+ tl_att=att_init('src_i-indices',&
+ & (/tl_dom0%i_imin, tl_dom0%i_imax/))
+ CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), &
+ & tl_att)
+
+ tl_att=att_init('src_j-indices', &
+ & (/tl_dom0%i_jmin, tl_dom0%i_jmax/))
+ CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), &
+ & tl_att)
+
+ IF( ANY(il_rho(:)/=1) )THEN
+ tl_att=att_init("refinment_factor", &
+ & (/il_rho(jp_I),il_rho(jp_J)/))
+ CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), &
+ & tl_att)
ENDIF
+ ! clean structure
+ CALL att_clean(tl_att)
+
+ ! clean
CALL dom_clean(tl_dom0)
-
- !7-5 close mpp files
- CALL iom_mpp_close(tl_mpp)
-
- !7-6 clean structure
- CALL mpp_clean(tl_mpp)
- ENDDO
- ENDIF
- ENDDO
- jvar=jvar+tl_multi%t_file(ji)%i_nvar
-
- ENDIF
- CALL file_clean(tl_file)
-
+ CALL dom_clean(tl_dom1)
+
+ ! close mpp files
+ CALL iom_dom_close(tl_mpp)
+
+ ! clean structure
+ CALL var_clean(tl_lon1)
+ CALL var_clean(tl_lat1)
+ CALL var_clean(tl_lvl1)
+
+ ENDDO ! jj
+
+ ! clean
+ CALL var_clean(tl_var0)
+
+ ENDDO ! jk
+
+ ENDIF
+ ENDDO ! jl
+
+ jvar=jvar+tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
+
+ !- end of interpolate value from coarse grid
ENDIF
+
+ ! clean
+ CALL mpp_clean(tl_mpp)
+
+ !- end of use file to fill variable
ENDIF
ENDDO
ENDIF
+
IF( jvar /= tl_multi%i_nvar )THEN
CALL logger_error("CREATE BOUNDARY: it seems some variable can not be read")
ENDIF
- !8- concatenate file
- ALLOCATE( tl_lon1(ip_ncard) )
- ALLOCATE( tl_lat1(ip_ncard) )
- ALLOCATE( tl_var(tl_multi%i_nvar,ip_ncard) )
-
- DO jk=1,ip_ncard
- IF( tl_bdy(jk)%l_use )THEN
+ CALL var_clean(tl_seglvl1(:,:,:))
+ DEALLOCATE( tl_seglvl1 )
+
+ ! write file for each segment of each boundary
+ DO jl=1,ip_ncard
+ IF( tl_bdy(jl)%l_use )THEN
SELECT CASE(TRIM(tl_bdy(jk)%c_card))
@@ -625,153 +906,169 @@
END SELECT
- DO jl=1,tl_bdy(jk)%i_nseg
- !- concatenate variable
- IF( jl == 1 )THEN
- tl_lon1(jk)=tl_seglon1(jk,jl)
- tl_lat1(jk)=tl_seglat1(jk,jl)
- DO jvar=1,tl_multi%i_nvar
- tl_var(jvar,jk)=tl_segvar1(jvar,jk,jl)
- ENDDO
+ DO jk=1,tl_bdy(jl)%i_nseg
+ !-
+ CALL create_boundary_get_coord( tl_coord1, tl_segdom1(jp_T,jk,jl),&
+ & 'T', tl_lon1, tl_lat1 )
+
+ ! del extra point on fine grid
+ CALL dom_del_extra( tl_lon1, tl_segdom1(jp_T,jk,jl) )
+ CALL dom_del_extra( tl_lat1, tl_segdom1(jp_T,jk,jl) )
+
+ ! clean
+ DO jpoint=1,ip_npoint
+ CALL dom_clean(tl_segdom1(jpoint,jk,jl))
+ ENDDO
+
+ ! swap array
+ CALL boundary_swap(tl_lon1, tl_bdy(jl))
+ CALL boundary_swap(tl_lat1, tl_bdy(jl))
+ DO jvar=1,tl_multi%i_nvar
+ CALL boundary_swap(tl_segvar1(jvar,jk,jl), tl_bdy(jl))
+
+ ! use additional request
+ ! forced min and max value
+ CALL var_limit_value(tl_segvar1(jvar,jk,jl))
+
+ ! filter
+ CALL filter_fill_value(tl_segvar1(jvar,jk,jl))
+
+ ! extrapolate
+ CALL extrap_fill_value( tl_segvar1(jvar,jk,jl), &
+ & id_iext=in_extrap, &
+ & id_jext=in_extrap, &
+ & id_kext=in_extrap )
+
+ ENDDO
+
+ ! create file
+ ! create file structure
+ ! set file namearray of level variable structure
+ IF( ASSOCIATED(tl_time%d_value) )THEN
+ cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)"
+ cl_date=date_print( var_to_date(tl_time), cl_fmt )
+
+ cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
+ & TRIM(tl_bdy(jl)%c_card), jk, TRIM(cl_date) )
ELSE
- tl_lon1(jk)=var_concat(tl_lon1(jk),tl_seglon1(jk,jl),DIM=il_dim)
- tl_lat1(jk)=var_concat(tl_lat1(jk),tl_seglat1(jk,jl),DIM=il_dim)
- DO jvar=1,tl_multi%i_nvar
- tl_var(jvar,jk)=var_concat(tl_var(jvar,jk),tl_segvar1(jvar,jk,jl),DIM=il_dim)
- ENDDO
- ENDIF
- ENDDO
-
- ! swap array
- CALL boundary_swap(tl_lon1(jk), tl_bdy(jk))
- CALL boundary_swap(tl_lat1(jk), tl_bdy(jk))
- DO jvar=1,tl_multi%i_nvar
- CALL boundary_swap(tl_var(jvar,jk), tl_bdy(jk))
-
- !9- use additional request
-
- !9-1 forced min and max value
- CALL var_limit_value(tl_var(jvar,jk))
-
- !9-2 filter
- CALL filter_fill_value(tl_var(jvar,jk))
-
- !9-3 extrapolate
- CALL extrap_fill_value(tl_var(jvar,jk), id_iext=in_extrap, &
- & id_jext=in_extrap, &
- & id_kext=in_extrap)
-
- ENDDO
+ cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
+ & TRIM(tl_bdy(jl)%c_card), jk )
+ ENDIF
+ !
+ tl_fileout=file_init(TRIM(cl_bdyout),id_perio=in_perio1)
+
+ ! add dimension
+ tl_dim(:)=var_max_dim(tl_segvar1(:,jk,jl))
+
+ CALL dim_unorder(tl_dim(:))
+ SELECT CASE(TRIM(tl_bdy(jl)%c_card))
+ CASE DEFAULT ! 'north','south'
+ cl_dimorder='xyzt'
+ CALL dim_reorder(tl_dim(:),TRIM(cl_dimorder))
+ CASE('east','west')
+ cl_dimorder='yxzt'
+ CALL dim_reorder(tl_dim(:),TRIM(cl_dimorder))
+ ! reorder coordinates dimension
+ CALL var_reorder(tl_lon1,TRIM(cl_dimorder))
+ CALL var_reorder(tl_lat1,TRIM(cl_dimorder))
+ ! reorder other variable dimension
+ DO jvar=1,tl_multi%i_nvar
+ CALL var_reorder(tl_segvar1(jvar,jk,jl),TRIM(cl_dimorder))
+ ENDDO
+ END SELECT
+
+ DO ji=1,ip_maxdim
+ IF( tl_dim(ji)%l_use ) CALL file_add_dim(tl_fileout, tl_dim(ji))
+ ENDDO
+
+ ! add variables
+ IF( ALL( tl_dim(1:2)%l_use ) )THEN
+ ! add longitude
+ CALL file_add_var(tl_fileout, tl_lon1)
+ CALL var_clean(tl_lon1)
+
+ ! add latitude
+ CALL file_add_var(tl_fileout, tl_lat1)
+ CALL var_clean(tl_lat1)
+ ENDIF
+
+ IF( tl_dim(3)%l_use )THEN
+ ! add depth
+ CALL file_add_var(tl_fileout, tl_depth)
+ ENDIF
+
+ IF( tl_dim(4)%l_use )THEN
+ ! add time
+ CALL file_add_var(tl_fileout, tl_time)
+ ENDIF
+
+ ! add other variable
+ DO jvar=1,tl_multi%i_nvar
+ CALL file_add_var(tl_fileout, tl_segvar1(jvar,jk,jl))
+ CALL var_clean(tl_segvar1(jvar,jk,jl))
+ ENDDO
+
+ ! add some attribute
+ tl_att=att_init("Created_by","SIREN create_boundary")
+ CALL file_add_att(tl_fileout, tl_att)
+
+ cl_date=date_print(date_now())
+ tl_att=att_init("Creation_date",cl_date)
+ CALL file_add_att(tl_fileout, tl_att)
+
+ ! add shift on north and east boundary
+ ! boundary compute on T point but express on U or V point
+ SELECT CASE(TRIM(tl_bdy(jl)%c_card))
+ CASE DEFAULT ! 'south','west'
+ il_shift=0
+ CASE('north','east')
+ il_shift=1
+ END SELECT
+
+ ! add indice of velocity row or column
+ tl_att=att_init('bdy_ind',tl_bdy(jl)%t_seg(jk)%i_index-il_shift)
+ CALL file_move_att(tl_fileout, tl_att)
+
+ ! add width of the relaxation zone
+ tl_att=att_init('bdy_width',tl_bdy(jl)%t_seg(jk)%i_width)
+ CALL file_move_att(tl_fileout, tl_att)
+
+ ! add indice of segment start
+ tl_att=att_init('bdy_deb',tl_bdy(jl)%t_seg(jk)%i_first)
+ CALL file_move_att(tl_fileout, tl_att)
+
+ ! add indice of segment end
+ tl_att=att_init('bdy_end',tl_bdy(jl)%t_seg(jk)%i_last)
+ CALL file_move_att(tl_fileout, tl_att)
+
+ ! clean
+ CALL att_clean(tl_att)
+
+ ! create file
+ CALL iom_create(tl_fileout)
+
+ ! write file
+ CALL iom_write_file(tl_fileout)
+
+ ! close file
+ CALL iom_close(tl_fileout)
+ CALL file_clean(tl_fileout)
+
+ ENDDO ! jk
+
ENDIF
- ENDDO
-
- DEALLOCATE( tl_seglon1 )
- DEALLOCATE( tl_seglat1 )
+ ! clean
+ CALL boundary_clean(tl_bdy(jl))
+ ENDDO !jl
+
+ ! clean
+ IF( ASSOCIATED(tl_depth%d_value) ) CALL var_clean(tl_depth)
+ IF( ASSOCIATED(tl_time%d_value) ) CALL var_clean(tl_time)
DEALLOCATE( tl_segdom1 )
DEALLOCATE( tl_segvar1 )
- DEALLOCATE( tl_seglvl1 )
-
- DO jk=1,ip_ncard
- IF( tl_bdy(jk)%l_use )THEN
-
- !10 create file
- !10-1 create file structure
- !10-1-1 set file name
- cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
- & TRIM(tl_bdy(jk)%c_card) )
- !10-1-2
- tl_fileout=file_init(TRIM(cl_bdyout),id_perio=in_perio1)
-
- !10-2 add dimension
- tl_dim(:)=var_max_dim(tl_var(:,jk))
-
- DO ji=1,ip_maxdim
- IF( tl_dim(ji)%l_use ) CALL file_add_dim(tl_fileout, tl_dim(ji))
- ENDDO
-
- !10-3 add variables
- IF( ALL( tl_dim(1:2)%l_use ) )THEN
- ! add longitude
- CALL file_add_var(tl_fileout, tl_lon1(jk))
- CALL var_clean(tl_lon1(jk))
-
- ! add latitude
- CALL file_add_var(tl_fileout, tl_lat1(jk))
- CALL var_clean(tl_lat1(jk))
- ENDIF
-
- IF( tl_dim(3)%l_use )THEN
- ! add depth
- CALL file_add_var(tl_fileout, tl_depth)
- ENDIF
-
- IF( tl_dim(4)%l_use )THEN
- ! add time
- CALL file_add_var(tl_fileout, tl_time)
- ENDIF
-
- ! add other variable
- DO jvar=1,tl_multi%i_nvar
- !IF( TRIM(tl_var(jvar,jk)%c_name) /= 'X' .AND. &
- !& TRIM(tl_var(jvar,jk)%c_name) /= 'Y' )THEN
- CALL file_add_var(tl_fileout, tl_var(jvar,jk))
- !ENDIF
- CALL var_clean(tl_var(jvar,jk))
- ENDDO
-
- !10-4 add some attribute
- tl_att=att_init("Created_by","SIREN create_boundary")
- CALL file_add_att(tl_fileout, tl_att)
-
- cl_date=date_print(date_now())
- tl_att=att_init("Creation_date",cl_date)
- CALL file_add_att(tl_fileout, tl_att)
-
- ! add attribute periodicity
- il_attid=0
- IF( ASSOCIATED(tl_fileout%t_att) )THEN
- il_attid=att_get_id(tl_fileout%t_att(:),'periodicity')
- ENDIF
- IF( tl_coord1%i_perio >= 0 .AND. il_attid == 0 )THEN
- tl_att=att_init('periodicity',tl_coord1%i_perio)
- CALL file_add_att(tl_fileout,tl_att)
- ENDIF
-
- il_attid=0
- IF( ASSOCIATED(tl_fileout%t_att) )THEN
- il_attid=att_get_id(tl_fileout%t_att(:),'ew_overlap')
- ENDIF
- IF( tl_coord1%i_ew >= 0 .AND. il_attid == 0 )THEN
- tl_att=att_init('ew_overlap',tl_coord1%i_ew)
- CALL file_add_att(tl_fileout,tl_att)
- ENDIF
-
- !10-5 create file
- CALL iom_create(tl_fileout)
-
- !10-6 write file
- CALL iom_write_file(tl_fileout)
-
- !10-7 close file
- CALL iom_close(tl_fileout)
- CALL file_clean(tl_fileout)
-
- ENDIF
- ENDDO
- DEALLOCATE( tl_lon1 )
- DEALLOCATE( tl_lat1 )
- DEALLOCATE( tl_var )
-
- !11- close file
- CALL iom_close(tl_bathy1)
- CALL iom_close(tl_coord1)
- CALL iom_close(tl_coord0)
-
- !12- clean
- CALL var_clean(tl_depth)
- CALL var_clean(tl_time)
- CALL file_clean(tl_fileout)
- CALL file_clean(tl_bathy1)
- CALL file_clean(tl_coord1)
- CALL file_clean(tl_coord0)
+
+ CALL mpp_clean(tl_coord1)
+ CALL mpp_clean(tl_coord0)
+
+ CALL multi_clean(tl_multi)
! close log file
@@ -779,19 +1076,19 @@
CALL logger_close()
-!> @endcode
CONTAINS
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This subroutine compute boundary domain for each grid point (T,U,V,F)
!>
- !> @details
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - take into account grid point to compute boundary indices
!>
- !> @author J.Paul
- !> - 2013- Initial Version
- !>
- !> @param[in]
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] td_bathy1 file structure
+ !> @param[in] td_bdy boundary structure
+ !> @param[in] id_seg segment indice
+ !> @return array of domain structure
+ !-------------------------------------------------------------------
FUNCTION create_boundary_get_dom( td_bathy1, td_bdy, id_seg )
@@ -799,10 +1096,10 @@
! Argument
- TYPE(TFILE), INTENT(IN ) :: td_bathy1
+ TYPE(TMPP) , INTENT(IN ) :: td_bathy1
TYPE(TBDY) , INTENT(IN ) :: td_bdy
INTEGER(i4), INTENT(IN ) :: id_seg
! function
- TYPE(TDOM) :: create_boundary_get_dom
+ TYPE(TDOM), DIMENSION(ip_npoint) :: create_boundary_get_dom
! local variable
@@ -812,60 +1109,133 @@
INTEGER(i4) :: il_jmax1
- TYPE(TFILE) :: tl_bathy1
-
+ INTEGER(i4) :: il_imin
+ INTEGER(i4) :: il_imax
+ INTEGER(i4) :: il_jmin
+ INTEGER(i4) :: il_jmax
+
+ INTEGER(i4), DIMENSION(ip_npoint) :: il_ishift
+ INTEGER(i4), DIMENSION(ip_npoint) :: il_jshift
+
! loop indices
- INTEGER(i4) :: jl
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jk
!----------------------------------------------------------------
- jl=id_seg
-
- !1- get boundary definition
+ ! init
+ jk=id_seg
+
+ il_ishift(:)=0
+ il_jshift(:)=0
+
+ ! get boundary definition
SELECT CASE(TRIM(td_bdy%c_card))
CASE('north')
- il_imin1=td_bdy%t_seg(jl)%i_first
- il_imax1=td_bdy%t_seg(jl)%i_last
- il_jmin1=td_bdy%t_seg(jl)%i_index-(td_bdy%t_seg(jl)%i_width-1)
- il_jmax1=td_bdy%t_seg(jl)%i_index
+ il_imin1=td_bdy%t_seg(jk)%i_first
+ il_imax1=td_bdy%t_seg(jk)%i_last
+ il_jmin1=td_bdy%t_seg(jk)%i_index-(td_bdy%t_seg(jk)%i_width-1)
+ il_jmax1=td_bdy%t_seg(jk)%i_index
+
+ il_jshift(jp_V)=-1
+ il_jshift(jp_F)=-1
CASE('south')
- il_imin1=td_bdy%t_seg(jl)%i_first
- il_imax1=td_bdy%t_seg(jl)%i_last
- il_jmin1=td_bdy%t_seg(jl)%i_index
- il_jmax1=td_bdy%t_seg(jl)%i_index+(td_bdy%t_seg(jl)%i_width-1)
+ il_imin1=td_bdy%t_seg(jk)%i_first
+ il_imax1=td_bdy%t_seg(jk)%i_last
+ il_jmin1=td_bdy%t_seg(jk)%i_index
+ il_jmax1=td_bdy%t_seg(jk)%i_index+(td_bdy%t_seg(jk)%i_width-1)
CASE('east')
- il_imin1=td_bdy%t_seg(jl)%i_index-(td_bdy%t_seg(jl)%i_width-1)
- il_imax1=td_bdy%t_seg(jl)%i_index
- il_jmin1=td_bdy%t_seg(jl)%i_first
- il_jmax1=td_bdy%t_seg(jl)%i_last
+ il_imin1=td_bdy%t_seg(jk)%i_index-(td_bdy%t_seg(jk)%i_width-1)
+ il_imax1=td_bdy%t_seg(jk)%i_index
+ il_jmin1=td_bdy%t_seg(jk)%i_first
+ il_jmax1=td_bdy%t_seg(jk)%i_last
+
+ il_ishift(jp_U)=-1
+ il_ishift(jp_F)=-1
CASE('west')
- il_imin1=td_bdy%t_seg(jl)%i_index
- il_imax1=td_bdy%t_seg(jl)%i_index+(td_bdy%t_seg(jl)%i_width-1)
- il_jmin1=td_bdy%t_seg(jl)%i_first
- il_jmax1=td_bdy%t_seg(jl)%i_last
+ il_imin1=td_bdy%t_seg(jk)%i_index
+ il_imax1=td_bdy%t_seg(jk)%i_index+(td_bdy%t_seg(jk)%i_width-1)
+ il_jmin1=td_bdy%t_seg(jk)%i_first
+ il_jmax1=td_bdy%t_seg(jk)%i_last
END SELECT
- !2 -read fine grid domain
- tl_bathy1=td_bathy1
- CALL iom_open(tl_bathy1)
-
- !2-1 compute domain
- create_boundary_get_dom=dom_init( tl_bathy1, &
- & il_imin1, il_imax1,&
- & il_jmin1, il_jmax1 )
-
- !2-2 close file
- CALL iom_close(tl_bathy1)
+ !-read fine grid domain
+ DO ji=1,ip_npoint
+
+ ! shift domain
+ il_imin=il_imin1+il_ishift(ji)
+ il_imax=il_imax1+il_ishift(ji)
+
+ il_jmin=il_jmin1+il_jshift(ji)
+ il_jmax=il_jmax1+il_jshift(ji)
+
+ ! compute domain
+ create_boundary_get_dom(ji)=dom_init( td_bathy1, &
+ & il_imin, il_imax,&
+ & il_jmin, il_jmax,&
+ & TRIM(td_bdy%c_card) )
+
+ ENDDO
END FUNCTION create_boundary_get_dom
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This subroutine get coordinates over boudnary domain
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !> @date September, 2014 - take into account grid point
+ !>
+ !> @param[in] td_coord1 coordinates file structure
+ !> @param[in] td_dom1 boundary domain structure
+ !> @param[in] cd_point grid point
+ !> @param[out] td_lon1 longitude variable structure
+ !> @param[out] td_lat1 latitude variable structure
+ !-------------------------------------------------------------------
+ SUBROUTINE create_boundary_get_coord( td_coord1, td_dom1, cd_point, &
+ & td_lon1, td_lat1 )
+
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP) , INTENT(IN ) :: td_coord1
+ TYPE(TDOM) , INTENT(IN ) :: td_dom1
+ TYPE(TVAR) , INTENT( OUT) :: td_lon1
+ TYPE(TVAR) , INTENT( OUT) :: td_lat1
+ CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: cd_point
+
+ ! local variable
+ TYPE(TMPP) :: tl_coord1
+
+ CHARACTER(LEN=lc) :: cl_name
+ ! loop indices
+ !----------------------------------------------------------------
+ !read variables on domain (ugly way to do it, have to work on it)
+ ! init mpp structure
+ tl_coord1=mpp_copy(td_coord1)
+
+ ! open mpp files
+ CALL iom_dom_open(tl_coord1, td_dom1)
+
+ ! read variable value on domain
+ WRITE(cl_name,*) 'longitude_'//TRIM(cd_point)
+ td_lon1=iom_dom_read_var( tl_coord1, TRIM(cl_name), td_dom1)
+ WRITE(cl_name,*) 'latitude_'//TRIM(cd_point)
+ td_lat1=iom_dom_read_var( tl_coord1, TRIM(cl_name), td_dom1)
+
+ ! close mpp files
+ CALL iom_dom_close(tl_coord1)
+
+ ! clean structure
+ CALL mpp_clean(tl_coord1)
+
+ END SUBROUTINE create_boundary_get_coord
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine interpolate variable over boundary
!>
!> @details
@@ -874,247 +1244,10 @@
!> - Nov, 2013- Initial Version
!>
- !> @param[in]
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE create_boundary_get_coord( td_bathy1, td_dom1, &
- & td_lon1, td_lat1 )
-
- IMPLICIT NONE
-
- ! Argument
- TYPE(TFILE), INTENT(IN ) :: td_bathy1
- TYPE(TDOM) , INTENT(IN ) :: td_dom1
- TYPE(TVAR) , INTENT( OUT) :: td_lon1
- TYPE(TVAR) , INTENT( OUT) :: td_lat1
-
- ! local variable
- TYPE(TFILE) :: tl_bathy1
-
- TYPE(TMPP) :: tl_mppbathy1
-
- ! loop indices
- !----------------------------------------------------------------
- !read variables on domain (ugly way to do it, have to work on it)
-
- !1 init mpp structure
- tl_bathy1=td_bathy1
- tl_mppbathy1=mpp_init(tl_bathy1)
-
- CALL file_clean(tl_bathy1)
-
- !2 get processor to be used
- CALL mpp_get_use( tl_mppbathy1, td_dom1 )
-
- !3 open mpp files
- CALL iom_mpp_open(tl_mppbathy1)
-
- !4 read variable value on domain
- td_lon1=iom_mpp_read_var(tl_mppbathy1,'longitude',td_dom=td_dom1)
- td_lat1=iom_mpp_read_var(tl_mppbathy1,'latitude' ,td_dom=td_dom1)
-
- !5 close mpp files
- CALL iom_mpp_close(tl_mppbathy1)
-
- !6 clean structure
- CALL mpp_clean(tl_mppbathy1)
-
- END SUBROUTINE create_boundary_get_coord
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !> @param[in]
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE create_boundary_get_mask( td_level1, td_dom1, &
- & td_var, td_mask )
-
- IMPLICIT NONE
-
- ! Argument
- TYPE(TFILE), INTENT(IN ) :: td_level1
- TYPE(TDOM) , INTENT(IN ) :: td_dom1
- TYPE(TVAR) , INTENT(IN ) :: td_var
- TYPE(TVAR) , INTENT( OUT) :: td_mask
-
- ! local variable
- TYPE(TFILE) :: tl_level1
-
- TYPE(TMPP) :: tl_mpplevel1
-
- ! loop indices
- !----------------------------------------------------------------
- !read variables on domain (ugly way to do it, have to work on it)
-
- !1 init mpp structure
- tl_level1=td_level1
- tl_mpplevel1=mpp_init(tl_level1)
-
- CALL file_clean(tl_level1)
-
- !2 get processor to be used
- CALL mpp_get_use( tl_mpplevel1, td_dom1 )
-
- !3 open mpp files
- CALL iom_mpp_open(tl_mpplevel1)
-
- !4 read variable value on domain
- SELECT CASE(TRIM(td_var%c_point))
- CASE('T')
- td_mask=iom_mpp_read_var(tl_mpplevel1,'tlevel',td_dom=td_dom1)
- CASE('U')
- td_mask=iom_mpp_read_var(tl_mpplevel1,'ulevel',td_dom=td_dom1)
- CASE('V')
- td_mask=iom_mpp_read_var(tl_mpplevel1,'vlevel',td_dom=td_dom1)
- CASE('F')
- td_mask=iom_mpp_read_var(tl_mpplevel1,'flevel',td_dom=td_dom1)
- END SELECT
-
- !5 close mpp files
- CALL iom_mpp_close(tl_mpplevel1)
-
- !6 clean structure
- CALL mpp_clean(tl_mpplevel1)
-
- END SUBROUTINE create_boundary_get_mask
- !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief
-! !> This subroutine
-! !>
-! !> @details
-! !>
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !>
-! !> @param[in]
-! !> @todo
-! !-------------------------------------------------------------------
-! !> @code
-! SUBROUTINE create_boundary_get_var( td_var, td_bdy, &
-! & td_coord0, td_dom0, &
-! & td_mask, &
-! & id_rhoi, id_rhoj )
-!
-! IMPLICIT NONE
-!
-! ! Argument
-! TYPE(TVAR) , INTENT(INOUT) :: td_var
-! TYPE(TBDY) , INTENT(IN ) :: td_bdy
-! TYPE(TFILE), INTENT(IN ) :: td_coord0
-! TYPE(TDOM) , INTENT(IN ) :: td_dom0
-! TYPE(TVAR) , INTENT(IN ) :: td_mask
-! INTEGER(I4), INTENT(IN ) :: id_rhoi
-! INTEGER(I4), INTENT(IN ) :: id_rhoj
-!
-! ! local variable
-! TYPE(TVAR) :: tl_var0
-!
-! TYPE(TDOM) :: tl_dom0
-!
-! TYPE(TFILE) :: tl_file0
-!
-! TYPE(TMPP) :: tl_mppfile0
-!
-! ! loop indices
-! INTEGER(i4) :: jk
-! INTEGER(i4) :: jl
-! !----------------------------------------------------------------
-!
-! CALL logger_debug("CREATE BOUNDARY INTERP: read coarse grid"// TRIM(td_var%c_file) )
-! !1- read coarse grid variable on domain
-! tl_file0=file_init( TRIM(td_var%c_file) )
-!
-! !2- init
-! tl_dom0=td_dom0
-!
-! !3- add extra band (if possible) to compute interpolation
-! CALL dom_add_extra(tl_dom0)
-!
-! !4- read variables on domain (ugly way to do it, have to work on it)
-! !4-1 init mpp structure
-! tl_mppfile0=mpp_init(tl_file0)
-!
-! CALL file_clean(tl_file0)
-!
-! !4-2 get processor to be used
-! CALL mpp_get_use( tl_mppfile0, tl_dom0 )
-!
-! !4-3 open mpp files
-! CALL iom_mpp_open(tl_mppfile0)
-!
-! ! check file dimension
-! IF( ANY(tl_mppfile0%t_dim(1:2)%i_len /= td_coord0%t_dim(1:2)%i_len) )THEN
-! CALL logger_error("CREATE BOUNDARY INTERP: dimension of file "//&
-! & TRIM(tl_mppfile0%c_name)//" not conform to those of "//&
-! & TRIM(td_coord0%c_name))
-! ELSE
-!
-! !4-4 read variable value on domain
-! tl_var0=iom_mpp_read_var( tl_mppfile0, TRIM(td_var%c_name), &
-! & td_dom=tl_dom0 )
-!
-! !5- work on variable
-! CALL create_boundary_interp(tl_var0, id_rhoi, id_rhoj )
-!
-! !6- remove extraband added to domain
-! CALL dom_del_extra( tl_var0, tl_dom0, id_rhoi, id_rhoj )
-!
-! !6-1 remove extraband added to domain
-! CALL dom_clean_extra( tl_dom0 )
-!
-! !7- keep only useful point (width)
-! ! interpolation could create more point than necessary
-! CALL boundary_clean_interp(tl_var0, td_bdy )
-!
-! !8- forced min and max value
-! CALL var_limit_value(tl_var0)
-!
-! !9- filter
-! CALL filter_fill_value(tl_var0)
-!
-! td_var=tl_var0
-!
-! CALL var_clean(tl_var0)
-! ENDIF
-!
-! !4-5 close mpp files
-! CALL iom_mpp_close(tl_mppfile0)
-!
-! !4-6 clean structure
-! CALL mpp_clean(tl_mppfile0)
-!
-! !5- apply mask
-! DO jl=1,td_var%t_dim(4)%i_len
-! DO jk=1,td_var%t_dim(3)%i_len
-! WHERE( td_mask%d_value(:,:,1,1) < jk )
-! td_var%d_value(:,:,jk,jl)=td_var%d_fill
-! END WHERE
-! ENDDO
-! ENDDO
-!
-! END SUBROUTINE create_boundary_get_var
-! !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !> @param[in]
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> @param[inout] td_var variable structure
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] id_offset array of offset between fine and coarse grid
+ !> @param[in] id_iext i-direction size of extra bands (default=im_minext)
+ !> @param[in] id_jext j-direction size of extra bands (default=im_minext)
+ !-------------------------------------------------------------------
SUBROUTINE create_boundary_interp( td_var, &
& id_rho, &
@@ -1134,13 +1267,8 @@
! local variable
- TYPE(TVAR) :: tl_var
-
INTEGER(i4) :: il_iext
INTEGER(i4) :: il_jext
! loop indices
!----------------------------------------------------------------
-
- ! copy variable
- tl_var=td_var
!WARNING: at least two extrabands are required for cubic interpolation
@@ -1163,26 +1291,19 @@
ENDIF
- !2- work on variable
- !2-0 add extraband
- CALL extrap_add_extrabands(tl_var, il_iext, il_jext)
-
- !2-1 extrapolate variable
- CALL extrap_fill_value( tl_var, id_iext=il_iext, id_jext=il_jext )
-
- !2-2 interpolate Bathymetry
- CALL interp_fill_value( tl_var, id_rho(:), &
+ ! work on variable
+ ! add extraband
+ CALL extrap_add_extrabands(td_var, il_iext, il_jext)
+
+ ! extrapolate variable
+ CALL extrap_fill_value( td_var, id_iext=il_iext, id_jext=il_jext )
+
+ ! interpolate Bathymetry
+ CALL interp_fill_value( td_var, id_rho(:), &
& id_offset=id_offset(:,:) )
- !2-3 remove extraband
- CALL extrap_del_extrabands(tl_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
-
- !3- save result
- td_var=tl_var
-
- ! clean variable structure
- CALL var_clean(tl_var)
+ ! remove extraband
+ CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
END SUBROUTINE create_boundary_interp
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -1192,30 +1313,26 @@
!> A variable is create with the same name that the input variable,
!> and with dimension of the coordinate file.
- !> Then the variable table of value is split into equal subdomain.
+ !> Then the variable array of value is split into equal subdomain.
!> Each subdomain is fill with the linked value of the matrix.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!>
- !> @param[in] td_var : variable structure
- !> @param[in] td_dom : domain structure
- !> @param[in] td_coord : coordinate
+ !> @param[in] td_var variable structure
+ !> @param[in] td_dom domain structure
+ !> @param[in] id_nlevel number of levels
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
- FUNCTION create_bdy_matrix(td_var, td_dom, td_coord)
+ FUNCTION create_boundary_matrix(td_var, td_dom, id_nlevel)
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(IN) :: td_var
- TYPE(TDOM) , INTENT(IN) :: td_dom
- TYPE(TFILE), INTENT(IN) :: td_coord
+ TYPE(TVAR) , INTENT(IN) :: td_var
+ TYPE(TDOM) , INTENT(IN) :: td_dom
+ INTEGER(i4), INTENT(IN) :: id_nlevel
! function
- TYPE(TVAR) :: create_bdy_matrix
+ TYPE(TVAR) :: create_boundary_matrix
! local variable
- INTEGER(i4) :: il_ighost
- INTEGER(i4) :: il_jghost
- INTEGER(i4) , DIMENSION(2) :: il_xghost
INTEGER(i4) , DIMENSION(3) :: il_dim
INTEGER(i4) , DIMENSION(3) :: il_size
@@ -1228,7 +1345,4 @@
REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
- TYPE(TVAR) :: tl_lon
- TYPE(TVAR) :: tl_lat
- TYPE(TVAR) :: tl_var
TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
@@ -1239,25 +1353,12 @@
!----------------------------------------------------------------
- !1- read output grid
- tl_lon=iom_read_var(td_coord,'longitude')
- tl_lat=iom_read_var(td_coord,'latitude')
-
- !2- look for ghost cell
- il_xghost(:)=grid_get_ghost( tl_lon, tl_lat )
-
- il_ighost=il_xghost(1)*ig_ghost
- il_jghost=il_xghost(2)*ig_ghost
-
- !3- write value on grid
- !3-1 get matrix dimension
+ ! write value on grid
+ ! get matrix dimension
il_dim(:)=td_var%t_dim(1:3)%i_len
- !3-2 output dimension
- tl_dim(:)=tl_lon%t_dim(:)
-
- ! remove ghost cell
- tl_dim(1)%i_len=tl_dim(1)%i_len - 2*il_xghost(1)*ig_ghost
- tl_dim(2)%i_len=tl_dim(2)%i_len - 2*il_xghost(2)*ig_ghost
-
- !3-3 split output domain in N subdomain depending of matrix dimension
+
+ tl_dim(jp_I:jp_J)=dim_copy(td_dom%t_dim(jp_I:jp_J))
+ tl_dim(jp_K)%i_len=id_nlevel
+
+ ! split output domain in N subdomain depending of matrix dimension
il_size(:) = tl_dim(1:3)%i_len / il_dim(:)
il_rest(:) = MOD(tl_dim(1:3)%i_len, il_dim(:))
@@ -1271,5 +1372,4 @@
il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1)
-
ALLOCATE( il_jshape(il_dim(2)+1) )
il_jshape(:)=0
@@ -1288,5 +1388,5 @@
il_kshape(il_dim(3)+1)=il_kshape(il_dim(3)+1)+il_rest(3)
- !3-3 write ouput table of value
+ ! write ouput array of value
ALLOCATE(dl_value( tl_dim(1)%i_len, &
& tl_dim(2)%i_len, &
@@ -1309,37 +1409,29 @@
ENDDO
- !3-4 initialise variable with value
- tl_var=var_init(TRIM(td_var%c_name),dl_value(:,:,:,:))
+ ! initialise variable with value
+ create_boundary_matrix=var_init(TRIM(td_var%c_name),dl_value(:,:,:,:))
DEALLOCATE(dl_value)
- !4- add ghost cell
- CALL grid_add_ghost(tl_var,il_ighost,il_jghost)
-
- !5- save result
- create_bdy_matrix=tl_var
-
- END FUNCTION create_bdy_matrix
- !> @endcode
+ END FUNCTION create_boundary_matrix
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This subroutine use mask to filled land point with _FillValue
!>
!> @details
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!>
- !> @param[in]
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE create_bdy_use_mask( td_var, td_mask )
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_mask mask variable structure
+ !-------------------------------------------------------------------
+ SUBROUTINE create_boundary_use_mask( td_var, td_mask )
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_var
- TYPE(TVAR), DIMENSION(:), INTENT(IN ) :: td_mask
+ TYPE(TVAR), INTENT(INOUT) :: td_var
+ TYPE(TVAR), INTENT(IN ) :: td_mask
! local variable
@@ -1351,17 +1443,20 @@
!----------------------------------------------------------------
+ IF( ANY(td_var%t_dim(1:2)%i_len /= &
+ & td_mask%t_dim(1:2)%i_len) )THEN
+ CALL logger_debug(" mask dimension ( "//&
+ & TRIM(fct_str(td_mask%t_dim(1)%i_len))//","//&
+ & TRIM(fct_str(td_mask%t_dim(2)%i_len))//")" )
+ CALL logger_debug(" variable dimension ( "//&
+ & TRIM(fct_str(td_var%t_dim(1)%i_len))//","//&
+ & TRIM(fct_str(td_var%t_dim(2)%i_len))//")" )
+ CALL logger_fatal("CREATE BOUNDARY USE MASK: mask and "//&
+ & "variable dimension differ." )
+ ENDIF
+
ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
& td_var%t_dim(2)%i_len) )
- SELECT CASE(TRIM(td_var%c_point))
- CASE('T')
- il_mask(:,:)=INT(td_mask(jp_T)%d_value(:,:,1,1))
- CASE('U')
- il_mask(:,:)=INT(td_mask(jp_U)%d_value(:,:,1,1))
- CASE('V')
- il_mask(:,:)=INT(td_mask(jp_V)%d_value(:,:,1,1))
- CASE('F')
- il_mask(:,:)=INT(td_mask(jp_F)%d_value(:,:,1,1))
- END SELECT
+ il_mask(:,:)=INT(td_mask%d_value(:,:,1,1))
DO jl=1,td_var%t_dim(4)%i_len
@@ -1372,62 +1467,172 @@
DEALLOCATE( il_mask )
- END SUBROUTINE create_bdy_use_mask
- !> @endcode
+
+ END SUBROUTINE create_boundary_use_mask
!-------------------------------------------------------------------
!> @brief
+ !> This function extract level over domain on each grid point, and return
+ !> array of variable structure
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] td_level array of level variable structure
+ !> @param[in] td_dom array of domain structure
+ !> @return array of variable structure
+ !-------------------------------------------------------------------
+ FUNCTION create_boundary_get_level(td_level, td_dom)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_level
+ TYPE(TDOM), DIMENSION(:), INTENT(IN) :: td_dom
+
+ ! function
+ TYPE(TVAR), DIMENSION(ip_npoint) :: create_boundary_get_level
+
+ ! local variable
+ TYPE(TVAR), DIMENSION(ip_npoint) :: tl_var
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ IF( SIZE(td_level(:)) /= ip_npoint .OR. &
+ & SIZE(td_dom(:)) /= ip_npoint )THEN
+ CALL logger_error("CREATE BDY GET LEVEL: invalid dimension. "//&
+ & "check input array of level and domain.")
+ ELSE
+
+ DO ji=1,ip_npoint
+
+ tl_var(ji)=var_copy(td_level(ji))
+
+ IF( ASSOCIATED(tl_var(ji)%d_value) ) DEALLOCATE(tl_var(ji)%d_value)
+
+ tl_var(ji)%t_dim(1)%i_len=td_dom(ji)%t_dim(1)%i_len
+ tl_var(ji)%t_dim(2)%i_len=td_dom(ji)%t_dim(2)%i_len
+ ALLOCATE(tl_var(ji)%d_value(tl_var(ji)%t_dim(1)%i_len, &
+ & tl_var(ji)%t_dim(2)%i_len, &
+ & tl_var(ji)%t_dim(3)%i_len, &
+ & tl_var(ji)%t_dim(4)%i_len) )
+
+ tl_var(ji)%d_value(:,:,:,:) = &
+ & td_level(ji)%d_value( td_dom(ji)%i_imin:td_dom(ji)%i_imax, &
+ & td_dom(ji)%i_jmin:td_dom(ji)%i_jmax, :, : )
+
+ ENDDO
+ ! save result
+ create_boundary_get_level(:)=var_copy(tl_var(:))
+
+ ! clean
+ CALL var_clean(tl_var(:))
+
+ ENDIF
+ END FUNCTION create_boundary_get_level
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine get depth variable value in an open mpp structure
+ !> and check if agree with already input depth variable.
!>
!> @details
!>
!> @author J.Paul
- !> - 2013- Initial Version
+ !> - November, 2014- Initial Version
!>
- !-------------------------------------------------------------------
- !> @code
- FUNCTION create_bdy_get_level(td_level, td_dom)
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_depth depth variable structure
+ !-------------------------------------------------------------------
+ SUBROUTINE create_boundary_check_depth( td_mpp, td_depth )
+
IMPLICIT NONE
+
! Argument
- TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_level
- TYPE(TDOM) , INTENT(IN) :: td_dom
-
- ! function
- TYPE(TVAR), DIMENSION(ig_npoint) :: create_bdy_get_level
+ TYPE(TMPP) , INTENT(IN ) :: td_mpp
+ TYPE(TVAR) , INTENT(INOUT) :: td_depth
! local variable
- TYPE(TVAR), DIMENSION(ig_npoint) :: tl_var
-
+ INTEGER(i4) :: il_varid
+ TYPE(TVAR) :: tl_depth
! loop indices
- INTEGER(i4) :: ji
!----------------------------------------------------------------
- IF( SIZE(td_level(:)) /= ig_npoint )THEN
- CALL logger_error("CREATE BDY GET LEVEL: invalid dimension. "//&
- & "check input table of level.")
- ELSE
-
- !tl_var(1:ig_npoint)=td_level(1:ig_npoint)
- create_bdy_get_level(:)=tl_var(:)
- DO ji=1,ig_npoint
-
- tl_var(ji)=td_level(ji)
-
- IF( ASSOCIATED(tl_var(ji)%d_value) ) DEALLOCATE( tl_var(ji)%d_value )
-
- tl_var(ji)%t_dim(1)%i_len=td_dom%t_dim(1)%i_len
- tl_var(ji)%t_dim(2)%i_len=td_dom%t_dim(2)%i_len
- ALLOCATE(tl_var(ji)%d_value(tl_var(ji)%t_dim(1)%i_len, &
- & tl_var(ji)%t_dim(2)%i_len, &
- & tl_var(ji)%t_dim(3)%i_len, &
- & tl_var(ji)%t_dim(4)%i_len) )
-
- tl_var(ji)%d_value(:,:,:,:) = &
- & td_level(ji)%d_value( td_dom%i_imin:td_dom%i_imax, &
- & td_dom%i_jmin:td_dom%i_jmax, :, : )
-
- ENDDO
- !4 save result
- create_bdy_get_level(:)=tl_var(:)
+ ! get or check depth value
+ IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN
+
+ il_varid=td_mpp%t_proc(1)%i_depthid
+ IF( ASSOCIATED(td_depth%d_value) )THEN
+
+ tl_depth=iom_mpp_read_var(td_mpp, il_varid)
+ IF( ANY( td_depth%d_value(:,:,:,:) /= &
+ & tl_depth%d_value(:,:,:,:) ) )THEN
+
+ CALL logger_fatal("CREATE BOUNDARY: depth value from "//&
+ & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//&
+ & " to those from former file(s).")
+
+ ENDIF
+ CALL var_clean(tl_depth)
+
+ ELSE
+ td_depth=iom_mpp_read_var(td_mpp,il_varid)
+ ENDIF
ENDIF
- END FUNCTION create_bdy_get_level
- !> @endcode
+
+ END SUBROUTINE create_boundary_check_depth
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine get date and time in an open mpp structure
+ !> and check if agree with date and time already read.
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - November, 2014- Initial Version
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_time time variable structure
+ !-------------------------------------------------------------------
+ SUBROUTINE create_boundary_check_time( td_mpp, td_time )
+
+ IMPLICIT NONE
+
+ ! Argument
+ TYPE(TMPP), INTENT(IN ) :: td_mpp
+ TYPE(TVAR), INTENT(INOUT) :: td_time
+
+ ! local variable
+ INTEGER(i4) :: il_varid
+ TYPE(TVAR) :: tl_time
+
+ TYPE(TDATE) :: tl_date1
+ TYPE(TDATE) :: tl_date2
+ ! loop indices
+ !----------------------------------------------------------------
+
+ ! get or check depth value
+ IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN
+
+ il_varid=td_mpp%t_proc(1)%i_timeid
+ IF( ASSOCIATED(td_time%d_value) )THEN
+
+ tl_time=iom_mpp_read_var(td_mpp, il_varid)
+
+ tl_date1=var_to_date(td_time)
+ tl_date2=var_to_date(tl_time)
+ IF( tl_date1 - tl_date2 /= 0 )THEN
+
+ CALL logger_fatal("CREATE BOUNDARY: date from "//&
+ & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//&
+ & " to those from former file(s).")
+
+ ENDIF
+ CALL var_clean(tl_time)
+
+ ELSE
+ td_time=iom_mpp_read_var(td_mpp,il_varid)
+ ENDIF
+
+ ENDIF
+
+ END SUBROUTINE create_boundary_check_time
END PROGRAM create_boundary
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_coord.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_coord.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_coord.f90 (revision 5214)
@@ -7,26 +7,101 @@
!
! DESCRIPTION:
+!> @file
!> @brief
-!> This program create coordinate file.
+!> This program create fine grid coordinate file.
!>
!> @details
-!> Variables are extracted from the input coordinates coarse grid,
-!> and interpolated to create fine coordinates files.
-!>
-!> @author
-!> J.Paul
+!> @section sec1 method
+!> All variables from the input coordinates coarse grid file, are extracted
+!> and interpolated to create fine grid coordinates files.
+!> @note
+!> interpolation method could be different for each variable.
+!>
+!> @section sec2 how to
+!> to create fine grid coordinates files:
+!> @code{.sh}
+!> ./SIREN/bin/create_coord create_coord.nam
+!> @endcode
+!>
+!> create_coord.nam comprise 6 namelists:
+!> - logger namelist (namlog)
+!> - config namelist (namcfg)
+!> - coarse grid namelist (namcrs)
+!> - variable namelist (namvar)
+!> - nesting namelist (namnst)
+!> - output namelist (namout)
+!>
+!> @note
+!> All namelists have to be in file create_coord.nam,
+!> however variables of those namelists are all optional.
+!>
+!> * _logger namelist (namlog)_:
+!> - cn_logfile : log filename
+!> - cn_verbosity : verbosity ('trace','debug','info',
+!> 'warning','error','fatal')
+!> - in_maxerror : maximum number of error allowed
+!>
+!> * _config namelist (namcfg)_:
+!> - cn_varcfg : variable configuration file
+!> (see ./SIREN/cfg/variable.cfg)
+!>
+!> * _coarse grid namelist (namcrs)_:
+!> - cn_coord0 : coordinate file
+!> - in_perio0 : NEMO periodicity index (see Model Boundary Condition in
+!> [NEMO documentation](http://www.nemo-ocean.eu/About-NEMO/Reference-manuals))
+!>
+!> * _variable namelist (namvar)_:
+!> - cn_varinfo : list of variable and extra information about request(s)
+!> to be used.
+!> each elements of *cn_varinfo* is a string character.
+!> it is composed of the variable name follow by ':',
+!> then request(s) to be used on this variable.
+!> request could be:
+!> - interpolation method
+!> - extrapolation method
+!> - filter method
+!>
+!> requests must be separated by ';' .
+!> order of requests does not matter.
+!>
+!> informations about available method could be find in @ref interp,
+!> @ref extrap and @ref filter modules.
+!>
+!> Example: 'votemper: linear; hann(2,3); dist_weight',
+!> 'vosaline: cubic'
+!> @note
+!> If you do not specify a method which is required,
+!> default one is applied.
+!>
+!> * _nesting namelist (namnst)_:
+!> - in_imin0 : i-direction lower left point indice
+!> of coarse grid subdomain to be used
+!> - in_imax0 : i-direction upper right point indice
+!> of coarse grid subdomain to be used
+!> - in_jmin0 : j-direction lower left point indice
+!> of coarse grid subdomain to be used
+!> - in_jmax0 : j-direction upper right point indice
+!> of coarse grid subdomain to be used
+!> - in_rhoi : refinement factor in i-direction
+!> - in_rhoj : refinement factor in j-direction
+!>
+!> \image html grid_zoom_40.png
+!> \image latex grid_zoom_40.png
+!>
+!> * _output namelist (namout)_:
+!> - cn_fileout : output coordinate file
+!>
+!> @author J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
+!> @date November, 2013 - Initial Version
+!> @date September, 2014
+!> - add header for user
+!> - compute offset considering grid point
+!> - add global attributes in output file
+!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!>
-!> @todo
-!> - add extrapolation (case coordin with mask)
-!> - add extraction from a grid at fine resolution
!----------------------------------------------------------------------
-!> @code
PROGRAM create_coord
-! USE netcdf ! nf90 library
USE global ! global variable
USE kind ! F90 kind parameter
@@ -39,5 +114,4 @@
USE file ! file manager
USE iom ! I/O manager
- USE dom ! domain manager
USE grid ! grid manager
USE extrap ! extrapolation manager
@@ -45,5 +119,7 @@
USE filter ! filter manager
USE mpp ! MPP manager
+ USE dom ! domain manager
USE iom_mpp ! MPP I/O manager
+ USE iom_dom ! DOM I/O manager
IMPLICIT NONE
@@ -56,8 +132,10 @@
INTEGER(i4) :: il_status
INTEGER(i4) :: il_fileid
+ INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_ind
INTEGER(i4) :: il_nvar
-! INTEGER(i4) , DIMENSION(:,:,:,:) , ALLOCATABLE :: il_value
+ INTEGER(i4) :: il_ew
INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho
-
+ INTEGER(i4) , DIMENSION(2,2,ip_npoint) :: il_offset
LOGICAL :: ll_exist
@@ -71,22 +149,30 @@
TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
- TYPE(TFILE) :: tl_coord0
+ TYPE(TMPP) :: tl_coord0
TYPE(TFILE) :: tl_fileout
- TYPE(TMPP) :: tl_mppcoordin
+ ! check
+! INTEGER(i4) :: il_imin0
+! INTEGER(i4) :: il_imax0
+! INTEGER(i4) :: il_jmin0
+! INTEGER(i4) :: il_jmax0
+! INTEGER(i4) , DIMENSION(2,2) :: il_ind2
+! TYPE(TMPP) :: tl_mppout
! loop indices
INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
! namelist variable
CHARACTER(LEN=lc) :: cn_logfile = 'create_coord.log'
CHARACTER(LEN=lc) :: cn_verbosity = 'warning'
+ INTEGER(i4) :: in_maxerror = 5
CHARACTER(LEN=lc) :: cn_coord0 = ''
INTEGER(i4) :: in_perio0 = -1
- CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg'
-
- CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varinfo = ''
+ CHARACTER(LEN=lc) :: cn_varcfg = '../cfg/variable.cfg'
+
+ CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''
INTEGER(i4) :: in_imin0 = 0
@@ -100,21 +186,22 @@
!-------------------------------------------------------------------
- NAMELIST /namlog/ & !< logger namelist
- & cn_logfile, & !< log file
- & cn_verbosity !< logger verbosity
-
- NAMELIST /namcfg/ & !< config namelist
+ NAMELIST /namlog/ & ! logger namelist
+ & cn_logfile, & !< logger file name
+ & cn_verbosity, & !< logger verbosity
+ & in_maxerror !< logger maximum error
+
+ NAMELIST /namcfg/ & ! config namelist
& cn_varcfg !< variable configuration file
- NAMELIST /namcrs/ & ! coarse grid namelist
+ NAMELIST /namcrs/ & ! coarse grid namelist
& cn_coord0 , & !< coordinate file
& in_perio0 !< periodicity index
- NAMELIST /namvar/ & ! namvar
+ NAMELIST /namvar/ & ! variable namelist
& cn_varinfo !< list of variable and extra information about
!< interpolation, extrapolation or filter method to be used.
- !< (ex: 'votemper/linear/hann/dist_weight','vosaline/cubic' )
+ !< (ex: 'votemper:linear,hann,dist_weight','vosaline:cubic' )
- NAMELIST /namnst/ & !< nesting namelist
+ NAMELIST /namnst/ & ! nesting namelist
& in_imin0, & !< i-direction lower left point indice
& in_imax0, & !< i-direction upper right point indice
@@ -124,10 +211,10 @@
& in_rhoj !< refinement factor in j-direction
- NAMELIST /namout/ & !< output namelist
- & cn_fileout !< fine grid coordinate file
+ NAMELIST /namout/ & ! output namelist
+ & cn_fileout !< fine grid coordinate file
!-------------------------------------------------------------------
- !1- namelist
- !1-1 get namelist
+ ! namelist
+ ! get namelist
il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
IF( il_narg/=1 )THEN
@@ -138,8 +225,8 @@
ENDIF
- !1-2 read namelist
+ ! read namelist
INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist)
IF( ll_exist )THEN
-
+
il_fileid=fct_getunit()
@@ -157,15 +244,15 @@
READ( il_fileid, NML = namlog )
- !1-2-1 define log file
- CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity))
+ ! define logger file
+ CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror)
CALL logger_header()
READ( il_fileid, NML = namcfg )
- !1-2-2 get variable extra information on configuration file
+ ! get variable extra information on configuration file
CALL var_def_extra(TRIM(cn_varcfg))
READ( il_fileid, NML = namcrs )
READ( il_fileid, NML = namvar )
- !1-2-3 add user change in extra information
+ ! add user change in extra information
CALL var_chg_extra( cn_varinfo )
@@ -182,18 +269,19 @@
PRINT *,"ERROR in create_coord: can't find "//TRIM(cl_namelist)
-
- ENDIF
-
- !2- open files
+ STOP
+
+ ENDIF
+
+ ! open files
IF( cn_coord0 /= '' )THEN
- tl_coord0=file_init(TRIM(cn_coord0),id_perio=in_perio0)
- CALL iom_open(tl_coord0)
+ tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0)
+ CALL grid_get_info(tl_coord0)
ELSE
- CALL logger_fatal("CREATE COORD: no coarse grid coordinate found. "//&
+ CALL logger_fatal("CREATE COORD: no coarse grid coordinate found. "//&
& "check namelist")
ENDIF
- !3- check
- !3-1 check output file do not already exist
+ ! check
+ ! check output file do not already exist
INQUIRE(FILE=TRIM(cn_fileout), EXIST=ll_exist)
IF( ll_exist )THEN
@@ -202,7 +290,7 @@
ENDIF
- !3-2 check namelist
- IF( in_imin0 < 1 .OR. in_imax0 < 1 .OR. in_jmin0 < 1 .OR. in_jmax0 < 1)THEN
- CALL logger_error("CREATE COORD: invalid point indice."//&
+ ! check nesting parameters
+ IF( in_imin0 < 0 .OR. in_imax0 < 0 .OR. in_jmin0 < 0 .OR. in_jmax0 < 0)THEN
+ CALL logger_fatal("CREATE COORD: invalid points indices."//&
& " check namelist "//TRIM(cl_namelist))
ENDIF
@@ -215,67 +303,68 @@
il_rho(jp_I)=in_rhoi
il_rho(jp_J)=in_rhoj
- ENDIF
-
- !3-3 check domain validity
+
+ il_offset(:,:,:)=create_coord_get_offset(il_rho(:))
+
+ ENDIF
+
+ ! check domain validity
CALL grid_check_dom(tl_coord0, in_imin0, in_imax0, in_jmin0, in_jmax0 )
- !4- compute domain
+ ! compute domain
tl_dom=dom_init( tl_coord0, &
& in_imin0, in_imax0,&
& in_jmin0, in_jmax0 )
- ! close file
- CALL iom_close(tl_coord0)
-
- !4-1 add extra band (if possible) to compute interpolation
+ ! add extra band (if need be) to compute interpolation
CALL dom_add_extra(tl_dom)
- !5- read variables on domain (ugly way to do it, have to work on it)
- !5-1 init mpp structure
- tl_mppcoordin=mpp_init(tl_coord0)
-
- CALL file_clean(tl_coord0)
-
- !5-2 get processor to be used
- CALL mpp_get_use( tl_mppcoordin, tl_dom )
-
- !5-3 open mpp files
- CALL iom_mpp_open(tl_mppcoordin)
-
- !5-4 fill variable value on domain
- CALL iom_mpp_fill_var(tl_mppcoordin, tl_dom)
-
- !5-5 close mpp files
- CALL iom_mpp_close(tl_mppcoordin)
-
- il_nvar=tl_mppcoordin%t_proc(1)%i_nvar
+ ! open mpp files
+ CALL iom_dom_open(tl_coord0, tl_dom)
+
+ il_nvar=tl_coord0%t_proc(1)%i_nvar
ALLOCATE( tl_var(il_nvar) )
DO ji=1,il_nvar
- tl_var(ji)=tl_mppcoordin%t_proc(1)%t_var(ji)
- !7- interpolate variables
- CALL create_coord_interp( tl_var(ji), il_rho(:) )
-
- !6- remove extraband added to domain
- CALL dom_del_extra( tl_var(ji), tl_dom, il_rho(:) )
-
- !7- add ghost cell
- CALL grid_add_ghost(tl_var(ji),tl_dom%i_ighost,tl_dom%i_jghost)
-
- !8- filter
+ tl_var(ji)=iom_dom_read_var(tl_coord0, &
+ & TRIM(tl_coord0%t_proc(1)%t_var(ji)%c_name),&
+ & tl_dom)
+
+ SELECT CASE(TRIM(tl_var(ji)%c_point))
+ CASE('T')
+ jj=jp_T
+ CASE('U')
+ jj=jp_U
+ CASE('V')
+ jj=jp_V
+ CASE('F')
+ jj=jp_F
+ END SELECT
+
+ ! interpolate variables
+ CALL create_coord_interp( tl_var(ji), il_rho(:), &
+ & il_offset(:,:,jj) )
+
+ ! remove extraband added to domain
+ CALL dom_del_extra( tl_var(ji), tl_dom, il_rho(:), .true. )
+
+ ! do not add ghost cell.
+ ! ghost cell already replace by value for coordinates
+ ! CALL grid_add_ghost(tl_var(ji),tl_dom%i_ghost(:,:))
+
+ ! filter
CALL filter_fill_value(tl_var(ji))
ENDDO
- !9- clean
- DO ji=1,il_nvar
- CALL var_clean(tl_mppcoordin%t_proc(1)%t_var(ji))
- ENDDO
- CALL mpp_clean(tl_mppcoordin)
-
- !10- create file
+ ! close mpp files
+ CALL iom_dom_close(tl_coord0)
+
+ ! clean
+ CALL mpp_clean(tl_coord0)
+
+ ! create file
tl_fileout=file_init(TRIM(cn_fileout))
- !10-1 add dimension
+ ! add dimension
! save biggest dimension
tl_dim(:)=var_max_dim(tl_var(:))
@@ -285,11 +374,12 @@
ENDDO
- !10-2 add variables
-
+ ! add variables
DO ji=1,il_nvar
CALL file_add_var(tl_fileout, tl_var(ji))
ENDDO
- !10-3 add some attribute
+ ! recompute some attribute
+
+ ! add some attribute
tl_att=att_init("Created_by","SIREN create_coord")
CALL file_add_att(tl_fileout, tl_att)
@@ -299,50 +389,158 @@
CALL file_add_att(tl_fileout, tl_att)
- tl_att=att_init("source_file",TRIM(fct_basename(cn_coord0)))
+ tl_att=att_init("src_file",TRIM(fct_basename(cn_coord0)))
CALL file_add_att(tl_fileout, tl_att)
- tl_att=att_init("source_i-indices",(/in_imin0,in_imax0/))
+ tl_att=att_init("src_i_indices",(/in_imin0,in_imax0/))
CALL file_add_att(tl_fileout, tl_att)
- tl_att=att_init("source_j-indices",(/in_jmin0,in_jmax0/))
- CALL file_add_att(tl_fileout, tl_att)
-
- !10-4 create file
+ tl_att=att_init("src_j_indices",(/in_jmin0,in_jmax0/))
+ CALL file_add_att(tl_fileout, tl_att)
+ IF( .NOT. ALL(il_rho(:)==1) )THEN
+ tl_att=att_init("refinment_factor",(/il_rho(jp_I),il_rho(jp_J)/))
+ CALL file_add_att(tl_fileout, tl_att)
+ ENDIF
+
+ ! add attribute periodicity
+ il_attid=0
+ IF( ASSOCIATED(tl_fileout%t_att) )THEN
+ il_attid=att_get_index(tl_fileout%t_att(:),'periodicity')
+ ENDIF
+ IF( tl_dom%i_perio >= 0 .AND. il_attid == 0 )THEN
+ tl_att=att_init('periodicity',tl_dom%i_perio)
+ CALL file_add_att(tl_fileout,tl_att)
+ ENDIF
+
+ ! add attribute east west overlap
+ il_attid=0
+ IF( ASSOCIATED(tl_fileout%t_att) )THEN
+ il_attid=att_get_index(tl_fileout%t_att(:),'ew_overlap')
+ ENDIF
+ IF( il_attid == 0 )THEN
+ il_ind=var_get_index(tl_fileout%t_var(:),'longitude')
+ il_ew=grid_get_ew_overlap(tl_fileout%t_var(il_ind))
+ IF( il_ew >= 0 )THEN
+ tl_att=att_init('ew_overlap',il_ew)
+ CALL file_add_att(tl_fileout,tl_att)
+ ENDIF
+ ENDIF
+
+ ! create file
CALL iom_create(tl_fileout)
- !10-5 write file
+ ! write file
CALL iom_write_file(tl_fileout)
- !10-6 close file
+ ! close file
CALL iom_close(tl_fileout)
- !11- clean
- DO ji=1,il_nvar
- CALL var_clean(tl_var(ji))
- ENDDO
+ ! clean
+ CALL att_clean(tl_att)
+ CALL var_clean(tl_var(:))
+ DEALLOCATE( tl_var)
+
CALL file_clean(tl_fileout)
- DEALLOCATE( tl_var)
+! ! check domain
+! tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0)
+! tl_mppout=mpp_init( file_init(TRIM(cn_fileout)) )
+! CALL grid_get_info(tl_coord0)
+! CALL iom_mpp_open(tl_mppout)
+!
+! il_ind2(:,:)=grid_get_coarse_index( tl_coord0, tl_mppout, &
+! & id_rho=il_rho(:) )
+!
+! il_imin0=il_ind2(1,1) ; il_imax0=il_ind2(1,2)
+! il_jmin0=il_ind2(2,1) ; il_jmax0=il_ind2(2,2)
+!
+! IF( il_imin0 /= in_imin0 .OR. &
+! & il_imax0 /= in_imax0 .OR. &
+! & il_jmin0 /= in_jmin0 .OR. &
+! & il_jmax0 /= in_jmax0 )THEN
+! CALL logger_debug("CREATE COORD: output indices ("//&
+! & TRIM(fct_str(il_imin0))//","//&
+! & TRIM(fct_str(il_imax0))//") ("//&
+! & TRIM(fct_str(il_jmin0))//","//&
+! & TRIM(fct_str(il_jmax0))//")" )
+! CALL logger_debug("CREATE COORD: input indices ("//&
+! & TRIM(fct_str(in_imin0))//","//&
+! & TRIM(fct_str(in_imax0))//") ("//&
+! & TRIM(fct_str(in_jmin0))//","//&
+! & TRIM(fct_str(in_jmax0))//")" )
+! CALL logger_fatal("CREATE COORD: output domain not confrom "//&
+! & "with input indices")
+! ENDIF
+!
+! CALL iom_mpp_close(tl_coord0)
+! CALL iom_mpp_close(tl_mppout)
! close log file
CALL logger_footer()
- CALL logger_close()
-
-!> @endcode
+ CALL logger_close()
+
CONTAINS
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This function compute offset over Arakawa grid points,
+ !> given refinement factor.
+ !>
+ !> @author J.Paul
+ !> @date August, 2014 - Initial Version
+ !>
+ !> @param[in] id_rho array of refinement factor
+ !> @return array of offset
+ !-------------------------------------------------------------------
+ FUNCTION create_coord_get_offset( id_rho )
+ IMPLICIT NONE
+ ! Argument
+ INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_rho
+
+ ! function
+ INTEGER(i4), DIMENSION(2,2,ip_npoint) :: create_coord_get_offset
+ ! local variable
+ ! loop indices
+ !----------------------------------------------------------------
+
+ ! case 'T'
+ create_coord_get_offset(jp_I,:,jp_T)=FLOOR(REAL(id_rho(jp_I)-1,dp)*0.5)
+ create_coord_get_offset(jp_J,:,jp_T)=FLOOR(REAL(id_rho(jp_J)-1,dp)*0.5)
+ ! case 'U'
+ create_coord_get_offset(jp_I,1,jp_U)=0
+ create_coord_get_offset(jp_I,2,jp_U)=id_rho(jp_I)-1
+ create_coord_get_offset(jp_J,:,jp_U)=FLOOR(REAL(id_rho(jp_J)-1,dp)*0.5)
+ ! case 'V'
+ create_coord_get_offset(jp_I,:,jp_V)=FLOOR(REAL(id_rho(jp_I)-1,dp)*0.5)
+ create_coord_get_offset(jp_J,1,jp_V)=0
+ create_coord_get_offset(jp_J,2,jp_V)=id_rho(jp_J)-1
+ ! case 'F'
+ create_coord_get_offset(jp_I,1,jp_F)=0
+ create_coord_get_offset(jp_I,2,jp_F)=id_rho(jp_I)-1
+ create_coord_get_offset(jp_J,1,jp_F)=0
+ create_coord_get_offset(jp_J,2,jp_F)=id_rho(jp_J)-1
+
+
+ END FUNCTION create_coord_get_offset
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine interpolate variable, given refinment factor.
!>
!> @details
+ !> Optionaly, you could specify number of points
+ !> to be extrapolated in i- and j-direction.
+ !> variable mask is first computed (using _FillValue) and interpolated.
+ !> variable is then extrapolated, and interpolated.
+ !> Finally interpolated mask is applied on refined variable.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> @date November, 2013 - Initial Version
!>
- !> @param[in]
- !> @todo
+ !> @param[inout] td_var variable strcuture
+ !> @param[in] id_rho array of refinement factor
+ !> @param[in] id_offset offset between fine grid and coarse grid
+ !> @param[in] id_iext number of points to be extrapolated in i-direction
+ !> @param[in] id_jext number of points to be extrapolated in j-direction
!-------------------------------------------------------------------
- !> @code
SUBROUTINE create_coord_interp( td_var, &
& id_rho, &
+ & id_offset, &
& id_iext, id_jext)
@@ -350,16 +548,14 @@
! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_var
- INTEGER(i4), DIMENSION(:), INTENT(IN ) :: id_rho
- INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext
- INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
+ INTEGER(i4), DIMENSION(:) , INTENT(IN ) :: id_rho
+ INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_offset
+ INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext
+ INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext
! local variable
TYPE(TVAR) :: tl_mask
- TYPE(TVAR) :: tl_var
INTEGER(i1), DIMENSION(:,:,:,:), ALLOCATABLE :: bl_mask
-
- INTEGER(i4), DIMENSION(2,2) :: il_offset
INTEGER(i4) :: il_iext
@@ -369,6 +565,8 @@
!----------------------------------------------------------------
- ! copy variable
- tl_var=td_var
+ IF( ANY(SHAPE(id_offset(:,:)) /= 2) )THEN
+ CALL logger_error("CREATE COORD INTERP: invalid dimension of "//&
+ & "offset array")
+ ENDIF
!WARNING: two extrabands are required for cubic interpolation
@@ -391,60 +589,59 @@
ENDIF
- !1- work on mask
- !1-1 create mask
- ALLOCATE(bl_mask(tl_var%t_dim(1)%i_len, &
- & tl_var%t_dim(2)%i_len, &
- & tl_var%t_dim(3)%i_len, &
- & tl_var%t_dim(4)%i_len) )
-
- bl_mask(:,:,:,:)=1
- WHERE(tl_var%d_value(:,:,:,:)==tl_var%d_fill) bl_mask(:,:,:,:)=0
-
- SELECT CASE(TRIM(tl_var%c_point))
- CASE DEFAULT ! 'T'
- tl_mask=var_init('tmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
- CASE('U')
- tl_mask=var_init('umask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
- CASE('V')
- tl_mask=var_init('vmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
- CASE('F')
- tl_mask=var_init('fmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
- END SELECT
-
- DEALLOCATE(bl_mask)
-
- !1-2 interpolate mask
- il_offset(:,:)=1
- CALL interp_fill_value( tl_mask, id_rho(:), &
- & id_offset=il_offset(:,:) )
-
- !2- work on variable
- !2-0 add extraband
- CALL extrap_add_extrabands(tl_var, il_iext, il_jext)
-
- !2-1 extrapolate variable
- CALL extrap_fill_value( tl_var, id_iext=il_iext, id_jext=il_jext )
-
- !2-2 interpolate variable
- il_offset(:,:)=1
- CALL interp_fill_value( tl_var, id_rho(:), &
- & id_offset=il_offset(:,:))
-
- !2-3 remove extraband
- CALL extrap_del_extrabands(tl_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
-
- !3- keep original mask
- WHERE( tl_mask%d_value(:,:,:,:) == 0 )
- tl_var%d_value(:,:,:,:)=tl_var%d_fill
- END WHERE
-
- !4- save result
- td_var=tl_var
+ IF( ANY(id_rho(:)>1) )THEN
+ ! work on mask
+ ! create mask
+ ALLOCATE(bl_mask(td_var%t_dim(1)%i_len, &
+ & td_var%t_dim(2)%i_len, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len) )
+
+ bl_mask(:,:,:,:)=1
+ WHERE(td_var%d_value(:,:,:,:)==td_var%d_fill) bl_mask(:,:,:,:)=0
+
+ SELECT CASE(TRIM(td_var%c_point))
+ CASE DEFAULT ! 'T'
+ tl_mask=var_init('tmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),&
+ & id_ew=td_var%i_ew )
+ CASE('U')
+ tl_mask=var_init('umask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),&
+ & id_ew=td_var%i_ew )
+ CASE('V')
+ tl_mask=var_init('vmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),&
+ & id_ew=td_var%i_ew )
+ CASE('F')
+ tl_mask=var_init('fmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),&
+ & id_ew=td_var%i_ew )
+ END SELECT
+
+ DEALLOCATE(bl_mask)
+
+ ! interpolate mask
+ CALL interp_fill_value( tl_mask, id_rho(:), &
+ & id_offset=id_offset(:,:) )
+
+ ! work on variable
+ ! add extraband
+ CALL extrap_add_extrabands(td_var, il_iext, il_jext)
+
+ ! extrapolate variable
+ CALL extrap_fill_value( td_var, id_iext=il_iext, id_jext=il_jext )
+
+ ! interpolate variable
+ CALL interp_fill_value( td_var, id_rho(:), &
+ & id_offset=id_offset(:,:))
+
+ ! remove extraband
+ CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
+
+ ! keep original mask
+ WHERE( tl_mask%d_value(:,:,:,:) == 0 )
+ td_var%d_value(:,:,:,:)=td_var%d_fill
+ END WHERE
+ ENDIF
! clean variable structure
CALL var_clean(tl_mask)
- CALL var_clean(tl_var)
END SUBROUTINE create_coord_interp
- !> @endcode
END PROGRAM create_coord
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_restart.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_restart.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/create_restart.f90 (revision 5214)
@@ -7,27 +7,150 @@
!
! DESCRIPTION:
+!> @file
!> @brief
!> This program create restart file.
!>
!> @details
-!> Variables are read from restart file, or standard output.
-!> Then theses variables are interpolated on fine grid.
-!> Finally table are split over new decomposition.
-!>
-!> @author
-!> J.Paul
+!> @section sec1 method
+!> Variables could be extracted from fine grid file, interpolated from coarse
+!> grid file or restart file, or manually written.
+!> Then they are split over new decomposition.
+!> @note
+!> method could be different for each variable.
+!>
+!> @section sec2 how to
+!> to create restart file:
+!> @code{.sh}
+!> ./SIREN/bin/create_restart create_restart.nam
+!> @endcode
+!>
+!> create_restart.nam comprise 9 namelists:
+!> - logger namelist (namlog)
+!> - config namelist (namcfg)
+!> - coarse grid namelist (namcrs)
+!> - fine grid namelist (namfin)
+!> - vertical grid namelist (namzgr)
+!> - partial step namelist (namzps)
+!> - variable namelist (namvar)
+!> - nesting namelist (namnst)
+!> - output namelist (namout)
+!>
+!> @note
+!> All namelists have to be in file create_restart.nam
+!> however variables of those namelists are all optional.
+!>
+!> * _logger namelist (namlog)_:
+!> - cn_logfile : log filename
+!> - cn_verbosity : verbosity ('trace','debug','info',
+!> 'warning','error','fatal')
+!> - in_maxerror : maximum number of error allowed
+!>
+!> * _config namelist (namcfg)_:
+!> - cn_varcfg : variable configuration file
+!> (see ./SIREN/cfg/variable.cfg)
+!>
+!> * _coarse grid namelist (namcrs):
+!> - cn_coord0 : coordinate file
+!> - in_perio0 : NEMO periodicity index (see Model Boundary Condition in
+!> [NEMO documentation](http://www.nemo-ocean.eu/About-NEMO/Reference-manuals))
+!>
+!> * _fine grid namelist (namfin)_:
+!> - cn_coord1 : coordinate file
+!> - cn_bathy1 : bathymetry file
+!> - in_perio1 : NEMO periodicity index
+!> - in_extrap : number of land point to be extrapolated
+!> before writing file
+!>
+!> * _vertical grid namelist (namzgr)_:
+!> - dn_pp_to_be_computed :
+!> - dn_ppsur :
+!> - dn_ppa0 :
+!> - dn_ppa1 :
+!> - dn_ppa2 :
+!> - dn_ppkth :
+!> - dn_ppkth2 :
+!> - dn_ppacr :
+!> - dn_ppacr2 :
+!> - dn_ppdzmin :
+!> - dn_pphmax :
+!> - in_nlevel : number of vertical level
+!>
+!> * _partial step namelist (namzps)_:
+!> - dn_e3zps_min :
+!> - dn_e3zps_rat :
+!>
+!> * _variable namelist (namvar)_:
+!> - cn_varinfo : list of variable and extra information about request(s)
+!> to be used.
+!> each elements of *cn_varinfo* is a string character.
+!> it is composed of the variable name follow by ':',
+!> then request(s) to be used on this variable.
+!> request could be:
+!> - interpolation method
+!> - extrapolation method
+!> - filter method
+!> - > minimum value
+!> - < maximum value
+!>
+!> requests must be separated by ';'.
+!> order of requests does not matter.
+!>
+!> informations about available method could be find in @ref interp,
+!> @ref extrap and @ref filter.
+!> Example: 'votemper: linear; hann; dist_weight','vosaline: cubic'
+!> @note
+!> If you do not specify a method which is required,
+!> default one is apply.
+!> - cn_varfile : list of variable, and corresponding file
+!> *cn_varfile* is the path and filename of the file where find
+!> variable.
+!> @note
+!> *cn_varfile* could be a matrix of value, if you want to filled
+!> manually variable value.
+!> the variable array of value is split into equal subdomain.
+!> Each subdomain is filled with the corresponding value
+!> of the matrix.
+!> separators used to defined matrix are:
+!> - ',' for line
+!> - '/' for row
+!> - '\' for level
+!> Example:
+!> 3,2,3/1,4,5 => @f$ \left( \begin{array}{ccc}
+!> 3 & 2 & 3 \\
+!> 1 & 4 & 5 \end{array} \right) @f$
+!>
+!> Examples:
+!> - 'votemper:gridT.nc', 'vozocrtx:gridU.nc'
+!> - 'votemper:10\25', 'vozocrtx:gridU.nc'
+!>
+!> to get all variable from one file:
+!> - 'all:restart.dimg'
+!>
+!> * _nesting namelist (namnst)_:
+!> - in_rhoi : refinement factor in i-direction
+!> - in_rhoj : refinement factor in j-direction
+!> @note
+!> coarse grid indices will be deduced from fine grid
+!> coordinate file.
+!>
+!> * _output namelist (namout)_:
+!> - cn_fileout : output file
+!> - in_nproc : total number of processor to be used
+!> - in_niproc : i-direction number of processor
+!> - in_njproc : j-direction numebr of processor
+!> - cn_type : output format ('dimg', 'cdf')
+!>
+!> @author J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
+!> @date November, 2013 - Initial Version
+!> @date September, 2014
+!> - add header for user
+!> - offset computed considering grid point
+!> - add attributes in output variable
+!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!>
-!> @todo
-!> - add attributes indices and refinement in output file
-!> - check fileout exist at the beginning
!----------------------------------------------------------------------
-!> @code
PROGRAM create_restart
-! USE netcdf ! nf90 library
USE global ! global variable
USE kind ! F90 kind parameter
@@ -41,5 +164,4 @@
USE multi ! multi file manager
USE iom ! I/O manager
- USE dom ! domain manager
USE grid ! grid manager
USE vgrid ! vertical grid manager
@@ -48,5 +170,7 @@
USE filter ! filter manager
USE mpp ! MPP manager
+ USE dom ! domain manager
USE iom_mpp ! MPP I/O manager
+ USE iom_dom ! DOM I/O manager
IMPLICIT NONE
@@ -58,24 +182,26 @@
CHARACTER(LEN=lc) :: cl_name
CHARACTER(LEN=lc) :: cl_data
+ CHARACTER(LEN=lc) :: cl_fileout
INTEGER(i4) :: il_narg
INTEGER(i4) :: il_status
INTEGER(i4) :: il_fileid
+ INTEGER(i4) :: il_nvar
INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_imin1
+ INTEGER(i4) :: il_imax1
+ INTEGER(i4) :: il_jmin1
+ INTEGER(i4) :: il_jmax1
INTEGER(i4) :: il_imin0
INTEGER(i4) :: il_imax0
INTEGER(i4) :: il_jmin0
INTEGER(i4) :: il_jmax0
+ INTEGER(i4) :: il_index
INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho
- INTEGER(i4) , DIMENSION(2) :: il_xghost
+ INTEGER(i4) , DIMENSION(2,2) :: il_xghost
INTEGER(i4) , DIMENSION(2,2) :: il_offset
- INTEGER(i4) , DIMENSION(2,2,2) :: il_ind
+ INTEGER(i4) , DIMENSION(2,2) :: il_ind
LOGICAL :: ll_exist
-
- TYPE(TFILE) :: tl_coord0
- TYPE(TFILE) :: tl_coord1
- TYPE(TFILE) :: tl_bathy1
- TYPE(TFILE) :: tl_file
TYPE(TDOM) :: tl_dom1
@@ -88,5 +214,4 @@
TYPE(TVAR) :: tl_lon
TYPE(TVAR) :: tl_lat
- TYPE(TVAR) :: tl_tmp
TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_var
TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_level
@@ -94,6 +219,10 @@
TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
+ TYPE(TMPP) :: tl_coord0
+ TYPE(TMPP) :: tl_coord1
+ TYPE(TMPP) :: tl_bathy1
TYPE(TMPP) :: tl_mpp
TYPE(TMPP) :: tl_mppout
+
TYPE(TMULTI) :: tl_multi
@@ -104,29 +233,50 @@
! namelist variable
+ ! namlog
CHARACTER(LEN=lc) :: cn_logfile = 'create_restart.log'
CHARACTER(LEN=lc) :: cn_verbosity = 'warning'
-
+ INTEGER(i4) :: in_maxerror = 5
+
+ ! namcfg
CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg'
+ ! namcrs
CHARACTER(LEN=lc) :: cn_coord0 = ''
INTEGER(i4) :: in_perio0 = -1
+ ! namfin
CHARACTER(LEN=lc) :: cn_coord1 = ''
CHARACTER(LEN=lc) :: cn_bathy1 = ''
INTEGER(i4) :: in_perio1 = -1
INTEGER(i4) :: in_extrap = 0
- LOGICAL :: ln_fillclosed = .TRUE.
-
- CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varinfo = ''
- CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varfile = ''
-
- INTEGER(i4) :: in_imin0 = 0
- INTEGER(i4) :: in_imax0 = 0
- INTEGER(i4) :: in_jmin0 = 0
- INTEGER(i4) :: in_jmax0 = 0
+
+ !namzgr
+ REAL(dp) :: dn_pp_to_be_computed = 0._dp
+ REAL(dp) :: dn_ppsur = -3958.951371276829_dp
+ REAL(dp) :: dn_ppa0 = 103.9530096000000_dp
+ REAL(dp) :: dn_ppa1 = 2.4159512690000_dp
+ REAL(dp) :: dn_ppa2 = 100.7609285000000_dp
+ REAL(dp) :: dn_ppkth = 15.3510137000000_dp
+ REAL(dp) :: dn_ppkth2 = 48.0298937200000_dp
+ REAL(dp) :: dn_ppacr = 7.0000000000000_dp
+ REAL(dp) :: dn_ppacr2 = 13.000000000000_dp
+ REAL(dp) :: dn_ppdzmin = 6._dp
+ REAL(dp) :: dn_pphmax = 5750._dp
+ INTEGER(i4) :: in_nlevel = 75
+
+ !namzps
+ REAL(dp) :: dn_e3zps_min = 25._dp
+ REAL(dp) :: dn_e3zps_rat = 0.2_dp
+
+ ! namvar
+ CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''
+ CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''
+
+ ! namnst
INTEGER(i4) :: in_rhoi = 0
INTEGER(i4) :: in_rhoj = 0
- CHARACTER(LEN=lc) :: cn_fileout = 'restart'
+ ! namout
+ CHARACTER(LEN=lc) :: cn_fileout = 'restart.nc'
INTEGER(i4) :: in_nproc = 0
INTEGER(i4) :: in_niproc = 0
@@ -138,29 +288,43 @@
NAMELIST /namlog/ & !< logger namelist
& cn_logfile, & !< log file
- & cn_verbosity !< log verbosity
+ & cn_verbosity, & !< log verbosity
+ & in_maxerror !< logger maximum error
NAMELIST /namcfg/ & !< configuration namelist
& cn_varcfg !< variable configuration file
- NAMELIST /namcrs/ & !< coarse grid namelist
- & cn_coord0, & !< coordinate file
- & in_perio0 !< periodicity index
+ NAMELIST /namcrs/ & !< coarse grid namelist
+ & cn_coord0, & !< coordinate file
+ & in_perio0 !< periodicity index
- NAMELIST /namfin/ & !< fine grid namelist
- & cn_coord1, & !< coordinate file
- & cn_bathy1, & !< bathymetry file
- & in_perio1, & !< periodicity index
- & in_extrap, & !<
- & ln_fillclosed !< fill closed sea
+ NAMELIST /namfin/ & !< fine grid namelist
+ & cn_coord1, & !< coordinate file
+ & cn_bathy1, & !< bathymetry file
+ & in_perio1, & !< periodicity index
+ & in_extrap
+ NAMELIST /namzgr/ &
+ & dn_pp_to_be_computed, &
+ & dn_ppsur, &
+ & dn_ppa0, &
+ & dn_ppa1, &
+ & dn_ppa2, &
+ & dn_ppkth, &
+ & dn_ppkth2, &
+ & dn_ppacr, &
+ & dn_ppacr2, &
+ & dn_ppdzmin, &
+ & dn_pphmax, &
+ & in_nlevel !< number of vertical level
+
+ NAMELIST /namzps/ &
+ & dn_e3zps_min, &
+ & dn_e3zps_rat
+
NAMELIST /namvar/ & !< variable namelist
- & cn_varinfo, & !< list of variable and interpolation method to be used. (ex: 'votemper:linear','vosaline:cubic' )
+ & cn_varinfo, & !< list of variable and interpolation method to be used.
& cn_varfile !< list of variable file
NAMELIST /namnst/ & !< nesting namelist
- & in_imin0, & !< i-direction lower left point indice
- & in_imax0, & !< i-direction upper right point indice
- & in_jmin0, & !< j-direction lower left point indice
- & in_jmax0, & !< j-direction upper right point indice
& in_rhoi, & !< refinement factor in i-direction
& in_rhoj !< refinement factor in j-direction
@@ -174,6 +338,6 @@
!-------------------------------------------------------------------
- !1- namelist
- !1-1 get namelist
+ ! namelist
+ ! get namelist
il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
IF( il_narg/=1 )THEN
@@ -184,5 +348,5 @@
ENDIF
- !1-2 read namelist
+ ! read namelist
INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist)
IF( ll_exist )THEN
@@ -203,18 +367,19 @@
READ( il_fileid, NML = namlog )
- !1-2-1 define log file
- CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity))
+ ! define log file
+ CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror)
CALL logger_header()
READ( il_fileid, NML = namcfg )
- !1-2-2 get variable extra information
+ ! get variable extra information
CALL var_def_extra(TRIM(cn_varcfg))
READ( il_fileid, NML = namcrs )
READ( il_fileid, NML = namfin )
+ READ( il_fileid, NML = namzgr )
READ( il_fileid, NML = namvar )
- !1-2-3 add user change in extra information
+ ! add user change in extra information
CALL var_chg_extra(cn_varinfo)
- !1-2-4 match variable with file
+ ! match variable with file
tl_multi=multi_init(cn_varfile)
@@ -231,11 +396,19 @@
PRINT *,"ERROR in create_restart: can't find "//TRIM(cl_namelist)
-
- ENDIF
-
- !2- open files
+ STOP
+
+ ENDIF
+
+ !
+ CALL multi_print(tl_multi)
+ IF( tl_multi%i_nvar <= 0 )THEN
+ CALL logger_fatal("CREATE RESTART: no variable to be used."//&
+ & " check namelist.")
+ ENDIF
+
+ ! open files
IF( cn_coord0 /= '' )THEN
- tl_coord0=file_init(TRIM(cn_coord0),id_perio=in_perio0)
- CALL iom_open(tl_coord0)
+ tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0)
+ CALL grid_get_info(tl_coord0)
ELSE
CALL logger_fatal("CREATE RESTART: no coarse grid coordinate found. "//&
@@ -244,6 +417,6 @@
IF( TRIM(cn_coord1) /= '' )THEN
- tl_coord1=file_init(TRIM(cn_coord1),id_perio=in_perio1)
- CALL iom_open(tl_coord1)
+ tl_coord1=mpp_init( file_init(TRIM(cn_coord1)), id_perio=in_perio1)
+ CALL grid_get_info(tl_coord1)
ELSE
CALL logger_fatal("CREATE RESTART: no fine grid coordinate found. "//&
@@ -252,6 +425,6 @@
IF( TRIM(cn_bathy1) /= '' )THEN
- tl_bathy1=file_init(TRIM(cn_bathy1),id_perio=in_perio1)
- CALL iom_open(tl_bathy1)
+ tl_bathy1=mpp_init( file_init(TRIM(cn_bathy1)), id_perio=in_perio1)
+ CALL grid_get_info(tl_bathy1)
ELSE
CALL logger_fatal("CREATE RESTART: no fine grid bathymetry found. "//&
@@ -259,6 +432,14 @@
ENDIF
- !3- check
- !3-2-1 check refinement factor
+ ! check
+ ! check output file do not already exist
+ cl_fileout=file_rename(cn_fileout,1)
+ INQUIRE(FILE=TRIM(cl_fileout), EXIST=ll_exist)
+ IF( ll_exist )THEN
+ CALL logger_fatal("CREATE RESTART: output file "//TRIM(cl_fileout)//&
+ & " already exist.")
+ ENDIF
+
+ ! check refinement factor
il_rho(:)=1
IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN
@@ -270,163 +451,164 @@
ENDIF
- IF( cn_coord0 /= '' )THEN !.OR. cn_bathy0 /= '' )THEN
-
- !3-1 check namelist
- IF( in_imin0 < 1 .OR. in_imax0 < 1 .OR. in_jmin0 < 1 .OR. in_jmax0 < 1)THEN
- ! compute coarse grid indices around fine grid
- IF( cn_coord0 /= '' )THEN
- il_ind(:,:,:)=grid_get_coarse_index(tl_coord0, tl_coord1 )
- ENDIF
-
- il_imin0=il_ind(1,1,1) ; il_imax0=il_ind(1,2,1)
- il_jmin0=il_ind(2,1,1) ; il_jmax0=il_ind(2,2,1)
-
- il_offset(:,:)=il_ind(:,:,2)
- ELSE
- il_imin0=in_imin0 ; il_imax0=in_imax0
- il_jmin0=in_jmin0 ; il_jmax0=in_jmax0
-
- il_offset(1,:)=FLOOR(REAL(il_rho(jp_I)-1,dp)*0.5)
- il_offset(2,:)=FLOOR(REAL(il_rho(jp_J)-1,dp)*0.5)
- ENDIF
-
- !3-2 check domain validity
- IF( cn_coord0 /= '' )THEN
- CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0)
- ENDIF
-
- !3-3 check coordinate file
- IF( cn_coord0 /= '' )THEN
- CALL grid_check_coincidence( tl_coord0, tl_coord1, &
- & il_imin0, il_imax0, &
- & il_jmin0, il_jmax0, &
- & il_rho(:) )
- ENDIF
-
- ENDIF
+ ! check domain indices
+ ! compute coarse grid indices around fine grid
+ il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1, &
+ & id_rho=il_rho(:))
+
+ il_imin0=il_ind(1,1) ; il_imax0=il_ind(1,2)
+ il_jmin0=il_ind(2,1) ; il_jmax0=il_ind(2,2)
+
+ ! check domain validity
+ CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0)
+
+ !3-2-4 check coincidence between coarse and fine grid
+ CALL grid_check_coincidence( tl_coord0, tl_coord1, &
+ & il_imin0, il_imax0, &
+ & il_jmin0, il_jmax0, &
+ & il_rho(:) )
! compute level
- ALLOCATE(tl_level(ig_npoint))
+ ALLOCATE(tl_level(ip_npoint))
tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist )
! remove ghost cell
- il_xghost(:)=grid_get_ghost(tl_bathy1)
-
- DO ji=1,ig_npoint
- CALL grid_del_ghost(tl_level(ji), il_xghost(1), il_xghost(2))
+ il_xghost(:,:)=grid_get_ghost(tl_bathy1)
+ DO ji=1,ip_npoint
+ CALL grid_del_ghost(tl_level(ji), il_xghost(:,:))
ENDDO
- ! close
- CALL iom_close(tl_bathy1)
-
- !4- work on variables
- IF( .NOT. ASSOCIATED(tl_multi%t_file) )THEN
+ ! clean
+ CALL mpp_clean(tl_bathy1)
+
+ ! work on variables
+ IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN
CALL logger_error("CREATE RESTART: no file to work on. "//&
& "check cn_varfile in namelist.")
ELSE
ALLOCATE( tl_var( tl_multi%i_nvar ) )
+
jvar=0
! for each file
- DO ji=1,tl_multi%i_nfile
- WRITE(cl_data,'(a,i2.2)') 'data_',jvar+1
-
- IF( .NOT. ASSOCIATED(tl_multi%t_file(ji)%t_var) )THEN
+ DO ji=1,tl_multi%i_nmpp
+ WRITE(cl_data,'(a,i2.2)') 'data-',jvar+1
+
+ IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
CALL logger_error("CREATE RESTART: no variable to work on for "//&
- & "file "//TRIM(tl_multi%t_file(ji)%c_name)//&
+ & "mpp "//TRIM(tl_multi%t_mpp(ji)%c_name)//&
& ". check cn_varfile in namelist.")
- ELSEIF( TRIM(tl_multi%t_file(ji)%c_name) == TRIM(cl_data) )THEN
- !4-1 use input matrix to fill variable
-
+ ELSEIF( TRIM(tl_multi%t_mpp(ji)%c_name) == TRIM(cl_data) )THEN
+ !- use input matrix to fill variable
+
+ WRITE(*,'(a)') "work on data"
! for each variable initialise from matrix
- DO jj=1,tl_multi%t_file(ji)%i_nvar
+ DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
+
jvar=jvar+1
- tl_tmp=tl_multi%t_file(ji)%t_var(jj)
- !4-1-1 fill value with matrix data
- ! pb voir comment gerer nb de dimension
- tl_var(jvar)=create_restart_matrix(tl_tmp, tl_coord1)
-
- !4-1-2 use mask
- CALL create_restart_mask(tl_var(jvar), tl_level(:))
+
+ WRITE(*,'(2x,a,a)') "work on variable "//&
+ & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
+
+ ! fill value with matrix data
+ tl_var(jvar) = create_restart_matrix( &
+ & tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj), tl_coord1, &
+ & in_nlevel, tl_level(:) )
+
ENDDO
-
+ !- end of use input matrix to fill variable
ELSE
- !4-2 use file to fill variable
-
- ! open file
- tl_file=file_init(TRIM(tl_multi%t_file(ji)%c_name))
- CALL iom_open(tl_file)
+ !- use mpp file to fill variable
+
+ WRITE(*,'(a)') "work on file "//TRIM(tl_multi%t_mpp(ji)%c_name)
+ !
+ tl_mpp=mpp_init( file_init(TRIM(tl_multi%t_mpp(ji)%t_proc(1)%c_name)) )
+ CALL grid_get_info(tl_mpp)
+
+ ! check vertical dimension
+ IF( tl_mpp%t_dim(jp_K)%l_use .AND. &
+ & tl_mpp%t_dim(jp_K)%i_len /= in_nlevel )THEN
+ CALL logger_error("CREATE RESTART: dimension in file "//&
+ & TRIM(tl_mpp%c_name)//" not agree with namelist in_nlevel ")
+ ENDIF
+
+ ! open mpp file
+ CALL iom_mpp_open(tl_mpp)
! get or check depth value
- IF( tl_file%i_depthid /= 0 )THEN
- IF( ASSOCIATED(tl_depth%d_value) )THEN
- IF( ANY( tl_depth%d_value(:,:,:,:) /= &
- & tl_tmp%d_value(:,:,:,:) ) )THEN
- CALL logger_fatal("CREATE RESTART: depth value from "//&
- & TRIM(tl_multi%t_file(ji)%c_name)//" not conform "//&
- & " to those from former file(s).")
- ENDIF
- ELSE
- tl_depth=iom_read_var(tl_file,tl_file%i_depthid)
+ CALL create_restart_check_depth( tl_mpp, tl_depth )
+
+ ! get or check time value
+ CALL create_restart_check_time( tl_mpp, tl_time )
+
+ ! close mpp file
+ CALL iom_mpp_close(tl_mpp)
+
+ IF( ANY( tl_mpp%t_dim(1:2)%i_len /= &
+ & tl_coord0%t_dim(1:2)%i_len) )THEN
+ !!! extract value from fine grid
+
+ IF( ANY( tl_mpp%t_dim(1:2)%i_len <= &
+ & tl_coord1%t_dim(1:2)%i_len) )THEN
+ CALL logger_fatal("CREATE RESTART: dimension in file "//&
+ & TRIM(tl_mpp%c_name)//" smaller than those in fine"//&
+ & " grid coordinates.")
ENDIF
- ENDIF
-
- ! get or check time value
- IF( tl_file%i_timeid /= 0 )THEN
- IF( ASSOCIATED(tl_time%d_value) )THEN
- IF( ANY( tl_time%d_value(:,:,:,:) /= &
- & tl_tmp%d_value(:,:,:,:) ) )THEN
- CALL logger_fatal("CREATE RESTART: time value from "//&
- & TRIM(tl_multi%t_file(ji)%c_name)//" not conform "//&
- & " to those from former file(s).")
- ENDIF
- ELSE
- tl_time=iom_read_var(tl_file,tl_file%i_timeid)
- ENDIF
- ENDIF
-
- IF( ANY( tl_file%t_dim(1:2)%i_len /= &
- & tl_coord0%t_dim(1:2)%i_len) )THEN
- !4-2-1 extract value from fine grid
-
- !4-2-1-1 compute domain on fine grid
- tl_dom1=create__restart_get_dom_coord(tl_file, tl_coord1)
+
+ ! compute domain on fine grid
+ il_ind(:,:)=grid_get_coarse_index(tl_mpp, tl_coord1 )
+
+ il_imin1=il_ind(1,1) ; il_imax1=il_ind(1,2)
+ il_jmin1=il_ind(2,1) ; il_jmax1=il_ind(2,2)
+
+ !- check grid coincidence
+ CALL grid_check_coincidence( tl_mpp, tl_coord1, &
+ & il_imin1, il_imax1, &
+ & il_jmin1, il_jmax1, &
+ & il_rho(:) )
+
+ ! compute domain
+ tl_dom1=dom_init(tl_mpp, &
+ & il_imin1, il_imax1, &
+ & il_jmin1, il_jmax1)
- ! open mpp file on domain
- !4-2-1-2 init mpp structure
- tl_mpp=mpp_init(tl_file)
-
- !4-2-1-3 get processor to be used
- CALL mpp_get_use( tl_mpp, tl_dom1 )
- !4-2-1-4 open mpp files
- CALL iom_mpp_open(tl_mpp)
+ ! open mpp files
+ CALL iom_dom_open(tl_mpp, tl_dom1)
! for each variable of this file
- DO jj=1,tl_multi%t_file(ji)%i_nvar
+ DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
+
+ WRITE(*,'(2x,a,a)') "work on variable "//&
+ & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
+
jvar=jvar+1
- cl_name=tl_multi%t_file(ji)%t_var(jj)%c_name
- !4-2-1-5 read variable over domain
- tl_var(jvar)=iom_mpp_read_var( tl_mpp, TRIM(cl_name), &
- & td_dom=tl_dom1 )
-
- !4-2-1-7 add attribute to variable
+ cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name
+ ! read variable over domain
+ tl_var(jvar)=iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom1)
+
+ ! add attribute to variable
tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
CALL var_move_att(tl_var(jvar), tl_att)
+ tl_att=att_init('src_i_indices',(/il_imin0, il_imax0/))
+ CALL var_move_att(tl_var(jvar), tl_att)
+
+ tl_att=att_init('src_j_indices',(/il_jmin0, il_jmax0/))
+ CALL var_move_att(tl_var(jvar), tl_att)
+
! clean structure
CALL att_clean(tl_att)
- !4-2-1-8 use mask
+ ! use mask
CALL create_restart_mask(tl_var(jvar), tl_level(:))
- !4-2-1-9 add ghost cell
- CALL grid_add_ghost( tl_var(jvar), &
- & tl_dom1%i_ighost,tl_dom1%i_jghost )
+ ! add ghost cell
+ CALL grid_add_ghost( tl_var(jvar), tl_dom1%i_ghost(:,:) )
ENDDO
- !4-2-1-2 close mpp file
- CALL iom_mpp_close(tl_mpp)
+ ! close mpp file
+ CALL iom_dom_close(tl_mpp)
+
! clean structure
CALL mpp_clean(tl_mpp)
@@ -434,64 +616,75 @@
ELSE
- !4-2-2 get value from coarse grid
-
- !4-2-2-1 compute domain on coarse grid
- tl_dom0=create__restart_get_dom_index(tl_file, il_imin0, il_jmin0, &
- & il_imax0, il_jmax0)
-
- !4-2-2-2 add extra band (if possible) to compute interpolation
+ !!! get value from coarse grid
+
+ ! compute domain on coarse grid
+ tl_dom0=dom_init(tl_mpp, &
+ & il_imin0, il_imax0, &
+ & il_jmin0, il_jmax0 )
+
+ ! add extra band (if possible) to compute interpolation
CALL dom_add_extra(tl_dom0)
- ! open mpp file on domain
- !4-2-2-3 init mpp structure
- tl_mpp=mpp_init(tl_file)
-
- !4-2-2-4 get processor to be used
- CALL mpp_get_use( tl_mpp, tl_dom0 )
-
- !4-2-2-5 open mpp files
- CALL iom_mpp_open(tl_mpp)
-
+ ! open mpp files
+ CALL iom_dom_open(tl_mpp, tl_dom0)
! for each variable of this file
- DO jj=1,tl_multi%t_file(ji)%i_nvar
+ DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
+
+ WRITE(*,'(2x,a,a)') "work on variable "//&
+ & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
jvar=jvar+1
- cl_name=tl_multi%t_file(ji)%t_var(jj)%c_name
- print *,'work on ',trim(cl_name)
- !4-2-2-6 read variable over domain
- tl_var(jvar)=iom_mpp_read_var( tl_mpp, TRIM(cl_name), &
- & td_dom=tl_dom0 )
-
- !4-2-2-7 interpolate variable
+ cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name
+
+ ! read variable over domain
+ tl_var(jvar)=iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom0)
+
+ il_offset(:,:)=grid_get_fine_offset(tl_coord0, &
+ & il_imin0, il_jmin0, &
+ & il_imax0, il_jmax0, &
+ & tl_coord1, &
+ & id_rho=il_rho(:), &
+ & cd_point=TRIM(tl_var(jvar)%c_point))
+
+
+ ! interpolate variable
CALL create_restart_interp(tl_var(jvar), tl_level(:), &
& il_rho(:), &
& id_offset=il_offset(:,:))
- !tl_att=att_init('add_offset',0.)
- !CALL var_move_att(tl_var(jvar), tl_att)
- !tl_att=att_init('scale_factor',1.)
- !CALL var_move_att(tl_var(jvar), tl_att)
-
- !4-2-2-8 remove extraband added to domain
+ ! remove extraband added to domain
CALL dom_del_extra( tl_var(jvar), tl_dom0, il_rho(:) )
- !4-2-2-10 add attribute to variable
+ ! add attribute to variable
tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
CALL var_move_att(tl_var(jvar), tl_att)
+ tl_att=att_init('src_i-indices',(/il_imin0, il_imax0/))
+ CALL var_move_att(tl_var(jvar), tl_att)
+
+ tl_att=att_init('src_j-indices',(/il_jmin0, il_jmax0/))
+ CALL var_move_att(tl_var(jvar), tl_att)
+
+ IF( ANY(il_rho(:)/=1) )THEN
+ tl_att=att_init("refinment_factor", &
+ & (/il_rho(jp_I),il_rho(jp_J)/))
+ CALL var_move_att(tl_var(jvar), tl_att)
+ ENDIF
+
! clean structure
CALL att_clean(tl_att)
- !4-2-2-11 use mask
+ ! use mask
CALL create_restart_mask(tl_var(jvar), tl_level(:))
- !4-2-2-12 add ghost cell
- CALL grid_add_ghost( tl_var(jvar), &
- & tl_dom0%i_ighost,tl_dom0%i_jghost )
+ ! add ghost cell
+ CALL grid_add_ghost( tl_var(jvar), il_xghost(:,:) )
+
ENDDO
- !4-2-2-2 close mpp file
- CALL iom_mpp_close(tl_mpp)
+ ! close mpp file
+ CALL iom_dom_close(tl_mpp)
+
! clean structure
CALL mpp_clean(tl_mpp)
@@ -500,29 +693,33 @@
ENDIF
- ! close file
- CALL iom_close(tl_file)
! clean structure
- CALL file_clean(tl_file)
+ CALL mpp_clean(tl_mpp)
ENDIF
ENDDO
ENDIF
- !5- use additional request
- DO jvar=1,tl_multi%i_nvar
-
- !5-1 forced min and max value
- CALL var_limit_value(tl_var(jvar))
-
- !5-2 filter
- CALL filter_fill_value(tl_var(jvar))
-
- !5-3 extrapolate
- CALL extrap_fill_value(tl_var(jvar), id_iext=in_extrap, &
- & id_jext=in_extrap, &
- & id_kext=in_extrap)
+ il_nvar=tl_multi%i_nvar
+
+ ! clean
+ CALL multi_clean(tl_multi)
+ CALL mpp_clean(tl_coord0)
+
+ ! use additional request
+ DO jvar=1,il_nvar
+
+ ! forced min and max value
+ CALL var_limit_value(tl_var(jvar))
+
+ ! filter
+ CALL filter_fill_value(tl_var(jvar))
+
+ ! extrapolate
+ CALL extrap_fill_value(tl_var(jvar), id_iext=in_extrap, &
+ & id_jext=in_extrap, &
+ & id_kext=in_extrap)
ENDDO
- !6- create file
+ ! create file
IF( in_niproc == 0 .AND. &
& in_njproc == 0 .AND. &
@@ -532,10 +729,18 @@
in_nproc = 1
ENDIF
- tl_mppout=mpp_init( TRIM(cn_fileout), tl_var(1), &
- & in_niproc, in_njproc, in_nproc, &
- & cd_type=cn_type)
-
- !6-1 add dimension
+
+ ! add dimension
tl_dim(:)=var_max_dim(tl_var(:))
+
+ DO ji=1,il_nvar
+
+ IF( ALL(tl_var(ji)%t_dim(:)%i_len == tl_dim(:)%i_len) )THEN
+ tl_mppout=mpp_init( TRIM(cn_fileout), tl_var(ji), &
+ & in_niproc, in_njproc, in_nproc, &
+ & cd_type=cn_type)
+ EXIT
+ ENDIF
+
+ ENDDO
DO ji=1,ip_maxdim
@@ -551,43 +756,61 @@
ENDDO
- !6-2 add variables
-
- !IF( ALL( tl_dim(1:2)%l_use ) )THEN
- ! ! add longitude
- ! tl_lon=iom_read_var(tl_coord1,'longitude')
-
- ! CALL mpp_add_var(tl_mppout, tl_lon)
- ! CALL var_clean(tl_lon)
-
- ! ! add latitude
- ! tl_lat=iom_read_var(tl_coord1,'latitude')
-
- ! CALL mpp_add_var(tl_mppout, tl_lat)
- ! CALL var_clean(tl_lat)
- !ENDIF
-
- !IF( tl_dim(3)%l_use )THEN
- ! ! add depth
- ! CALL mpp_add_var(tl_mppout, tl_depth)
- ! CALL var_clean(tl_depth)
- !ENDIF
-
- !IF( tl_dim(4)%l_use )THEN
- ! ! add time
- ! CALL mpp_add_var(tl_mppout, tl_time)
- ! CALL var_clean(tl_time)
- !ENDIF
+ ! add variables
+ IF( ALL( tl_dim(1:2)%l_use ) )THEN
+
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord1)
+
+ ! add longitude
+ tl_lon=iom_mpp_read_var(tl_coord1,'longitude')
+ CALL mpp_add_var(tl_mppout, tl_lon)
+ CALL var_clean(tl_lon)
+
+ ! add latitude
+ tl_lat=iom_mpp_read_var(tl_coord1,'latitude')
+ CALL mpp_add_var(tl_mppout, tl_lat)
+ CALL var_clean(tl_lat)
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_coord1)
+
+ ENDIF
+
+ IF( tl_dim(3)%l_use )THEN
+ IF( ASSOCIATED(tl_depth%d_value) )THEN
+ ! add depth
+ CALL mpp_add_var(tl_mppout, tl_depth)
+ ELSE
+ CALL logger_error("CREATE RESTART: no value for depth variable.")
+ ENDIF
+ ENDIF
+ IF( ASSOCIATED(tl_depth%d_value) ) CALL var_clean(tl_depth)
+
+ IF( tl_dim(4)%l_use )THEN
+ IF( ASSOCIATED(tl_time%d_value) )THEN
+ ! add time
+ CALL mpp_add_var(tl_mppout, tl_time)
+ ELSE
+ CALL logger_error("CREATE RESTART: no value for time variable.")
+ ENDIF
+ ENDIF
+ IF( ASSOCIATED(tl_time%d_value) ) CALL var_clean(tl_time)
! add other variable
- DO jvar=1,tl_multi%i_nvar
- CALL mpp_add_var(tl_mppout, tl_var(jvar))
- CALL var_clean(tl_var(jvar))
+ DO jvar=1,il_nvar
+ ! check if variable already add
+ il_index=var_get_index(tl_mppout%t_proc(1)%t_var(:), tl_var(jvar)%c_name)
+ IF( il_index == 0 )THEN
+ CALL mpp_add_var(tl_mppout, tl_var(jvar))
+ CALL var_clean(tl_var(jvar))
+ ENDIF
ENDDO
- DO ji=1,4
- CALL mpp_add_var(tl_mppout,tl_level(ji))
- ENDDO
-
- !6-3 add some attribute
+! DO ji=1,4
+! CALL grid_add_ghost( tl_level(ji), il_xghost(:,:) )
+! CALL var_clean(tl_level(ji))
+! ENDDO
+
+ ! add some attribute
tl_att=att_init("Created_by","SIREN create_restart")
CALL mpp_add_att(tl_mppout, tl_att)
@@ -616,20 +839,24 @@
ENDIF
- !6-4 create file
+ ! create file
CALL iom_mpp_create(tl_mppout)
- !6-5 write file
+ ! write file
CALL iom_mpp_write_file(tl_mppout)
-
- !6-6 close file
+ ! close file
CALL iom_mpp_close(tl_mppout)
- IF( cn_coord0 /= '' ) CALL iom_close(tl_coord0)
-
- !7- clean
+
+ ! print
+ CALL mpp_print(tl_mppout)
+
+ ! clean
+ CALL att_clean(tl_att)
+ CALL var_clean(tl_var(:))
DEALLOCATE(tl_var)
+ CALL var_clean(tl_level(:))
+ DEALLOCATE(tl_level)
CALL mpp_clean(tl_mppout)
- CALL file_clean(tl_coord1)
- CALL file_clean(tl_coord0)
+ CALL mpp_clean(tl_coord1)
! close log file
@@ -637,60 +864,5 @@
CALL logger_close()
-!> @endcode
CONTAINS
- !-------------------------------------------------------------------
- !> @brief
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !-------------------------------------------------------------------
- !> @code
- FUNCTION create_restart_level(td_level1)
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(IN) :: td_level1
-
- ! function
- TYPE(TVAR), DIMENSION(4) :: create_restart_level
-
- ! local variable
- TYPE(TFILE) :: tl_level1
- TYPE(TVAR), DIMENSION(4) :: tl_var
- TYPE(TMPP) :: tl_mpplevel1
-
- ! loop indices
- !----------------------------------------------------------------
-
- !0- compute domain
- tl_dom1=dom_init(td_level1)
-
- !1 init mpp structure
- tl_level1=td_level1
- tl_mpplevel1=mpp_init(tl_level1)
-
- CALL file_clean(tl_level1)
-
- !2 get processor to be used
- CALL mpp_get_use( tl_mpplevel1, tl_dom1 )
-
- !3 open mpp files
- CALL iom_mpp_open(tl_mpplevel1)
- tl_var(jp_T)=iom_mpp_read_var(tl_mpplevel1,'tlevel',td_dom=tl_dom1)
- tl_var(jp_U)=iom_mpp_read_var(tl_mpplevel1,'ulevel',td_dom=tl_dom1)
- tl_var(jp_V)=iom_mpp_read_var(tl_mpplevel1,'vlevel',td_dom=tl_dom1)
- tl_var(jp_F)=iom_mpp_read_var(tl_mpplevel1,'flevel',td_dom=tl_dom1)
-
- !4 save result
- create_restart_level(:)=tl_var(:)
-
- !5 clean
- CALL iom_mpp_close(tl_mpplevel1)
- CALL mpp_clean(tl_mpplevel1)
-
- END FUNCTION create_restart_level
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -699,21 +871,24 @@
!> @details
!> A variable is create with the same name that the input variable,
- !> and with dimension of the coordinate file.
- !> Then the variable table of value is split into equal subdomain.
- !> Each subdomain is fill with the linked value of the matrix.
+ !> and with dimension of the coordinate file.
+ !> Then the variable array of value is split into equal subdomain.
+ !> Each subdomain is filled with the corresponding value of the matrix.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!>
- !> @param[in] td_var : variable structure
- !> @param[in] td_coord : coordinate
+ !> @param[in] td_var variable structure
+ !> @param[in] td_coord coordinate file structure
+ !> @param[in] id_nlevel number of vertical level
+ !> @param[in] td_level array of level on T,U,V,F point (variable structure)
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
- FUNCTION create_restart_matrix(td_var, td_coord)
+ FUNCTION create_restart_matrix(td_var, td_coord, id_nlevel, td_level)
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(IN) :: td_var
- TYPE(TFILE), INTENT(IN) :: td_coord
+ TYPE(TVAR) , INTENT(IN) :: td_var
+ TYPE(TMPP) , INTENT(IN) :: td_coord
+ INTEGER(i4) , INTENT(IN) :: id_nlevel
+ TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_level
! function
@@ -721,10 +896,8 @@
! local variable
- INTEGER(i4) :: il_ighost
- INTEGER(i4) :: il_jghost
- INTEGER(i4) , DIMENSION(2) :: il_xghost
INTEGER(i4) , DIMENSION(3) :: il_dim
INTEGER(i4) , DIMENSION(3) :: il_size
INTEGER(i4) , DIMENSION(3) :: il_rest
+ INTEGER(i4) , DIMENSION(2,2) :: il_xghost
INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ishape
@@ -734,7 +907,4 @@
REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
- TYPE(TVAR) :: tl_lon
- TYPE(TVAR) :: tl_lat
- TYPE(TVAR) :: tl_var
TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
@@ -745,25 +915,22 @@
!----------------------------------------------------------------
- !1- read output grid
- tl_lon=iom_read_var(td_coord,'longitude')
- tl_lat=iom_read_var(td_coord,'latitude')
-
- !2- look for ghost cell
- il_xghost(:)=grid_get_ghost( tl_lon, tl_lat )
-
- il_ighost=il_xghost(1)*ig_ghost
- il_jghost=il_xghost(2)*ig_ghost
-
- !3- write value on grid
- !3-1 get matrix dimension
+ ! look for ghost cell
+ il_xghost(:,:)=grid_get_ghost( td_coord )
+
+ ! write value on grid
+ ! get matrix dimension
il_dim(:)=td_var%t_dim(1:3)%i_len
- !3-2 output dimension
- tl_dim(:)=tl_lon%t_dim(:)
+
+ ! output dimension
+ tl_dim(jp_I:jp_J)=dim_copy(td_coord%t_dim(jp_I:jp_J))
+ IF( id_nlevel >= 1 )THEN
+ tl_dim(jp_K)=dim_init('Z',id_nlevel)
+ ENDIF
! remove ghost cell
- tl_dim(1)%i_len=tl_dim(1)%i_len - 2*il_xghost(1)*ig_ghost
- tl_dim(2)%i_len=tl_dim(2)%i_len - 2*il_xghost(2)*ig_ghost
-
- !3-3 split output domain in N subdomain depending of matrix dimension
+ tl_dim(jp_I)%i_len=tl_dim(jp_I)%i_len - SUM(il_xghost(jp_I,:))*ip_ghost
+ tl_dim(jp_J)%i_len=tl_dim(jp_J)%i_len - SUM(il_xghost(jp_J,:))*ip_ghost
+
+ ! split output domain in N subdomain depending of matrix dimension
il_size(:) = tl_dim(1:3)%i_len / il_dim(:)
il_rest(:) = MOD(tl_dim(1:3)%i_len, il_dim(:))
@@ -776,5 +943,4 @@
! add rest to last cell
il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1)
-
ALLOCATE( il_jshape(il_dim(2)+1) )
@@ -794,5 +960,5 @@
il_kshape(il_dim(3)+1)=il_kshape(il_dim(3)+1)+il_rest(3)
- !3-3 write ouput table of value
+ ! write ouput array of value
ALLOCATE(dl_value( tl_dim(1)%i_len, &
& tl_dim(2)%i_len, &
@@ -815,160 +981,37 @@
ENDDO
- !3-4 initialise variable with value
- tl_var=var_init(TRIM(td_var%c_name),dl_value(:,:,:,:))
+ ! keep attribute and type
+ create_restart_matrix=var_copy(td_var)
+ DEALLOCATE( create_restart_matrix%d_value )
+ ! save new dimension
+ create_restart_matrix%t_dim(:)=dim_copy(tl_dim(:))
+ ! add variable value
+ CALL var_add_value( create_restart_matrix, dl_value(:,:,:,:), &
+ & id_type=td_var%i_type)
DEALLOCATE(dl_value)
- !4- add ghost cell
- CALL grid_add_ghost(tl_var,il_ighost,il_jghost)
-
- !5- save result
- create_restart_matrix=tl_var
+ ! use mask
+ CALL create_restart_mask(create_restart_matrix, td_level(:))
+
+ ! add ghost cell
+ CALL grid_add_ghost( create_restart_matrix, il_xghost(:,:) )
+
+ ! clean
+ DEALLOCATE(il_ishape)
+ DEALLOCATE(il_jshape)
+ DEALLOCATE(il_kshape)
END FUNCTION create_restart_matrix
- !> @endcode
!-------------------------------------------------------------------
!> @brief
+ !> This subroutine use mask to filled land point with _FillValue
!>
- !> @details
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
!>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_mask mask variable structure
!-------------------------------------------------------------------
- !> @code
- FUNCTION create__restart_get_dom_coord( td_file, td_coord, &
- & id_rho )
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(IN) :: td_file
- TYPE(TFILE), INTENT(IN) :: td_coord
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho
-
- ! function
- TYPE(TDOM) :: create__restart_get_dom_coord
-
- ! local variable
- INTEGER(i4) :: il_pivot
- INTEGER(i4) :: il_perio
-
- INTEGER(i4) :: il_imin
- INTEGER(i4) :: il_imax
- INTEGER(i4) :: il_jmin
- INTEGER(i4) :: il_jmax
-
- INTEGER(i4), DIMENSION(2,2,2) :: il_ind
-
- TYPE(TFILE) :: tl_file
-
- TYPE(TDOM) :: tl_dom
- ! loop indices
- !----------------------------------------------------------------
-
- tl_file=td_file
- !1- open file
- CALL iom_open(tl_file)
-
- ! get periodicity
- il_pivot=grid_get_pivot(tl_file)
- il_perio=grid_get_perio(tl_file,il_pivot)
-
- tl_file%i_perio=il_perio
-
- !2- compute file grid indices around coord grid
- il_ind(:,:,:)=grid_get_coarse_index(tl_file, td_coord )
-
- il_imin=il_ind(1,1,1) ; il_imax=il_ind(1,2,1)
- il_jmin=il_ind(2,1,1) ; il_jmax=il_ind(2,2,1)
-
- !3- check grid coincidence
- CALL grid_check_coincidence( tl_file, td_coord, &
- & il_imin, il_imax, &
- & il_jmin, il_jmax, &
- & id_rho(:) )
-
- !4- compute domain
- tl_dom=dom_init(tl_file, &
- & il_imin, il_imax, &
- & il_jmin, il_jmax)
-
- ! close file
- CALL iom_close(tl_file)
-
- ! save result
- create__restart_get_dom_coord=tl_dom
-
- END FUNCTION create__restart_get_dom_coord
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !-------------------------------------------------------------------
- !> @code
- FUNCTION create__restart_get_dom_index( td_file, id_imin, id_jmin, &
- & id_imax, id_jmax )
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(IN) :: td_file
- INTEGER(i4), INTENT(IN) :: id_imin
- INTEGER(i4), INTENT(IN) :: id_imax
- INTEGER(i4), INTENT(IN) :: id_jmin
- INTEGER(i4), INTENT(IN) :: id_jmax
-
- ! function
- TYPE(TDOM) :: create__restart_get_dom_index
-
- ! local variable
- INTEGER(i4) :: il_pivot
- INTEGER(i4) :: il_perio
-
- TYPE(TFILE) :: tl_file
-
- TYPE(TDOM) :: tl_dom
- ! loop indices
- !----------------------------------------------------------------
-
- ! init
- tl_file=td_file
- !1- open file
- CALL iom_open(tl_file)
-
- ! get periodicity
- il_pivot=grid_get_pivot(tl_file)
- il_perio=grid_get_perio(tl_file,il_pivot)
-
- tl_file%i_perio=il_perio
-
- !2- compute domain
- tl_dom=dom_init(tl_file, &
- & id_imin, id_imax, &
- & id_jmin, id_jmax)
-
- ! close file
- CALL iom_close(tl_file)
-
- ! save result
- create__restart_get_dom_index=tl_dom
-
- END FUNCTION create__restart_get_dom_index
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !> @param[in]
- !> @todo
- !-------------------------------------------------------------------
- !> @code
SUBROUTINE create_restart_mask( td_var, td_mask )
@@ -987,192 +1030,54 @@
!----------------------------------------------------------------
- IF( ANY(td_var%t_dim(1:2)%i_len /= td_mask(1)%t_dim(1:2)%i_len) )THEN
- CALL logger_error("CREATE RESTART MASK: dimension differ between "//&
- & "variable ("//&
- & TRIM(fct_str(td_var%t_dim(1)%i_len))//","//&
- & TRIM(fct_str(td_var%t_dim(2)%i_len))//&
- & ") and level ("//&
- & TRIM(fct_str(td_mask(1)%t_dim(1)%i_len))//","//&
- & TRIM(fct_str(td_mask(1)%t_dim(2)%i_len))//")")
- ELSE
- ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
- & td_var%t_dim(2)%i_len) )
-
- SELECT CASE(TRIM(td_var%c_point))
- CASE('T')
- il_mask(:,:)=INT(td_mask(jp_T)%d_value(:,:,1,1))
- CASE('U')
- il_mask(:,:)=INT(td_mask(jp_U)%d_value(:,:,1,1))
- CASE('V')
- il_mask(:,:)=INT(td_mask(jp_V)%d_value(:,:,1,1))
- CASE('F')
- il_mask(:,:)=INT(td_mask(jp_F)%d_value(:,:,1,1))
- END SELECT
-
- DO jl=1,td_var%t_dim(4)%i_len
- DO jk=1,td_var%t_dim(3)%i_len
- WHERE( il_mask(:,:) < jk ) td_var%d_value(:,:,jk,jl)=99 !td_var%d_fill
- !.AND. &
- !& td_var%d_value(:,:,jk,jl) == td_var%d_fill .OR. &
- !& il_mask(:,:) < jk .AND. &
- !& td_var%d_value(:,:,jk,jl) == 1 ) td_var%d_value(:,:,jk,jl)=99 !td_var%d_fill
+ IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
+ IF( ANY(td_var%t_dim(1:2)%i_len /= td_mask(1)%t_dim(1:2)%i_len) )THEN
+ CALL logger_error("CREATE RESTART MASK: dimension differ between"//&
+ & " variable "//TRIM(td_var%c_name)//" ("//&
+ & TRIM(fct_str(td_var%t_dim(1)%i_len))//","//&
+ & TRIM(fct_str(td_var%t_dim(2)%i_len))//&
+ & ") and level ("//&
+ & TRIM(fct_str(td_mask(1)%t_dim(1)%i_len))//","//&
+ & TRIM(fct_str(td_mask(1)%t_dim(2)%i_len))//")")
+ ELSE
+ ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
+ & td_var%t_dim(2)%i_len) )
+
+ SELECT CASE(TRIM(td_var%c_point))
+ CASE('T')
+ il_mask(:,:)=INT(td_mask(jp_T)%d_value(:,:,1,1))
+ CASE('U')
+ il_mask(:,:)=INT(td_mask(jp_U)%d_value(:,:,1,1))
+ CASE('V')
+ il_mask(:,:)=INT(td_mask(jp_V)%d_value(:,:,1,1))
+ CASE('F')
+ il_mask(:,:)=INT(td_mask(jp_F)%d_value(:,:,1,1))
+ END SELECT
+
+ DO jl=1,td_var%t_dim(4)%i_len
+ DO jk=1,td_var%t_dim(3)%i_len
+ WHERE( il_mask(:,:) < jk )
+ td_var%d_value(:,:,jk,jl)=td_var%d_fill
+ END WHERE
+ ENDDO
ENDDO
- ENDDO
-
- DEALLOCATE( il_mask )
+
+ DEALLOCATE( il_mask )
+ ENDIF
ENDIF
END SUBROUTINE create_restart_mask
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This subroutine interpolate variable
!>
- !> @details
- !>
!> @author J.Paul
!> - Nov, 2013- Initial Version
!>
- !> @param[in]
+ !> @param[inout] td_var variable structure
+ !> @param[inout] td_level fine grid level, array of variable structure
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] id_offset array of offset between fine and coarse grid
+ !> @param[in] id_iext i-direction size of extra bands (default=im_minext)
+ !> @param[in] id_jext j-direction size of extra bands (default=im_minext)
!-------------------------------------------------------------------
- !> @code
- FUNCTION create_restart_extract(td_var, td_file, &
- & td_coord)
- IMPLICIT NONE
- ! Argument
- TYPE(TVAR) , INTENT(IN) :: td_var
- TYPE(TFILE), INTENT(IN) :: td_file
- TYPE(TFILE), INTENT(IN) :: td_coord
-
- ! function
- TYPE(TVAR) :: create_restart_extract
-
- ! local variable
- INTEGER(i4), DIMENSION(2,2,2) :: il_ind
-
- INTEGER(i4) :: il_pivot
- INTEGER(i4) :: il_perio
-
- INTEGER(i4) :: il_imin
- INTEGER(i4) :: il_jmin
- INTEGER(i4) :: il_imax
- INTEGER(i4) :: il_jmax
-
- TYPE(TFILE) :: tl_file
-
- TYPE(TMPP) :: tl_mpp
-
- TYPE(TATT) :: tl_att
-
- TYPE(TVAR) :: tl_var
-
- TYPE(TDOM) :: tl_dom
- ! loop indices
- !----------------------------------------------------------------
-
- IF( td_file%i_id == 0 )THEN
- CALL logger_error("CREATE RESTART EXTRACT: file "//&
- & TRIM(td_file%c_name)//" not opened ")
- ELSE
-
- !init
- tl_file=td_file
-
- !1- open file
- CALL iom_open(tl_file)
-
- ! get periodicity
- il_pivot=grid_get_pivot(tl_file)
- il_perio=grid_get_perio(tl_file,il_pivot)
-
- tl_file%i_perio=il_perio
-
- !2- compute file grid indices around coord grid
- il_ind(:,:,:)=grid_get_coarse_index(tl_file, td_coord )
-
- il_imin=il_ind(1,1,1) ; il_imax=il_ind(1,2,1)
- il_jmin=il_ind(2,1,1) ; il_jmax=il_ind(2,2,1)
-
- !3- check grid coincidence
- CALL grid_check_coincidence( tl_file, td_coord, &
- & il_imin, il_imax, &
- & il_jmin, il_jmax, &
- & (/1, 1, 1/) )
-
- !4- compute domain
- tl_dom=dom_init(tl_file, &
- & il_imin, il_imax, &
- & il_jmin, il_jmax)
-
- ! close file
- CALL iom_close(tl_file)
-
- !5- read bathymetry on domain (ugly way to do it, have to work on it)
- !5-1 init mpp structure
- tl_mpp=mpp_init(tl_file)
-
- CALL file_clean(tl_file)
-
- !5-2 get processor to be used
- CALL mpp_get_use( tl_mpp, tl_dom )
-
- !5-3 open mpp files
- CALL iom_mpp_open(tl_mpp)
-
- !5-4 read variable on domain
- tl_var=iom_mpp_read_var(tl_mpp,TRIM(td_var%c_name),td_dom=tl_dom)
-
- !5-5 close mpp file
- CALL iom_mpp_close(tl_mpp)
-
- !6- add ghost cell
- CALL grid_add_ghost(tl_var,tl_dom%i_ighost,tl_dom%i_jghost)
-
- !7- check result
- IF( ANY( tl_var%t_dim(:)%l_use .AND. &
- & tl_var%t_dim(:)%i_len /= td_coord%t_dim(:)%i_len) )THEN
- CALL logger_debug("CREATE BATHY EXTRACT: "//&
- & "dimensoin of variable "//TRIM(td_var%c_name)//" "//&
- & TRIM(fct_str(tl_var%t_dim(1)%i_len))//","//&
- & TRIM(fct_str(tl_var%t_dim(2)%i_len))//","//&
- & TRIM(fct_str(tl_var%t_dim(3)%i_len))//","//&
- & TRIM(fct_str(tl_var%t_dim(4)%i_len)) )
- CALL logger_debug("CREATE BATHY EXTRACT: "//&
- & "dimensoin of coordinate file "//&
- & TRIM(fct_str(td_coord%t_dim(1)%i_len))//","//&
- & TRIM(fct_str(td_coord%t_dim(2)%i_len))//","//&
- & TRIM(fct_str(td_coord%t_dim(3)%i_len))//","//&
- & TRIM(fct_str(td_coord%t_dim(4)%i_len)) )
- CALL logger_fatal("CREATE BATHY EXTRACT: "//&
- & "dimensoin of extracted "//&
- & "variable and coordinate file dimension differ")
- ENDIF
-
- !8- add attribute to variable
- tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
- CALL var_move_att(tl_var, tl_att)
-
- !9- save result
- create_restart_extract=tl_var
-
- ! clean structure
- CALL var_clean(tl_var)
- CALL mpp_clean(tl_mpp)
- ENDIF
-
- END FUNCTION create_restart_extract
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !> @param[in]
- !> @todo
- !-------------------------------------------------------------------
- !> @code
SUBROUTINE create_restart_interp( td_var, td_level,&
& id_rho, &
@@ -1191,6 +1096,4 @@
! local variable
- TYPE(TVAR) :: tl_var
-
INTEGER(i4) :: il_iext
INTEGER(i4) :: il_jext
@@ -1198,7 +1101,4 @@
! loop indices
!----------------------------------------------------------------
-
- ! copy variable
- tl_var=td_var
il_iext=3
@@ -1220,31 +1120,128 @@
ENDIF
- il_iext=0
- il_jext=0
-
! work on variable
- !1 add extraband
- CALL extrap_add_extrabands(tl_var, il_iext, il_jext)
-
- !2 extrapolate variable
- CALL extrap_fill_value( tl_var, td_level(:), &
+ ! add extraband
+ CALL extrap_add_extrabands(td_var, il_iext, il_jext)
+
+ ! extrapolate variable
+ CALL extrap_fill_value( td_var, td_level(:), &
& id_offset(:,:), &
& id_rho(:), &
& id_iext=il_iext, id_jext=il_jext )
- !3 interpolate variable
- CALL interp_fill_value( tl_var, id_rho(:), &
+ ! interpolate variable
+ CALL interp_fill_value( td_var, id_rho(:), &
& id_offset=id_offset(:,:) )
- !4 remove extraband
- CALL extrap_del_extrabands(tl_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
-
- !5- save result
- td_var=tl_var
-
- ! clean variable structure
- CALL var_clean(tl_var)
+ ! remove extraband
+ CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
END SUBROUTINE create_restart_interp
- !> @endcode
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine get depth variable value in an open mpp structure
+ !> and check if agree with already input depth variable.
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - November, 2014- Initial Version
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_depth depth variable structure
+ !-------------------------------------------------------------------
+ SUBROUTINE create_restart_check_depth( td_mpp, td_depth )
+
+ IMPLICIT NONE
+
+ ! Argument
+ TYPE(TMPP), INTENT(IN ) :: td_mpp
+ TYPE(TVAR), INTENT(INOUT) :: td_depth
+
+ ! local variable
+ INTEGER(i4) :: il_varid
+ TYPE(TVAR) :: tl_depth
+ ! loop indices
+ !----------------------------------------------------------------
+
+ ! get or check depth value
+ IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN
+
+ il_varid=td_mpp%t_proc(1)%i_depthid
+ IF( ASSOCIATED(td_depth%d_value) )THEN
+
+ tl_depth=iom_mpp_read_var(td_mpp, il_varid)
+ IF( ANY( td_depth%d_value(:,:,:,:) /= &
+ & tl_depth%d_value(:,:,:,:) ) )THEN
+
+ CALL logger_fatal("CREATE BOUNDARY: depth value from "//&
+ & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//&
+ & " to those from former file(s).")
+
+ ENDIF
+ CALL var_clean(tl_depth)
+
+ ELSE
+ td_depth=iom_mpp_read_var(td_mpp,il_varid)
+ ENDIF
+
+ ENDIF
+
+ END SUBROUTINE create_restart_check_depth
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine get date and time in an open mpp structure
+ !> and check if agree with date and time already read.
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - November, 2014- Initial Version
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_time time variable structure
+ !-------------------------------------------------------------------
+ SUBROUTINE create_restart_check_time( td_mpp, td_time )
+
+ IMPLICIT NONE
+
+ ! Argument
+ TYPE(TMPP), INTENT(IN ) :: td_mpp
+ TYPE(TVAR), INTENT(INOUT) :: td_time
+
+ ! local variable
+ INTEGER(i4) :: il_varid
+ TYPE(TVAR) :: tl_time
+
+ TYPE(TDATE) :: tl_date1
+ TYPE(TDATE) :: tl_date2
+ ! loop indices
+ !----------------------------------------------------------------
+
+ ! get or check depth value
+ IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN
+
+ il_varid=td_mpp%t_proc(1)%i_timeid
+ IF( ASSOCIATED(td_time%d_value) )THEN
+
+ tl_time=iom_mpp_read_var(td_mpp, il_varid)
+
+ tl_date1=var_to_date(td_time)
+ tl_date2=var_to_date(tl_time)
+ IF( tl_date1 - tl_date2 /= 0 )THEN
+
+ CALL logger_fatal("CREATE BOUNDARY: date from "//&
+ & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//&
+ & " to those from former file(s).")
+
+ ENDIF
+ CALL var_clean(tl_time)
+
+ ELSE
+ td_time=iom_mpp_read_var(td_mpp,il_varid)
+ ENDIF
+
+ ENDIF
+
+ END SUBROUTINE create_restart_check_time
END PROGRAM create_restart
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/date.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/date.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/date.f90 (revision 5214)
@@ -7,70 +7,122 @@
! DESCRIPTION:
!> @brief This module provide the calculation of Julian dates, and
-!> do many manipulations with dates.
-!> Actually we use Modified Julian Dates, with origin the
-!> 17 Nov 1858 at 00:00:00
-!
+!> do many manipulations with dates.
+!>
!> @details
+!> Actually we use Modified Julian Dates, with
+!> 17 Nov 1858 at 00:00:00 as origin.
+!>
!> define type TDATE:
-!> TYPE(TDATE) :: tl_date1
+!> @code
+!> TYPE(TDATE) :: tl_date1
+!> @endcode
!> default date is 17 Nov 1858 at 00:00:00
!>
!> to intialise date :
-!> - from date of the day at 12:00:00 : tl_date1=date_today()
-!> - from date and time of the day : tl_date1=date_now()
-!> - from julian day : tl_date1=date_init(1.)
-!> - from year month day : tl_date1=date_init(2012,12,10)
+!> - from date of the day at 12:00:00 :
+!> @code
+!> tl_date1=date_today()
+!> @endcode
+!> - from date and time of the day :
+!> @code
+!> tl_date1=date_now()
+!> @endcode
+!> - from julian day :
+!> @code
+!> tl_date1=date_init(dd_jd)
+!> @endcode
+!> - dd_jd julian day (double precision)
+!> - from number of second since julian day origin :
+!> @code
+!> tl_date1=date_init(kd_nsec)
+!> @endcode
+!> - kd_nsec number of second (integer 8)
+!> - from year month day :
+!> @code
+!> tl_date1=date_init(2012,12,10)
+!> @endcode
+!> - from string character formatted date :
+!> @code
+!> tl_date1=date_init(cd_fmtdate)
+!> @endcode
+!> - cd_fmtdate date in format YYYY-MM-DD hh:mm:ss
!>
!> to print date in format YYYY-MM-DD hh:mm:ss
!> CHARACTER(LEN=lc) :: cl_date
-!> cl_date=date_print(tl_date1)
-!> PRINT *, TRIM(cl_date)
-!>
-!> to print day if the week:
-!> PRINT *,"dow ", tl_date1\%i_dow
+!> @code
+!> cl_date=date_print(tl_date1)
+!> PRINT *, TRIM(cl_date)
+!> @endcode
+!>
+!> to print date in another format (only year, month, day):
+!> @code
+!> cl_date=date_print(tl_date1, cd_fmt)
+!> PRINT *, TRIM(cl_date)
+!> @endcode
+!> - cd_fmt ouput format (ex: cd_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" )
+!>
+!> to print day of the week:
+!> @code
+!> PRINT *,"dow ", tl_date1\%i_dow
+!> @endcode
!> to print last day of the month:
-!> PRINT *,"last day ", tl_date1\%i_lday
+!> @code
+!> PRINT *,"last day ", tl_date1\%i_lday
+!> @endcode
+!>
!> to know if year is a leap year:
-!> LOGICAL :: ll_isleap
-!> ll_isleap=date_leapyear(tl_date1)
-!>
-!> to compute difference between to dates:
-!> tl_date2=date_init(2010,12,10)
-!> print *,"diff ",tl_date1-tl_date2
+!> @code
+!> ll_isleap=date_leapyear(tl_date1)
+!> @endcode
+!> - ll_isleap is logical
+!>
+!> to compute number of days between two dates:
+!> @code
+!> tl_date2=date_init(2010,12,10)
+!> dl_diff=tl_date1-tl_date2
+!> @endcode
+!> - dl_diff is the number of days between date1 and date2 (double precision)
!>
!> to add or substract nday to a date:
-!> tl_date2=tl_date1+2.
-!> print *,"add ",trim(date_print(tl_date2))
-!> tl_date2=tl_date1-2.6
-!> print *,"sub ",trim(date_print(tl_date2))
+!> @code
+!> tl_date2=tl_date1+2.
+!> tl_date2=tl_date1-2.6
+!> @endcode
+!> - number of day (double precision)
!>
!> to print julian day:
-!> print *," julian day",tl_date1\%r_jd
+!> @code
+!> PRINT *," julian day",tl_date1\%r_jd
+!> @endcode
!>
!> to print CNES julian day (origin 1950-01-01 00:00:00)
-!> print *," CNES julian day",tl_date1\%r_jc
+!> @code
+!> PRINT *," CNES julian day",tl_date1\%r_jc
+!> @endcode
!>
!> to create pseudo julian day with origin date_now:
-!> tl_date1=date_init(2012,12,10,td_dateo=date_now())
-!> print *," new julian day",tl_date1\%r_jc
-!> Note that you erase CNES julian day when doing so
+!> @code
+!> tl_date1=date_init(2012,12,10,td_dateo=date_now())
+!> @endcode
+!> @note you erase CNES julian day when doing so
!>
!> to print julian day in seconds:
-!> print *, tl_date1\%k_jdsec
+!> @code
+!> PRINT *, tl_date1\%k_jdsec
+!> @endcode
!> to print CNES or new julian day in seconds:
-!> print *, tl_date1\%k_jcsec
-!>
-!> @author
-!> J.Paul
+!> @code
+!> PRINT *, tl_date1\%k_jcsec
+!> @endcode
+!>
+!> @author J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
+!> @date November, 2013 - Initial Version
!
!> @note This module is based on Perderabo's date calculator (ksh)
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+!>
!> @todo
-!> - check if real(sp), integer(i8) is enough
!> - see calendar.f90 and select Gregorian, NoLeap, or D360 calendar
-!> - add suffix to number
-!> - add log message
!----------------------------------------------------------------------
MODULE date
@@ -78,28 +130,30 @@
USE kind ! F90 kind parameter
USE fct ! basic useful function
- USE logger ! log file manager
+ USE logger ! log file manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! type and variable
- PUBLIC :: TDATE ! date structure
+ PUBLIC :: TDATE !< date structure
+
+ PRIVATE :: cm_fmtdate !< date and time format
+ PRIVATE :: im_secbyday !< number of second by day
! function and subroutine
- PUBLIC :: OPERATOR(-) ! substract two dates or n days to a date
- PUBLIC :: OPERATOR(+) ! add n days to a date
- PUBLIC :: date_init ! initiazed date structure form julian day or year month day
- PUBLIC :: date_now ! return the date and time
- PUBLIC :: date_today ! return the date of the day at 12:00:00
- PUBLIC :: date_print ! print the date with format YYYY-MM-DD hh:mm:ss
- PUBLIC :: date_leapyear ! check if year is a leap year
-
- PRIVATE :: date__init_fmtdate ! initiazed date structure from character YYYY-MM-DD hh:mm:ss
- PRIVATE :: date__init_jd ! initiazed date structure from julian day
- PRIVATE :: date__init_nsec ! initiazed date structure from number of second since origin of julian day
- PRIVATE :: date__init_ymd ! initiazed date structure from year month day
+ PUBLIC :: date_today !< return the date of the day at 12:00:00
+ PUBLIC :: date_now !< return the date and time
+ PUBLIC :: date_init !< initialized date structure form julian day or year month day
+ PUBLIC :: date_print !< print the date with format YYYY-MM-DD hh:mm:ss
+ PUBLIC :: date_leapyear !< check if year is a leap year
+ PUBLIC :: OPERATOR(-) !< substract two dates or n days to a date
+ PUBLIC :: OPERATOR(+) !< add n days to a date
+
+ PRIVATE :: date__init_fmtdate ! initialized date structure from character YYYY-MM-DD hh:mm:ss
+ PRIVATE :: date__init_jd ! initialized date structure from julian day
+ PRIVATE :: date__init_nsec ! initialized date structure from number of second since origin of julian day
+ PRIVATE :: date__init_ymd ! initialized date structure from year month day
PRIVATE :: date__addnday ! add nday to a date
PRIVATE :: date__subnday ! substract nday to a date
- PRIVATE :: date__diffdate ! compute number of day between two dates
+ PRIVATE :: date__diffdate ! compute number of days between two dates
PRIVATE :: date__lastday ! compute last day of the month
PRIVATE :: date__ymd2jd ! compute julian day from year month day
@@ -115,10 +169,8 @@
PRIVATE :: date__sec2jd ! convert seconds since julian day origin in julian day
- !> @struct TDATE
- TYPE TDATE
+ TYPE TDATE !< date structure
INTEGER(i4) :: i_year = 1858 !< year
INTEGER(i4) :: i_month = 11 !< month
INTEGER(i4) :: i_day = 17 !< day
- INTEGER(i4) :: i_hms = 0 !< fraction of the day
INTEGER(i4) :: i_hour = 0 !< hour
INTEGER(i4) :: i_min = 0 !< min
@@ -126,6 +178,6 @@
INTEGER(i4) :: i_dow = 0 !< day of week
INTEGER(i4) :: i_lday = 0 !< last day of the month
- REAL(sp) :: r_jd = 0 !< julian day (origin : 1858/11/17 00:00:00)
- REAL(sp) :: r_jc = 0 !< CNES julian day or pseudo julian day with new date origin
+ REAL(dp) :: d_jd = 0 !< julian day (origin : 1858/11/17 00:00:00)
+ REAL(dp) :: d_jc = 0 !< CNES julian day or pseudo julian day with new date origin
INTEGER(i8) :: k_jdsec = 0 !< number of seconds since julian day origin
INTEGER(i8) :: k_jcsec = 0 !< number of seconds since CNES or pseudo julian day origin
@@ -133,5 +185,5 @@
! module variable
- CHARACTER(LEN=lc), PARAMETER :: cm_fmtdate = & !< date format
+ CHARACTER(LEN=lc), PARAMETER :: cm_fmtdate = & !< date and time format
& "(i0.4,'-',i0.2,'-',i0.2,1x,i0.2,':',i0.2,':',i0.2)"
@@ -139,8 +191,8 @@
INTERFACE date_init
- MODULE PROCEDURE date__init_jd ! initiazed date structure from julian day
- MODULE PROCEDURE date__init_nsec ! initiazed date structure from number of second since origin of julian day
- MODULE PROCEDURE date__init_ymd ! initiazed date structure from year month day
- MODULE PROCEDURE date__init_fmtdate ! initiazed date structure from character YYYY-MM-DD hh:mm:ss
+ MODULE PROCEDURE date__init_jd ! initialized date structure from julian day
+ MODULE PROCEDURE date__init_nsec ! initialized date structure from number of second since origin of julian day
+ MODULE PROCEDURE date__init_ymd ! initialized date structure from year month day
+ MODULE PROCEDURE date__init_fmtdate ! initialized date structure from character YYYY-MM-DD hh:mm:ss
END INTERFACE date_init
@@ -156,36 +208,43 @@
CONTAINS
!-------------------------------------------------------------------
- !> @brief This function print the date with
- !> format YYYY/MM/DD hh:mm:ss
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_date : date strutcutre
+ !> @brief This function print the date and time with
+ !> format YYYY/MM/DD hh:mm:ss.
+ !> @details
+ !> Optionally, you could specify output format. However it will be only apply
+ !> to year, month, day.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_date date strutcutre
+ !> @param[in] cd_fmt ouput format (only for year,month,day)
!> @return date in format YYYY-MM-DD hh:mm:ss
!-------------------------------------------------------------------
- ! @code
- CHARACTER(LEN=lc) FUNCTION date_print(td_date)
- IMPLICIT NONE
- ! Argument
- TYPE(TDATE), INTENT(IN) :: td_date
- !----------------------------------------------------------------
-
- WRITE(date_print,cm_fmtdate) &
- & td_date%i_year,td_date%i_month,td_date%i_day, &
- & td_date%i_hour,td_date%i_min,td_date%i_sec
+ CHARACTER(LEN=lc) FUNCTION date_print(td_date, cd_fmt)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TDATE) , INTENT(IN) :: td_date
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_fmt
+ !----------------------------------------------------------------
+
+ IF( PRESENT(cd_fmt) )THEN
+ WRITE(date_print,TRIM(cd_fmt)) &
+ & td_date%i_year,td_date%i_month,td_date%i_day
+ ELSE
+ WRITE(date_print,cm_fmtdate) &
+ & td_date%i_year,td_date%i_month,td_date%i_day, &
+ & td_date%i_hour,td_date%i_min,td_date%i_sec
+ ENDIF
END FUNCTION date_print
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function check if year is a leap year.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_date : date strutcutre
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_date date strutcutre
!> @return true if year is leap year
!-------------------------------------------------------------------
- ! @code
LOGICAL FUNCTION date_leapyear(td_date)
IMPLICIT NONE
@@ -206,14 +265,12 @@
END FUNCTION date_leapyear
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function return the date and time
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @return date and time of the day in a date structure
- !-------------------------------------------------------------------
- ! @code
+ !-------------------------------------------------------------------
+ !> @brief This function return the current date and time.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @return current date and time in a date structure
+ !-------------------------------------------------------------------
TYPE(TDATE) FUNCTION date_now()
IMPLICIT NONE
@@ -228,14 +285,12 @@
END FUNCTION date_now
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function return the date of the day at 12:00:00
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !-------------------------------------------------------------------
+ !> @brief This function return the date of the day at 12:00:00.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
!
!> @return date of the day at 12:00:00 in a date structure
!-------------------------------------------------------------------
- ! @code
TYPE(TDATE) FUNCTION date_today()
IMPLICIT NONE
@@ -249,25 +304,28 @@
END FUNCTION date_today
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function initiazed date structure from a character
- !> date with format YYYY-MM-DD hh:mm:ss
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_date : date in format YYYY-MM-DD hh:mm:ss
- !> @param[in] td_dateo : new date origin for pseudo julian day
+ !-------------------------------------------------------------------
+ !> @brief This function initialized date structure from a character
+ !> date with format YYYY-MM-DD hh:mm:ss.
+ !> @details
+ !> Optionaly create pseudo julian day with new origin.
+ !> julian day origin is 17 Nov 1858 at 00:00:00
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_date date in format YYYY-MM-DD hh:mm:ss
+ !> @param[in] td_dateo new date origin for pseudo julian day
!> @return date structure
!-------------------------------------------------------------------
- ! @code
- TYPE(TDATE) FUNCTION date__init_fmtdate(cd_date, td_dateo)
- IMPLICIT NONE
- ! Argument
- CHARACTER(LEN=*), INTENT(IN) :: cd_date
+ TYPE(TDATE) FUNCTION date__init_fmtdate(cd_datetime, td_dateo)
+ IMPLICIT NONE
+ ! Argument
+ CHARACTER(LEN=*), INTENT(IN) :: cd_datetime
TYPE(TDATE), INTENT(IN), OPTIONAL :: td_dateo
! local variable
+ CHARACTER(LEN=lc) :: cl_datetime
CHARACTER(LEN=lc) :: cl_date
+ CHARACTER(LEN=lc) :: cl_time
CHARACTER(LEN=lc) :: cl_year
CHARACTER(LEN=lc) :: cl_month
@@ -285,17 +343,20 @@
!----------------------------------------------------------------
- cl_date=TRIM(ADJUSTL(cd_date))
-
- cl_year=cl_date(1:4)
+ cl_datetime=TRIM(ADJUSTL(cd_datetime))
+
+ cl_date=fct_split(cl_datetime,1,' ')
+ cl_time=fct_split(cl_datetime,2,' ')
+
+ cl_year = fct_split(cl_date,1,'-')
READ(cl_year,*) il_year
- cl_month=cl_date(6:7)
+ cl_month= fct_split(cl_date,2,'-')
READ(cl_month, *) il_month
- cl_day=cl_date(9:10)
+ cl_day = fct_split(cl_date,3,'-')
READ(cl_day, *) il_day
- cl_hour=cl_date(12:13)
+ cl_hour = fct_split(cl_time,1,':')
READ(cl_hour, *) il_hour
- cl_min=cl_date(15:16)
+ cl_min = fct_split(cl_time,2,':')
READ(cl_min, *) il_min
- cl_sec=cl_date(18:19)
+ cl_sec = fct_split(cl_time,3,':')
READ(cl_sec, *) il_sec
@@ -304,23 +365,22 @@
END FUNCTION date__init_fmtdate
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function initiazed date structure from julian day
- !> optionaly create pseudo julian day with new origin
+ !-------------------------------------------------------------------
+ !> @brief This function initialized date structure from julian day.
+ !> @details
+ !> Optionaly create pseudo julian day with new origin.
!> julian day origin is 17 Nov 1858 at 00:00:00
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] rd_jd : julian day
- !> @param[in] td_dateo : new date origin for pseudo julian day
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] dd_jd julian day
+ !> @param[in] td_dateo new date origin for pseudo julian day
!
!> @return date structure of julian day
!-------------------------------------------------------------------
- ! @code
- TYPE(TDATE) FUNCTION date__init_jd(rd_jd, td_dateo)
+ TYPE(TDATE) FUNCTION date__init_jd(dd_jd, td_dateo)
IMPLICIT NONE
!Argument
- REAL(sp), INTENT(IN) :: rd_jd
+ REAL(dp), INTENT(IN) :: dd_jd
TYPE(TDATE), INTENT(IN), OPTIONAL :: td_dateo
!----------------------------------------------------------------
@@ -329,12 +389,12 @@
! pseudo julian day with origin dateo
- date__init_jd%r_jc=rd_jd
- date__init_jd%k_jcsec=date__jd2sec(rd_jd)
+ date__init_jd%d_jc=dd_jd
+ date__init_jd%k_jcsec=date__jd2sec(dd_jd)
! convert to truly julian day
CALL date__jc2jd(date__init_jd, td_dateo)
ELSE
- date__init_jd%r_jd=rd_jd
- date__init_jd%k_jdsec=date__jd2sec(rd_jd)
+ date__init_jd%d_jd=dd_jd
+ date__init_jd%k_jdsec=date__jd2sec(dd_jd)
! compute CNES julian day
@@ -355,19 +415,18 @@
END FUNCTION date__init_jd
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function initiazed date structure from number of
- !> second since julian day origin
- !> optionaly create pseudo julian day with new origin
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] rd_jd : julian day
- !> @param[in] td_dateo : new date origin for pseudo julian day
+ !-------------------------------------------------------------------
+ !> @brief This function initialized date structure from number of
+ !> second since julian day origin.
+ !> @details
+ !> Optionaly create pseudo julian day with new origin.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] kd_nsec number of second since julian day origin
+ !> @param[in] td_dateo new date origin for pseudo julian day
!
!> @return date structure of julian day
!-------------------------------------------------------------------
- ! @code
TYPE(TDATE) FUNCTION date__init_nsec(kd_nsec, td_dateo)
IMPLICIT NONE
@@ -383,13 +442,13 @@
END FUNCTION date__init_nsec
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function initiazed date structure form year month day
- !> and optionnaly hour min sec
- !> optionaly create pseudo julian day with new origin
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialized date structure form year month day
+ !> and optionnaly hour min sec.
+ !> @details
+ !> Optionaly create pseudo julian day with new origin.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !>
!> @param[in] id_year
!> @param[in] id_month
@@ -398,9 +457,8 @@
!> @param[in] id_min
!> @param[in] id_sec
- !> @param[in] td_dateo : new date origin for pseudo julian day
+ !> @param[in] td_dateo new date origin for pseudo julian day
!
!> @return date structure of year month day
!-------------------------------------------------------------------
- ! @code
TYPE(TDATE) FUNCTION date__init_ymd(id_year, id_month, id_day, &
& id_hour, id_min, id_sec, &
@@ -450,18 +508,16 @@
END FUNCTION date__init_ymd
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function compute number of day between two dates
+ !-------------------------------------------------------------------
+ !> @brief This function compute number of day between two dates:
!> nday= date1 - date2
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_date1 : first date strutcutre
- !> @param[in] td_date2 : second date strutcutre
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_date1 first date strutcutre
+ !> @param[in] td_date2 second date strutcutre
!> @return nday
!-------------------------------------------------------------------
- ! @code
- REAL(sp) FUNCTION date__diffdate(td_date1, td_date2)
+ REAL(dp) FUNCTION date__diffdate(td_date1, td_date2)
IMPLICIT NONE
@@ -475,25 +531,23 @@
CALL date__check(td_date2)
- date__diffdate = td_date1%r_jd - td_date2%r_jd
+ date__diffdate = td_date1%d_jd - td_date2%d_jd
END FUNCTION date__diffdate
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function substract nday to a date
+ !-------------------------------------------------------------------
+ !> @brief This function substract nday to a date:
!> date2 = date1 - nday
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_date : date strutcutre
- !> @param[in] rd_nday : number of day
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_date date strutcutre
+ !> @param[in] dd_nday number of day
!> @return date strutcutre of date - nday
!-------------------------------------------------------------------
- ! @code
- TYPE(TDATE) FUNCTION date__subnday(td_date, rd_nday)
+ TYPE(TDATE) FUNCTION date__subnday(td_date, dd_nday)
IMPLICIT NONE
!Argument
TYPE(TDATE), INTENT(IN) :: td_date
- REAL(sp), INTENT(IN) :: rd_nday
+ REAL(dp), INTENT(IN) :: dd_nday
!----------------------------------------------------------------
@@ -501,25 +555,23 @@
CALL date__check(td_date)
- date__subnday=date__init_jd(td_date%r_jd-rd_nday)
+ date__subnday=date__init_jd(td_date%d_jd-dd_nday)
END FUNCTION date__subnday
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function add nday to a date
+ !-------------------------------------------------------------------
+ !> @brief This function add nday to a date:
!> date2 = date1 + nday
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_date : date strutcutre
- !> @param[in] rd_nday : number of day
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_date date strutcutre
+ !> @param[in] dd_nday number of day
!> @return date strutcutre of date + nday
!-------------------------------------------------------------------
- ! @code
- TYPE(TDATE) FUNCTION date__addnday(td_date, rd_nday)
+ TYPE(TDATE) FUNCTION date__addnday(td_date, dd_nday)
IMPLICIT NONE
!Argument
TYPE(TDATE), INTENT(IN) :: td_date
- REAL(sp), INTENT(IN) :: rd_nday
+ REAL(dp), INTENT(IN) :: dd_nday
!----------------------------------------------------------------
@@ -527,17 +579,16 @@
CALL date__check(td_date)
- date__addnday=date__init_jd(td_date%r_jd+rd_nday)
+ date__addnday=date__init_jd(td_date%d_jd+dd_nday)
END FUNCTION date__addnday
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine compute last day of the month
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_date : date strutcutre
- !-------------------------------------------------------------------
- ! @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_date date strutcutre
+ !> @return last day of the month
+ !-------------------------------------------------------------------
INTEGER(i4) FUNCTION date__lastday(td_date)
IMPLICIT NONE
@@ -562,15 +613,13 @@
END FUNCTION date__lastday
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine compute julian day from year month day
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_date : date strutcutre
- !> @return julian day in the date strutcutre
- !-------------------------------------------------------------------
- ! @code
+ !-------------------------------------------------------------------
+ !> @brief This subroutine compute julian day from year month day , and fill
+ !> input date strutcutre.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_date date strutcutre
+ !-------------------------------------------------------------------
SUBROUTINE date__ymd2jd(td_date)
IMPLICIT NONE
@@ -579,34 +628,32 @@
! local variable
- REAL(sp) :: rl_standard_jd
- REAL(sp) :: rl_frac
- !----------------------------------------------------------------
-
- rl_standard_jd= td_date%i_day - 32075 &
+ REAL(dp) :: dl_standard_jd
+ REAL(dp) :: dl_frac
+ !----------------------------------------------------------------
+
+ dl_standard_jd= td_date%i_day - 32075 &
& + 1461 * (td_date%i_year + 4800 - (14 - td_date%i_month)/12)/4 &
& + 367 * (td_date%i_month - 2 + (14 - td_date%i_month)/12*12)/12 &
& - 3 * ((td_date%i_year + 4900 - (14 - td_date%i_month)/12)/100)/4
- td_date%r_jd = rl_standard_jd-2400001 ! origin : 17 nov 1858 h00m00s00
+ td_date%d_jd = dl_standard_jd-2400001 ! origin : 17 nov 1858 h00m00s00
! compute fraction of day
- rl_frac=date__hms2jd(td_date)
-
- td_date%r_jd = td_date%r_jd + rl_frac
-
- td_date%k_jdsec = date__jd2sec( td_date%r_jd )
+ dl_frac=date__hms2jd(td_date)
+
+ td_date%d_jd = td_date%d_jd + dl_frac
+
+ td_date%k_jdsec = date__jd2sec( td_date%d_jd )
END SUBROUTINE date__ymd2jd
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine compute year month day from julian day
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_date : date strutcutre
- !> @return year month day in the date strutcutre
- !-------------------------------------------------------------------
- ! @code
+ !-------------------------------------------------------------------
+ !> @brief This subroutine compute year month day from julian day, and fill
+ !> input date strutcutre.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_date date strutcutre
+ !-------------------------------------------------------------------
SUBROUTINE date__jd2ymd(td_date)
IMPLICIT NONE
@@ -615,5 +662,4 @@
! local variable
- REAL(sp) :: rl_frac
INTEGER(i4) :: il_standard_jd
INTEGER(i4) :: il_temp1
@@ -624,6 +670,5 @@
CALL date__check(td_date)
- il_standard_jd=INT( td_date%r_jd+2400001, i4 )
- rl_frac=(td_date%r_jd+2400001)-il_standard_jd
+ il_standard_jd=INT( td_date%d_jd+2400001, i4 )
il_temp1=il_standard_jd + 68569
@@ -645,16 +690,14 @@
END SUBROUTINE date__jd2ymd
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine compute julian day from pseudo julian day
- !> with new date origin
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_date : date
- !> @return julian day inside input date structure
- !-------------------------------------------------------------------
- ! @code
+ !> with new date origin, and fill input date strutcutre.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_date date
+ !> @param[in] td_dateo new date origin for pseudo julian day
+ !-------------------------------------------------------------------
SUBROUTINE date__jc2jd(td_date, td_dateo)
IMPLICIT NONE
@@ -665,30 +708,28 @@
! local variable
TYPE(TDATE) :: tl_date
- REAL(sp) :: rl_nday
+ REAL(dp) :: dl_nday
!----------------------------------------------------------------
! origin julian day
tl_date=date_init(1858,11,17)
- rl_nday=td_dateo-tl_date
+ dl_nday=td_dateo-tl_date
! compute julian day
- td_date%r_jd = td_date%r_jc + rl_nday
+ td_date%d_jd = td_date%d_jc + dl_nday
! compute number of second since julian day origin
- td_date%k_jdsec = date__jd2sec(td_date%r_jd)
+ td_date%k_jdsec = date__jd2sec(td_date%d_jd)
END SUBROUTINE date__jc2jd
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine compute pseudo julian day with new date origin
- !> default new origin is CNES julian day origin: 1950/01/01
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_date : date
- !> @param[in] td_dateo : new origin date
- !> @return pseudo julian day inside input date structure
- !-------------------------------------------------------------------
- ! @code
+ !-------------------------------------------------------------------
+ !> @brief This subroutine compute pseudo julian day with new date origin, and
+ !> fill input date structure.
+ !> default new origin is CNES julian day origin: 1950-01-01 00:00:00
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_date date
+ !> @param[in] td_dateo new origin date
+ !-------------------------------------------------------------------
SUBROUTINE date__jd2jc(td_date, td_dateo)
IMPLICIT NONE
@@ -701,5 +742,5 @@
!----------------------------------------------------------------
IF( PRESENT(td_dateo) )THEN
- td_date%r_jc=td_date%r_jd-td_dateo%r_jd
+ td_date%d_jc=td_date%d_jd-td_dateo%d_jd
ELSE
! CNES julian day origin
@@ -710,23 +751,21 @@
CALL date__ymd2jd(tl_dateo)
- td_date%r_jc = td_date%r_jd-tl_dateo%r_jd
- ENDIF
-
- td_date%k_jcsec = date__jd2sec(td_date%r_jc)
+ td_date%d_jc = td_date%d_jd-tl_dateo%d_jd
+ ENDIF
+
+ td_date%k_jcsec = date__jd2sec(td_date%d_jc)
END SUBROUTINE date__jd2jc
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine compute the day of week from julian day
+ !-------------------------------------------------------------------
+ !> @brief This subroutine compute the day of week from julian day, and fill
+ !> input date structure.
!> days : Sunday Monday Tuesday Wednesday Thursday Friday Saturday
!> numday : 0 1 2 3 4 5 6
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_date : date strutcutre
- !> @return day of week inside input date structure
- !-------------------------------------------------------------------
- ! @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_date date strutcutre
+ !-------------------------------------------------------------------
SUBROUTINE date__jd2dow(td_date)
IMPLICIT NONE
@@ -735,20 +774,18 @@
!----------------------------------------------------------------
- td_date%i_dow=MOD((INT(AINT(td_date%r_jd))+3),7)
+ td_date%i_dow=MOD((INT(AINT(td_date%d_jd))+3),7)
END SUBROUTINE date__jd2dow
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function compute fraction of a day from
- !> hour, minute, second
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_date : date strutcutre
+ !> hour, minute, second.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_date date strutcutre
!> @return fraction of the day
!-------------------------------------------------------------------
- ! @code
- REAL(sp) FUNCTION date__hms2jd(td_date)
+ REAL(dp) FUNCTION date__hms2jd(td_date)
IMPLICIT NONE
! Argument
@@ -757,25 +794,22 @@
! compute real seconds
- date__hms2jd = REAL( td_date%i_sec, sp )
+ date__hms2jd = REAL( td_date%i_sec, dp )
! compute real minutes
- date__hms2jd = REAL( td_date%i_min, sp ) + date__hms2jd/60.0
+ date__hms2jd = REAL( td_date%i_min, dp ) + date__hms2jd/60.0
! compute real hours
- date__hms2jd = REAL( td_date%i_hour, sp ) + date__hms2jd/60.0
+ date__hms2jd = REAL( td_date%i_hour, dp ) + date__hms2jd/60.0
! julian fraction of a day
date__hms2jd = date__hms2jd/24.0
END FUNCTION date__hms2jd
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function compute hour, minute, second from julian
- !> fraction
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_date : date strutcutre
- !> @return date strutcutre
- !-------------------------------------------------------------------
- ! @code
+ !-------------------------------------------------------------------
+ !> @brief This subroutine compute hour, minute, second from julian
+ !> fraction, and fill date structure.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_date date strutcutre
+ !-------------------------------------------------------------------
SUBROUTINE date__jd2hms(td_date)
IMPLICIT NONE
@@ -784,28 +818,26 @@
!local variable
- REAL(sp) :: rl_fract
- !----------------------------------------------------------------
-
- rl_fract=(td_date%r_jd)-AINT(td_date%r_jd)
+ REAL(dp) :: dl_fract
+ !----------------------------------------------------------------
+
+ dl_fract=(td_date%d_jd)-AINT(td_date%d_jd)
! compute hour
- td_date%i_hour = INT( rl_fract * 24.0, i4 )
- rl_fract = ( rl_fract - REAL( td_date%i_hour, sp ) / 24.0) * 24.0
+ td_date%i_hour = INT( dl_fract * 24.0, i4 )
+ dl_fract = ( dl_fract - REAL( td_date%i_hour, dp ) / 24.0) * 24.0
! compute minute
- td_date%i_min = INT( rl_fract * 60.0, i4 )
- rl_fract = ( rl_fract - REAL( td_date%i_min, sp ) / 60.0) * 60.0
+ td_date%i_min = INT( dl_fract * 60.0, i4 )
+ dl_fract = ( dl_fract - REAL( td_date%i_min, dp ) / 60.0) * 60.0
! compute second
- td_date%i_sec = NINT( rl_fract * 60.0, i4 )
+ td_date%i_sec = NINT( dl_fract * 60.0, i4 )
END SUBROUTINE date__jd2hms
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine check date express in date structure
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_date : date strutcutre
- !-------------------------------------------------------------------
- ! @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_date date strutcutre
+ !-------------------------------------------------------------------
SUBROUTINE date__check(td_date)
IMPLICIT NONE
@@ -819,60 +851,67 @@
!----------------------------------------------------------------
+ ! init
+ il_status=0
+
! check year
IF( td_date%i_year < 1858_i4 .OR. td_date%i_year > 39999_i4 )THEN
+ il_status=il_status+1
WRITE(cl_msg,*) "year ",td_date%i_year," out of range"
CALL logger_error(cl_msg)
- CALL fct_err(il_status)
ENDIF
! check month
IF( td_date%i_month < 1_i4 .OR. td_date%i_month > 12_i4 )THEN
+ il_status=il_status+1
WRITE(cl_msg,*) "month ",td_date%i_month," out of range"
CALL logger_error(cl_msg)
- CALL fct_err(il_status)
ENDIF
! check day
il_lastday=date__lastday(td_date)
IF( td_date%i_day < 1_i4 .OR. td_date%i_day > il_lastday )THEN
+ il_status=il_status+1
WRITE(cl_msg,*) "day ",td_date%i_day," out of range"
CALL logger_error(cl_msg)
- CALL fct_err(il_status)
ENDIF
! check hour
IF( td_date%i_hour < 0_i4 .OR. td_date%i_hour > 23_i4 )THEN
+ il_status=il_status+1
WRITE(cl_msg,*) "hour ",td_date%i_hour," out of range"
CALL logger_error(cl_msg)
- CALL fct_err(il_status)
ENDIF
! check minutes
IF( td_date%i_min < 0_i4 .OR. td_date%i_min > 59_i4 )THEN
+ il_status=il_status+1
WRITE(cl_msg,*) "minutes ",td_date%i_min," out of range"
CALL logger_error(cl_msg)
- CALL fct_err(il_status)
ENDIF
! check seconds
IF( td_date%i_sec < 0_i4 .OR. td_date%i_sec > 59_i4 )THEN
+ il_status=il_status+1
WRITE(cl_msg,*) "seconds ",td_date%i_sec," out of range"
CALL logger_error(cl_msg)
- CALL fct_err(il_status)
ENDIF
! check julian day
- IF( td_date%r_jd < 0_sp .OR. td_date%r_jd > 782028_sp )THEN
- WRITE(cl_msg,*) "julian day ",td_date%r_jd," out of range"
+ IF( td_date%d_jd < 0_sp .OR. td_date%d_jd > 782028_sp )THEN
+ il_status=il_status+1
+ WRITE(cl_msg,*) "julian day ",td_date%d_jd," out of range"
CALL logger_error(cl_msg)
- CALL fct_err(il_status)
+ ENDIF
+
+ IF( il_status/= 0 )THEN
+ WRITE(cl_msg,*) " date error"
+ CALL logger_fatal(cl_msg)
ENDIF
END SUBROUTINE date__check
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine adjust date
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_date : date strutcutre
- !-------------------------------------------------------------------
- ! @code
+ !-------------------------------------------------------------------
+ !> @brief This subroutine adjust date (correct hour, minutes, and seconds
+ !> value if need be)
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_date date strutcutre
+ !-------------------------------------------------------------------
SUBROUTINE date__adjust(td_date)
IMPLICIT NONE
@@ -893,40 +932,36 @@
IF( td_date%i_hour == 24 )THEN
td_date%i_hour=0
- td_date=date__addnday(td_date,1._sp)
+ td_date=date__addnday(td_date,1._dp)
ENDIF
END SUBROUTINE date__adjust
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function convert julian day in seconds
- !> since julian day origin
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_date : date strutcutre
+ !> since julian day origin.
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_date date strutcutre
!> @return number of seconds since julian day origin
!-------------------------------------------------------------------
- ! @code
- INTEGER(i8) FUNCTION date__jd2sec(rd_jul)
- IMPLICIT NONE
- ! Argument
- REAL(sp), INTENT(IN) :: rd_jul
- !----------------------------------------------------------------
-
- date__jd2sec = NINT( rd_jul * im_secbyday, i8 )
+ INTEGER(i8) FUNCTION date__jd2sec(dd_jul)
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp), INTENT(IN) :: dd_jul
+ !----------------------------------------------------------------
+
+ date__jd2sec = NINT( dd_jul * im_secbyday, i8 )
END FUNCTION date__jd2sec
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function convert seconds since julian day origin in
- !> julian day
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_date : date strutcutre
- !> @return number of seconds since julian day origin
- !-------------------------------------------------------------------
- ! @code
- REAL(sp) FUNCTION date__sec2jd(kd_nsec)
+ !> julian day.
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] kd_nsec number of second since julian day origin
+ !> @return julian day
+ !-------------------------------------------------------------------
+ REAL(dp) FUNCTION date__sec2jd(kd_nsec)
IMPLICIT NONE
! Argument
@@ -934,8 +969,7 @@
!----------------------------------------------------------------
- date__sec2jd = REAL( REAL( kd_nsec , sp ) / im_secbyday, sp )
+ date__sec2jd = REAL( REAL( kd_nsec , dp ) / im_secbyday, dp )
END FUNCTION date__sec2jd
- ! @endcode
END MODULE date
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/dimension.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/dimension.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/dimension.f90 (revision 5214)
@@ -8,18 +8,35 @@
!> @brief
!> This module manage dimension and how to change order of those dimension.
-!
+!>
!> @details
!> define type TDIM:
-!> TYPE(TDIM) :: tl_dim
-!>
-!> to initialise a dimension structure:
-!> - tl_dim=dim_init( cd_name, [id_len,] [ld_uld,] [cd_sname])
+!> @code
+!> TYPE(TDIM) :: tl_dim
+!> @endcode
+!>
+!> to initialize a dimension structure:
+!> @code
+!> tl_dim=dim_init( cd_name, [id_len,] [ld_uld,] [cd_sname])
+!> @endcode
!> - cd_name is the dimension name
-!> - id_len is the dimension size (optional)
-!> - ld_uld is true if this dimension is the unlimited one (optional)
-!> - cd_sname is the dimension short name (optional)
+!> - id_len is the dimension size [optional]
+!> - ld_uld is true if this dimension is the unlimited one [optional]
+!> - cd_sname is the dimension short name ('x','y','z','t') [optional]
+!>
+!> to clean dimension structure:
+!> @code
+!> CALL dim_clean(tl_dim)
+!> @endcode
+!> - tl_dim : dimension strucutre or array of dimension structure
!>
!> to print information about dimension structure:
+!> @code
!> CALL dim_print(tl_dim)
+!> @endcode
+!>
+!> to copy dimension structure in another one (using different memory cell):
+!> @code
+!> tl_dim2=dim_copy(tl_dim1)
+!> @endcode
!>
!> to get dimension name:
@@ -35,8 +52,8 @@
!> - tl_dim\%l_uld
!>
-!> to get dimension id (use for variable or file dimension):
+!> to get dimension id (for variable or file dimension):
!> - tl_dim\%i_id
!>
-!> to know if dimension is used (use for variable or file dimension):
+!> to know if dimension is used (for variable or file dimension):
!> - tl_dim\%l_use
!>
@@ -44,55 +61,97 @@
!> variables as well as files use usually 4 dimensions.
!> To easily work with variable we want they will be all 4D and ordered as
-!> follow: ('x','y','z','t').
+!> following: ('x','y','z','t').
!> Functions and subroutines below, allow to reorder dimension of
!> variable.
!>
-!> Suppose we defined the table of dimension structure below:
-!> TYPE(TDIM), DIMENSION(4) :: tl_dim
+!> Suppose we defined the array of dimension structure below:
+!> @code
+!> TYPE(TDIM), DIMENSION(4) :: tl_dim
!> tl_dim(1)=dim_init( 'X', id_len=10)
!> tl_dim(2)=dim_init( 'T', id_len=3, ld_uld=.TRUE.)
-!>
-!> to reorder dimension as we assume variable are defined
-!> ('x','y','z','t'):
-!> CALL dim_reorder(tl(dim(:))
+!> @endcode
+!>
+!> to reorder dimension (default order: ('x','y','z','t')):
+!> @code
+!> CALL dim_reorder(tl_dim(:))
+!> @endcode
!>
!> This subroutine filled dimension structure with unused dimension,
-!> then switch from "unordered" dimension to "ordered" dimension
-!> The dimension structure return will be:
-!> tl_dim(1) => 'X', i_len=10, l_use=T, l_uld=F
-!> tl_dim(2) => 'Y', i_len=0, l_use=F, l_uld=F
-!> tl_dim(3) => 'Z', i_len=0, l_use=F, l_uld=F
-!> tl_dim(4) => 'T', i_len=3, l_use=T, l_uld=T
-!>
-!> After using dim_reorder subroutine you could use functions and subroutine
+!> then switch from "unordered" dimension to "ordered" dimension.
+!> The dimension structure return will be:
+!> tl_dim(1) => 'X', i_len=10, l_use=T, l_uld=F
+!> tl_dim(2) => 'Y', i_len=1, l_use=F, l_uld=F
+!> tl_dim(3) => 'Z', i_len=1, l_use=F, l_uld=F
+!> tl_dim(4) => 'T', i_len=3, l_use=T, l_uld=T
+!>
+!> After using subroutine dim_reorder you could use functions and subroutine
!> below.
!>
-!> to reshape table of value in "ordered" dimension:
+!> to use another dimension order.
+!> @code
+!> CALL dim_reorder(tl(dim(:), cl_neworder)
+!> @endcode
+!> - cl_neworder : character(len=4) (example: 'yxzt')
+!>
+!> to switch dimension array from ordered dimension to unordered
+!> dimension:
+!> @code
+!> CALL dim_unorder(tl_dim(:))
+!> @endcode
+!>
+!> to fill unused dimension of an array of dimension structure.
+!> @code
+!> tl_dimout(:)=dim_fill_unused(tl_dimin(:))
+!> @endcode
+!> - tl_dimout(:) : 1D array (4elts) of dimension strcuture
+!> - tl_dimin(:) : 1D array (<=4elts) of dimension structure
+!>
+!> to reshape array of value in "ordered" dimension:
+!> @code
!> CALL dim_reshape_2xyzt(tl_dim(:), value(:,:,:,:))
-!> - value must be a 4D table of real(8) value "unordered"
-!>
-!> to reshape table of value in "unordered" dimension:
+!> @endcode
+!> - value must be a 4D array of real(8) value "unordered"
+!>
+!> to reshape array of value in "unordered" dimension:
+!> @code
!> CALL dim_reshape_xyzt2(tl_dim(:), value(:,:,:,:))
-!> - value must be a 4D table of real(8) value "ordered"
-!>
-!> to reorder a 1D table of 4 elements in "ordered" dimension:
+!> @endcode
+!> - value must be a 4D array of real(8) value "ordered"
+!>
+!> to reorder a 1D array of 4 elements in "ordered" dimension:
+!> @code
!> CALL dim_reorder_2xyzt(tl_dim(:), tab(:))
-!>
-!> - tab must be a 1D table with 4 elements "unordered".
+!> @endcode
+!> - tab must be a 1D array with 4 elements "unordered".
!> It could be composed of character, integer(4), or logical
!>
-!> to reorder a 1D table of 4 elements in "unordered" dimension:
+!> to reorder a 1D array of 4 elements in "unordered" dimension:
+!> @code
!> CALL dim_reorder_2xyzt(tl_dim(:), tab(:))
-!>
-!> - tab must be a 1D table with 4 elements "ordered".
+!> @endcode
+!> - tab must be a 1D array with 4 elements "ordered".
!> It could be composed of character, integer(4), or logical
!>
-!> @author
-!> J.Paul
+!> to get dimension index from a array of dimension structure,
+!> given dimension name or short name :
+!> @code
+!> index=dim_get_index( tl_dim(:), [cl_name, cl_sname] )
+!> @endcode
+!> - tl_dim(:) : array of dimension structure
+!> - cl_name : dimension name [optional]
+!> - cl_sname: dimension short name [optional]
+!>
+!> to get dimension id used in an array of dimension structure,
+!> given dimension name or short name :
+!> @code
+!> id=dim_get_id( tl_dim(:), [cl_name, cl_sname] )
+!> @endcode
+!> - tl_dim(:) : array of dimension structure
+!> - cl_name : dimension name [optional]
+!> - cl_sname: dimension short name [optional]
+!>
+!> @author J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
-!> @todo
-!> - add description generique de l'objet dim
+!> @date November, 2013 - Initial Version
!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
@@ -104,11 +163,8 @@
USE fct ! basic useful function
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! type and variable
PUBLIC :: TDIM !< dimension structure
- PUBLIC :: ip_maxdim !< number of dimension to be used
- PUBLIC :: cp_dimorder !< dimension order
! function and subroutine
@@ -116,94 +172,164 @@
PUBLIC :: dim_clean !< clean dimension structuree
PUBLIC :: dim_print !< print dimension information
- PUBLIC :: dim_get_id !< get dimension id in table of dimension structure
- PUBLIC :: dim_get_void_id !< get unused dimension id in table of dimension structure
- PUBLIC :: dim_order !< check if dimension are ordered or not
+ PUBLIC :: dim_copy !< copy dimension structure
PUBLIC :: dim_reorder !< filled dimension structure to switch from unordered to ordered dimension
- PUBLIC :: dim_unorder !< switch dimension table from ordered to unordered dimension
- PUBLIC :: dim_reshape_2xyzt !< reshape table dimension to ('x','y','z','t')
- PUBLIC :: dim_reshape_xyzt2 !< reshape table dimension from ('x','y','z','t')
- PUBLIC :: dim_reorder_2xyzt !< reorder 1D table to ('x','y','z','t')
- PUBLIC :: dim_reorder_xyzt2 !< reorder 1D table from ('x','y','z','t')
-
- PRIVATE :: dim__fill_unused !< filled dimension structure with unused dimension
- PRIVATE :: dim__reshape_2xyzt_dp !< reshape real(8) 4D table to ('x','y','z','t')
- PRIVATE :: dim__reshape_xyzt2_dp !< reshape real(8) 4D table from ('x','y','z','t')
- PRIVATE :: dim__reorder_2xyzt_i4 !< reorder integer(4) 1D table to ('x','y','z','t')
- PRIVATE :: dim__reorder_xyzt2_i4 !< reorder integer(4) 1D table from ('x','y','z','t')
- PRIVATE :: dim__reorder_2xyzt_l !< reorder logical 1D table to ('x','y','z','t')
- PRIVATE :: dim__reorder_xyzt2_l !< reorder logical 1D table from ('x','y','z','t')
- PRIVATE :: dim__reorder_2xyzt_c !< reorder string 1D table to ('x','y','z','t')
- PRIVATE :: dim__reorder_xyzt2_c !< reorder string 1D table from ('x','y','z','t')
- PRIVATE :: dim__clean_unit !< clean one dimension structure
- PRIVATE :: dim__clean_tab !< clean a table of dimension structure
- PRIVATE :: dim__print_unit !< print information on one dimension structure
- PRIVATE :: dim__print_tab !< print information on a table of dimension structure
-
- !> @struct TDIM
- TYPE TDIM
- CHARACTER(LEN=lc) :: c_name = ''!< dimension name
+ PUBLIC :: dim_unorder !< switch dimension array from ordered to unordered dimension
+ PUBLIC :: dim_fill_unused !< filled dimension structure with unused dimension
+ PUBLIC :: dim_reshape_2xyzt !< reshape array dimension to ('x','y','z','t')
+ PUBLIC :: dim_reshape_xyzt2 !< reshape array dimension from ('x','y','z','t')
+ PUBLIC :: dim_reorder_2xyzt !< reorder 1D array to ('x','y','z','t')
+ PUBLIC :: dim_reorder_xyzt2 !< reorder 1D array from ('x','y','z','t')
+ PUBLIC :: dim_get_index !< get dimension index in array of dimension structure
+ PUBLIC :: dim_get_id !< get dimension id in array of dimension structure
+
+ PRIVATE :: dim__reshape_2xyzt_dp ! reshape real(8) 4D array to ('x','y','z','t')
+ PRIVATE :: dim__reshape_xyzt2_dp ! reshape real(8) 4D array from ('x','y','z','t')
+ PRIVATE :: dim__reorder_2xyzt_i4 ! reorder integer(4) 1D array to ('x','y','z','t')
+ PRIVATE :: dim__reorder_xyzt2_i4 ! reorder integer(4) 1D array from ('x','y','z','t')
+ PRIVATE :: dim__reorder_2xyzt_l ! reorder logical 1D array to ('x','y','z','t')
+ PRIVATE :: dim__reorder_xyzt2_l ! reorder logical 1D array from ('x','y','z','t')
+ PRIVATE :: dim__reorder_2xyzt_c ! reorder string 1D array to ('x','y','z','t')
+ PRIVATE :: dim__reorder_xyzt2_c ! reorder string 1D array from ('x','y','z','t')
+ PRIVATE :: dim__clean_unit ! clean one dimension structure
+ PRIVATE :: dim__clean_arr ! clean a array of dimension structure
+ PRIVATE :: dim__print_unit ! print information on one dimension structure
+ PRIVATE :: dim__print_arr ! print information on a array of dimension structure
+ PRIVATE :: dim__copy_unit ! copy dimension structure
+ PRIVATE :: dim__copy_arr ! copy array of dimension structure
+
+ TYPE TDIM !< dimension structure
+ CHARACTER(LEN=lc) :: c_name = '' !< dimension name
CHARACTER(LEN=lc) :: c_sname = 'u' !< dimension short name
- INTEGER(i4) :: i_id = 0 !< dimension id
+ INTEGER(i4) :: i_id = 0 !< dimension id
INTEGER(i4) :: i_len = 1 !< dimension length
LOGICAL :: l_uld = .FALSE. !< dimension unlimited or not
LOGICAL :: l_use = .FALSE. !< dimension used or not
- INTEGER(i4) :: i_2xyzt = 0 !< indices to reshape table to ('x','y','z','t')
- INTEGER(i4) :: i_xyzt2 = 0 !< indices to reshape table from ('x','y','z','t')
+ INTEGER(i4) :: i_2xyzt = 0 !< indices to reshape array to ('x','y','z','t')
+ INTEGER(i4) :: i_xyzt2 = 0 !< indices to reshape array from ('x','y','z','t')
END TYPE
-
- INTEGER(i4), PARAMETER :: ip_maxdim = 4 !< number of dimension to be used
-
- ! module variable
- CHARACTER(LEN=lc), PARAMETER :: cp_dimorder = 'xyzt' !< dimension order to output
INTERFACE dim_print
MODULE PROCEDURE dim__print_unit ! print information on one dimension
- MODULE PROCEDURE dim__print_tab ! print information on a table of dimension
+ MODULE PROCEDURE dim__print_arr ! print information on a array of dimension
END INTERFACE dim_print
INTERFACE dim_clean
MODULE PROCEDURE dim__clean_unit ! clean one dimension
- MODULE PROCEDURE dim__clean_tab ! clean a table of dimension
+ MODULE PROCEDURE dim__clean_arr ! clean a array of dimension
END INTERFACE dim_clean
+ INTERFACE dim_copy
+ MODULE PROCEDURE dim__copy_unit ! copy dimension structure
+ MODULE PROCEDURE dim__copy_arr ! copy array of dimension structure
+ END INTERFACE
+
INTERFACE dim_reshape_2xyzt
- MODULE PROCEDURE dim__reshape_2xyzt_dp ! reshape real(8) 4D table to ('x','y','z','t')
+ MODULE PROCEDURE dim__reshape_2xyzt_dp ! reshape real(8) 4D array to ('x','y','z','t')
END INTERFACE dim_reshape_2xyzt
INTERFACE dim_reshape_xyzt2
- MODULE PROCEDURE dim__reshape_xyzt2_dp ! reshape real(8) 4D table from ('x','y','z','t')
+ MODULE PROCEDURE dim__reshape_xyzt2_dp ! reshape real(8) 4D array from ('x','y','z','t')
END INTERFACE dim_reshape_xyzt2
INTERFACE dim_reorder_2xyzt
- MODULE PROCEDURE dim__reorder_2xyzt_i4 ! reorder integer(4) 1D table to ('x','y','z','t')
- MODULE PROCEDURE dim__reorder_2xyzt_c ! reorder string 1D table to ('x','y','z','t')
- MODULE PROCEDURE dim__reorder_2xyzt_l ! reorder logical 1D table to ('x','y','z','t')
+ MODULE PROCEDURE dim__reorder_2xyzt_i4 ! reorder integer(4) 1D array to ('x','y','z','t')
+ MODULE PROCEDURE dim__reorder_2xyzt_c ! reorder string 1D array to ('x','y','z','t')
+ MODULE PROCEDURE dim__reorder_2xyzt_l ! reorder logical 1D array to ('x','y','z','t')
END INTERFACE dim_reorder_2xyzt
INTERFACE dim_reorder_xyzt2
- MODULE PROCEDURE dim__reorder_xyzt2_i4 ! reorder integer(4) 1D table from ('x','y','z','t')
- MODULE PROCEDURE dim__reorder_xyzt2_c ! reorder string 1D table from ('x','y','z','t')
- MODULE PROCEDURE dim__reorder_xyzt2_l ! reorder logical 1D table from ('x','y','z','t')
+ MODULE PROCEDURE dim__reorder_xyzt2_i4 ! reorder integer(4) 1D array from ('x','y','z','t')
+ MODULE PROCEDURE dim__reorder_xyzt2_c ! reorder string 1D array from ('x','y','z','t')
+ MODULE PROCEDURE dim__reorder_xyzt2_l ! reorder logical 1D array from ('x','y','z','t')
END INTERFACE dim_reorder_xyzt2
CONTAINS
!-------------------------------------------------------------------
- !> @brief This function returns dimension id, in a table of dimension structure,
- !> given dimension name, or short name.
- !> only dimension used are checked.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : dimension structure
- !> @param[in] cd_name : dimension name or short name
- !> @param[in] cd_sname : dimension short name
- !> @return dimension id
- !-------------------------------------------------------------------
- !> @code
- INTEGER(i4) FUNCTION dim_get_id( td_dim, cd_name, cd_sname )
+ !> @brief
+ !> This subroutine copy a array of dimension structure in another one
+ !> @details
+ !> see dim__copy_unit
+ !>
+ !> @warning do not use on the output of a function who create or read an
+ !> structure (ex: tl_dim=dim_copy(dim_init()) is forbidden).
+ !> This will create memory leaks.
+ !> @warning to avoid infinite loop, do not use any function inside
+ !> this subroutine
+ !>
+ !> @author J.Paul
+ !> @date November, 2014 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension structure
+ !> @return copy of input array of dimension structure
+ !-------------------------------------------------------------------
+ FUNCTION dim__copy_arr( td_dim )
IMPLICIT NONE
! Argument
- TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim
+ TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim
+ ! function
+ TYPE(TDIM), DIMENSION(SIZE(td_dim(:))) :: dim__copy_arr
+
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ DO ji=1,SIZE(td_dim(:))
+ dim__copy_arr(ji)=dim_copy(td_dim(ji))
+ ENDDO
+
+ END FUNCTION dim__copy_arr
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine copy an dimension structure in another one
+ !> @details
+ !> dummy function to get the same use for all structure
+ !>
+ !> @warning do not use on the output of a function who create or read an
+ !> structure (ex: tl_dim=dim_copy(dim_init()) is forbidden).
+ !> This will create memory leaks.
+ !> @warning to avoid infinite loop, do not use any function inside
+ !> this subroutine
+ !>
+ !> @author J.Paul
+ !> @date November, 2014 - Initial Version
+ !>
+ !> @param[in] td_dim dimension structure
+ !> @return copy of input dimension structure
+ !-------------------------------------------------------------------
+ FUNCTION dim__copy_unit( td_dim )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TDIM), INTENT(IN) :: td_dim
+ ! function
+ TYPE(TDIM) :: dim__copy_unit
+
+ ! local variable
+ !----------------------------------------------------------------
+
+ dim__copy_unit=td_dim
+
+ END FUNCTION dim__copy_unit
+ !-------------------------------------------------------------------
+ !> @brief This function returns dimension index,
+ !> given dimension name or short name.
+ !>
+ !> @details
+ !> the function check dimension name, in the array of dimension structure.
+ !> dimension could be used or not.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !> @date September, 2014 - do not check if dimension used
+ !>
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] cd_name dimension name
+ !> @param[in] cd_sname dimension short name
+ !> @return dimension index
+ !-------------------------------------------------------------------
+ INTEGER(i4) FUNCTION dim_get_index( td_dim, cd_name, cd_sname )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TDIM) , DIMENSION(:), INTENT(IN) :: td_dim
CHARACTER(LEN=*), INTENT(IN) :: cd_name
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sname
@@ -222,5 +348,5 @@
!----------------------------------------------------------------
! init
- dim_get_id=0
+ dim_get_index=0
il_ndim=SIZE(td_dim(:))
@@ -228,82 +354,71 @@
! look for dimension name
cl_name=fct_lower(cd_name)
- ! check if dimension is in table of dimension structure and used
+ ! check if dimension is in array of dimension structure
jj=0
DO ji=1,il_ndim
- !IF( td_dim(ji)%l_use ) jj=jj+1
-
cl_dim_name=fct_lower(td_dim(ji)%c_name)
- IF( TRIM(cl_dim_name) == TRIM(cl_name) .AND. &
- & td_dim(ji)%l_use )THEN
- dim_get_id=ji !jj
- CALL logger_debug("GET ID: variable name "//&
- & TRIM(ADJUSTL(cd_name))//" already in file " )
- EXIT
+ IF( TRIM(cl_dim_name) == TRIM(cl_name) )THEN
+ dim_get_index=ji
+ EXIT
ENDIF
ENDDO
! look for dimension short name
- IF( dim_get_id == 0 )THEN
+ IF( dim_get_index == 0 )THEN
cl_sname=fct_lower(cd_name)
- ! check if dimension is in table of dimension structure and used
+ ! check if dimension is in array of dimension structure
jj=0
DO ji=1,il_ndim
- IF( td_dim(ji)%l_use ) jj=jj+1
-
cl_dim_sname=fct_lower(td_dim(ji)%c_sname)
- IF( (TRIM(cl_dim_sname) == TRIM(cl_sname) ).AND.&
- & td_dim(ji)%l_use )THEN
- CALL logger_debug("GET ID: variable short name "//&
+ IF( (TRIM(cl_dim_sname) == TRIM(cl_sname) ) )THEN
+ CALL logger_debug("DIM GET INDEX: variable short name "//&
& TRIM(ADJUSTL(cd_name))//" already in file")
- dim_get_id=jj
+ dim_get_index=ji
EXIT
ENDIF
ENDDO
+
ENDIF
! look for dimension short name
IF( PRESENT(cd_sname) )THEN
- IF( dim_get_id == 0 )THEN
+ IF( dim_get_index == 0 )THEN
cl_sname=fct_lower(cd_sname)
- ! check if dimension is in table of dimension structure and used
+ ! check if dimension is in array of dimension structure
jj=0
DO ji=1,il_ndim
- IF( td_dim(ji)%l_use ) jj=jj+1
-
cl_dim_sname=fct_lower(td_dim(ji)%c_sname)
- IF( (TRIM(cl_dim_sname) == TRIM(cl_sname) ).AND.&
- & td_dim(ji)%l_use )THEN
- CALL logger_debug("GET ID: variable short name "//&
+ IF( (TRIM(cl_dim_sname) == TRIM(cl_sname) ) )THEN
+ CALL logger_debug("DIM GET INDEX: variable short name "//&
& TRIM(ADJUSTL(cd_sname))//" already in file")
- dim_get_id=jj
+ dim_get_index=ji
EXIT
ENDIF
ENDDO
+
ENDIF
ENDIF
- END FUNCTION dim_get_id
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function returns dimension id, in a table of dimension structure,
- !> given dimension name, or short name.
- !> only dimension used are checked.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : dimension structure
- !> @param[in] cd_name : dimension name or short name
- !> @param[in] cd_sname : dimension short name
+ END FUNCTION dim_get_index
+ !-------------------------------------------------------------------
+ !> @brief This function returns dimension id, in a array of dimension structure,
+ !> given dimension name, or short name.
+ !> @note only dimension used are checked.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim dimension structure
+ !> @param[in] cd_name dimension name or short name
+ !> @param[in] cd_sname dimension short name
!> @return dimension id
!-------------------------------------------------------------------
- !> @code
- INTEGER(i4) FUNCTION dim_get_void_id( td_dim, cd_name, cd_sname )
+ INTEGER(i4) FUNCTION dim_get_id( td_dim, cd_name, cd_sname )
IMPLICIT NONE
! Argument
TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim
- CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_name
+ CHARACTER(LEN=*), INTENT(IN) :: cd_name
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sname
@@ -318,7 +433,8 @@
! loop indices
INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
!----------------------------------------------------------------
! init
- dim_get_void_id=0
+ dim_get_id=0
il_ndim=SIZE(td_dim(:))
@@ -326,72 +442,75 @@
! look for dimension name
cl_name=fct_lower(cd_name)
- ! check if dimension is in table of dimension structure and used
+ ! check if dimension is in array of dimension structure and used
+ jj=0
DO ji=1,il_ndim
-
cl_dim_name=fct_lower(td_dim(ji)%c_name)
IF( TRIM(cl_dim_name) == TRIM(cl_name) .AND. &
- & .NOT. td_dim(ji)%l_use )THEN
- dim_get_void_id=ji
- EXIT
+ & td_dim(ji)%l_use )THEN
+ IF( td_dim(ji)%i_id /= 0 )THEN
+ dim_get_id=td_dim(ji)%i_id
+ EXIT
+ ENDIF
ENDIF
ENDDO
! look for dimension short name
- IF( dim_get_void_id == 0 )THEN
+ IF( dim_get_id == 0 )THEN
cl_sname=fct_lower(cd_name)
- ! check if dimension is in table of dimension structure and used
+ ! check if dimension is in array of dimension structure and used
+ jj=0
DO ji=1,il_ndim
-
cl_dim_sname=fct_lower(td_dim(ji)%c_sname)
IF( (TRIM(cl_dim_sname) == TRIM(cl_sname) ).AND.&
- & .NOT. td_dim(ji)%l_use )THEN
- dim_get_void_id=ji
- EXIT
+ & td_dim(ji)%l_use )THEN
+ IF( td_dim(ji)%i_id /= 0 )THEN
+ dim_get_id=td_dim(ji)%i_id
+ EXIT
+ ENDIF
ENDIF
ENDDO
+
ENDIF
! look for dimension short name
IF( PRESENT(cd_sname) )THEN
- IF( dim_get_void_id == 0 )THEN
+ IF( dim_get_id == 0 )THEN
cl_sname=fct_lower(cd_sname)
- ! check if dimension is in table of dimension structure and used
+ ! check if dimension is in array of dimension structure and used
+ jj=0
DO ji=1,il_ndim
-
cl_dim_sname=fct_lower(td_dim(ji)%c_sname)
IF( (TRIM(cl_dim_sname) == TRIM(cl_sname) ).AND.&
- & .NOT. td_dim(ji)%l_use )THEN
- dim_get_void_id=ji
- EXIT
+ & td_dim(ji)%l_use )THEN
+ IF( td_dim(ji)%i_id /= 0 )THEN
+ dim_get_id=td_dim(ji)%i_id
+ EXIT
+ ENDIF
ENDIF
ENDDO
+
ENDIF
ENDIF
- IF( dim_get_void_id == 0 )THEN
- DO ji=1,il_ndim
- IF( .NOT. td_dim(ji)%l_use ) dim_get_void_id=ji
- ENDDO
- ENDIF
-
- END FUNCTION dim_get_void_id
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This routine initialise a dimension structure with given
- !> arguments (name, length, etc).
+ END FUNCTION dim_get_id
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a dimension structure with given
+ !> name.
+ !> @details
+ !> Optionally length could be inform, as well as short name and if dimension
+ !> is unlimited or not.
!> define dimension is supposed to be used.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : dimension name
- !> @param[in] id_len : dimension length
- !> @param[in] ld_uld : dimension unlimited
- !> @param[in] cd_sname : dimension short name
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] cd_name dimension name
+ !> @param[in] id_len dimension length
+ !> @param[in] ld_uld dimension unlimited
+ !> @param[in] cd_sname dimension short name
!> @return dimension structure
!-------------------------------------------------------------------
- !> @code
TYPE(TDIM) FUNCTION dim_init( cd_name, id_len, ld_uld, cd_sname)
IMPLICIT NONE
@@ -413,10 +532,10 @@
cl_name=fct_upper(cd_name)
- CALL logger_info( &
+ CALL logger_debug( &
& " DIM INIT: dimension name: "//TRIM(cl_name) )
dim_init%c_name=TRIM(ADJUSTL(cd_name))
IF( PRESENT(id_len) )THEN
- CALL logger_info( &
+ CALL logger_debug( &
& " DIM INIT: dimension length: "//fct_str(id_len) )
dim_init%i_len=id_len
@@ -434,5 +553,5 @@
& TRIM(cl_sname) == 'z' .OR. &
& TRIM(cl_sname) == 't' )THEN
- CALL logger_info( &
+ CALL logger_debug( &
& " DIM INIT: dimension short name: "//TRIM(cd_sname) )
dim_init%c_sname=TRIM(cd_sname)
@@ -452,8 +571,8 @@
dim_init%c_sname='y'
ELSEIF( TRIM(cl_name)== 'z' .OR. &
- & INDEX(cl_name,'depth')/=0 )THEN
+ & INDEX(cl_name,'depth')/=0 )THEN
dim_init%c_sname='z'
ELSEIF( TRIM(cl_name)== 't' .OR. &
- & INDEX(cl_name,'time')/=0 )THEN
+ & INDEX(cl_name,'time')/=0 )THEN
dim_init%c_sname='t'
ENDIF
@@ -462,5 +581,5 @@
IF( PRESENT(ld_uld) )THEN
- CALL logger_info( &
+ CALL logger_debug( &
& " DIM INIT: unlimited dimension: "//fct_str(ld_uld) )
dim_init%l_uld=ld_uld
@@ -471,16 +590,17 @@
ENDIF
+ ! get dimension orderer index
+ dim_init%i_2xyzt=SCAN(TRIM(cp_dimorder),TRIM(dim_init%c_sname))
+
END FUNCTION dim_init
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subrtoutine print dimension information
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE dim__print_tab(td_dim)
+ !-------------------------------------------------------------------
+ !> @brief This subroutine print informations of an array of dimension.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension structure
+ !-------------------------------------------------------------------
+ SUBROUTINE dim__print_arr(td_dim)
IMPLICIT NONE
@@ -496,15 +616,13 @@
ENDDO
- END SUBROUTINE dim__print_tab
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subrtoutine print dimension information
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : dimension structure
- !-------------------------------------------------------------------
- !> @code
+ END SUBROUTINE dim__print_arr
+ !-------------------------------------------------------------------
+ !> @brief This subrtoutine print dimension information.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
SUBROUTINE dim__print_unit(td_dim)
IMPLICIT NONE
@@ -512,5 +630,4 @@
! Argument
TYPE(TDIM), INTENT(IN) :: td_dim
-
!----------------------------------------------------------------
@@ -526,100 +643,124 @@
END SUBROUTINE dim__print_unit
- !> @endcode
+ !-------------------------------------------------------------------
+ !> @brief This function fill unused dimension of an array of dimension
+ !> and return a 4 elts array of dimension structure.
+ !> @details
+ !> output dimensions 'x','y','z' and 't' are all informed.
+ !>
+ !> @note without input array of dimension, return
+ !> a 4 elts array of dimension structure all unused
+ !> (case variable 0d)
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !>
+ !> @param[in] td_dim array of dimension structure
+ !> @return 4elts array of dimension structure
+ !-------------------------------------------------------------------
+ FUNCTION dim_fill_unused(td_dim)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TDIM), DIMENSION(:), INTENT(IN), OPTIONAL :: td_dim
+
+ ! function
+ TYPE(TDIM), DIMENSION(ip_maxdim) :: dim_fill_unused
+
+ ! local variable
+ CHARACTER(LEN=lc) :: cl_dimin
+ INTEGER(i4) , DIMENSION(1) :: il_ind ! index
+
+ TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ IF( PRESENT(td_dim) )THEN
+ tl_dim(1:SIZE(td_dim(:)))=td_dim(:)
+ ENDIF
+ ! concatenate short nem dimension in a character string
+ cl_dimin=fct_lower(fct_concat(tl_dim(:)%c_sname))
+ DO ji = 1, ip_maxdim
+
+ ! search missing dimension
+ IF( INDEX(cl_dimin,TRIM(fct_lower(cp_dimorder(ji:ji)))) == 0 )THEN
+ ! search first empty dimension
+ il_ind(:)=MINLOC( tl_dim(:)%i_2xyzt, tl_dim(:)%i_2xyzt == 0 )
+
+ ! put missing dimension instead of empty one
+ tl_dim(il_ind(1))%c_sname=fct_lower(cp_dimorder(ji:ji))
+ ! update output structure
+ tl_dim(il_ind(1))%c_name=fct_lower(cp_dimorder(ji:ji))
+ tl_dim(il_ind(1))%i_2xyzt=ji
+ tl_dim(il_ind(1))%i_len=1
+ tl_dim(il_ind(1))%l_use=.FALSE.
+ ENDIF
+
+ ENDDO
+
+ ! save result
+ dim_fill_unused(:)=tl_dim(:)
+
+ ! clean
+ CALL dim_clean(tl_dim(:))
+
+ END FUNCTION dim_fill_unused
!-------------------------------------------------------------------
!> @brief
- !> This subroutine check if dimension are ordered or not
- !
- !> @author J.Paul
- !> - 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension structure
- !> @return dimension are ordered or not
- !-------------------------------------------------------------------
- !> @code
- FUNCTION dim_order(td_dim)
+ !> This subroutine switch element of an array (4 elts) of dimension
+ !> structure
+ !> from unordered dimension to ordered dimension
+ !>
+ !> @details
+ !> Optionally you could specify dimension order to output
+ !> (default 'xyzt')
+ !> Example: (/'z','x','t','y'/) => (/'x','y','z','t'/)
+ !>
+ !> @warning this subroutine change dimension order
+ !
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !> @date September, 2014 - allow to choose ordered dimension to be output
+ !>
+ !> @param[inout] td_dim array of dimension structure
+ !> @param[in] cd_dimorder dimension order to be output
+ !-------------------------------------------------------------------
+ SUBROUTINE dim_reorder(td_dim, cd_dimorder)
IMPLICIT NONE
! Argument
- TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim
-
- ! function
- LOGICAL :: dim_order
+ TYPE(TDIM) , DIMENSION(:), INTENT(INOUT) :: td_dim
+ CHARACTER(LEN=ip_maxdim) , INTENT(IN ), OPTIONAL :: cd_dimorder
! local variable
- CHARACTER(LEN=lc) :: cl_dimin
-
- ! loop indices
- !----------------------------------------------------------------
- ! init
- dim_order=.FALSE.
+ INTEGER(i4) :: il_ind
+
+ CHARACTER(LEN=lc) :: cl_dimin
+ CHARACTER(LEN=lc) :: cl_dimorder
+
+ TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
IF( SIZE(td_dim(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension.")
+ CALL logger_error("DIM REORDER: invalid dimension of array dimension.")
ELSE
- cl_dimin=fct_concat(td_dim(:)%c_sname)
-
- IF( TRIM(cp_dimorder) == TRIM(cl_dimin) )THEN
- dim_order=.TRUE.
- ENDIF
-
- ENDIF
- END FUNCTION dim_order
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine switch element of a table (4 elts) of dimension
- !> structure
- !> from unordered dimension to ordered dimension ('x','y','z','t')
- !> Example: (/'z','x','t','y'/) => (/'x','y','z','t'/)
- !> @warning this subroutine change dimension order
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_dim : table of dimension structure
- !> @return dimension structure completed and reordered
- !>
- !> @todo
- !> -check input dimension order and stop if already ordered
- !> -
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE dim_reorder(td_dim)
- IMPLICIT NONE
- ! Argument
- TYPE(TDIM), DIMENSION(:), INTENT(INOUT) :: td_dim
-
- ! local variable
- INTEGER(i4) :: il_id
- CHARACTER(LEN=lc) :: cl_dimin
- TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
-
- ! loop indices
- INTEGER(i4) :: ji
- INTEGER(i4) :: jj
- !----------------------------------------------------------------
-
- IF( SIZE(td_dim(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension.")
- ELSE
-
- ! copy and rename dimension in local variable
- tl_dim(:)=td_dim(:)
- jj=0
+ cl_dimorder=TRIM(cp_dimorder)
+ IF( PRESENT(cd_dimorder) ) cl_dimorder=TRIM(ADJUSTL(cd_dimorder))
+
+ ! add id if dimension used and no id
DO ji=1, ip_maxdim
- CALL logger_debug( "DIM REORDER : jj "//TRIM(fct_str(jj))//&
- & " "//TRIM(fct_str(td_dim(ji)%l_use)))
IF( td_dim(ji)%l_use )THEN
- jj=jj+1
- !IF( td_dim(ji)%l_use .AND. td_dim(ji)%i_id == 0 )THEN
- ! add id if dimension used and no id
- CALL logger_debug( "DIM REORDER : add id "//TRIM(fct_str(jj))//&
- & " to dimension "//TRIM(td_dim(ji)%c_name) )
- tl_dim(ji)%i_id=jj
+ IF( td_dim(ji)%i_id == 0 )THEN
+ td_dim(ji)%i_id=MAXVAL(td_dim(:)%i_id)+1
+ ENDIF
ELSE
td_dim(ji)%i_id=0
td_dim(ji)%i_xyzt2=0
+ td_dim(ji)%i_2xyzt=0
td_dim(ji)%c_sname='u'
td_dim(ji)%c_name=''
@@ -629,20 +770,14 @@
ENDDO
- print *,">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
- CALL dim_print(tl_dim(:))
-
-
! fill unused dimension
- CALL dim__fill_unused(tl_dim(:))
+ tl_dim(:)=dim_fill_unused(td_dim(:))
cl_dimin=fct_lower(fct_concat(tl_dim(:)%c_sname))
- print *,">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
- CALL dim_print(tl_dim(:))
! compute input id from output id (xyzt)
DO ji = 1, ip_maxdim
- il_id=SCAN(TRIM(cp_dimorder),TRIM(cl_dimin(ji:ji)))
- IF( il_id /= 0 )THEN
- tl_dim(ji)%i_xyzt2=il_id
+ il_ind=SCAN(TRIM(cl_dimorder),TRIM(cl_dimin(ji:ji)))
+ IF( il_ind /= 0 )THEN
+ tl_dim(ji)%i_xyzt2=il_ind
ENDIF
@@ -652,7 +787,7 @@
DO ji = 1, ip_maxdim
- il_id=SCAN(TRIM(cl_dimin),TRIM(cp_dimorder(ji:ji)))
- IF( il_id /= 0 )THEN
- tl_dim(ji)%i_2xyzt=il_id
+ il_ind=SCAN(TRIM(cl_dimin),TRIM(cl_dimorder(ji:ji)))
+ IF( il_ind /= 0 )THEN
+ tl_dim(ji)%i_2xyzt=il_ind
ENDIF
@@ -669,24 +804,22 @@
td_dim(:)%i_xyzt2 = tl_dim(:)%i_xyzt2
+ ! clean
+ CALL dim_clean(tl_dim(:))
ENDIF
END SUBROUTINE dim_reorder
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine switch dimension table from ordered dimension ('x','y','z','t')
- !> to unordered dimension.
+ !-------------------------------------------------------------------
+ !> @brief This subroutine switch dimension array from ordered dimension ('x','y','z','t')
+ !> to unordered dimension.
+ !> @details
!> Example: (/'x','y','z','t'/) => (/'z','x','t','y'/)
- !> This is useful to add dimension in a variable or file
- !
+ ! This is useful to add dimension in a variable or file.
!> @warning this subroutine change dimension order
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_dim : table of dimension structure
- !> @return dimension structure unordered
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[inout] td_dim array of dimension structure
+ !-------------------------------------------------------------------
SUBROUTINE dim_unorder(td_dim)
IMPLICIT NONE
@@ -702,7 +835,7 @@
IF( SIZE(td_dim(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension.")
+ CALL logger_error("DIM UNORDER: invalid dimension of array dimension.")
ELSE
- ! add dummy xyzt2 id to removed dimension
+ ! add dummy xyzt2 id to unused dimension
jj=1
DO ji = 1, ip_maxdim
@@ -729,6 +862,4 @@
td_dim(ji)%i_xyzt2=0
td_dim(ji)%c_sname='u'
- !td_dim(ji)%c_name='unknown'
- !td_dim(ji)%c_sname=''
td_dim(ji)%c_name=''
td_dim(ji)%l_uld=.FALSE.
@@ -738,79 +869,21 @@
END SUBROUTINE dim_unorder
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine filled dimension structure with unused
- !> dimension in order that all dimensions 'x','y','z' and 't' be
- !> informed, even if void
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_dim : table of dimension structure
- !> @return td_dim with unused dimension
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE dim__fill_unused(td_dim)
- IMPLICIT NONE
- ! Argument
- TYPE(TDIM), DIMENSION(:), INTENT(INOUT) :: td_dim
-
- ! local variable
- CHARACTER(LEN=lc) :: cl_dimin
- INTEGER(i4) , DIMENSION(1) :: il_ind ! index
-
- ! loop indices
- INTEGER(i4) :: ji
- !----------------------------------------------------------------
-
- IF( SIZE(td_dim(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension.")
- ELSE
- ! concatenate dimension used in a character string
- cl_dimin=fct_lower(fct_concat(td_dim(:)%c_sname))
- DO ji = 1, ip_maxdim
-
- ! search missing dimension
- IF( INDEX(cl_dimin,TRIM(fct_lower(cp_dimorder(ji:ji)))) == 0 )THEN
- ! search first empty dimension
- il_ind(:)=MINLOC( td_dim(:)%i_id, td_dim(:)%i_id == 0 )
-
- ! put missing dimension instead of empty one
- td_dim(il_ind(1))%c_sname=fct_lower(cp_dimorder(ji:ji))
- ! update output structure
- td_dim(il_ind(1))%c_name=fct_lower(cp_dimorder(ji:ji))
- td_dim(il_ind(1))%i_id=il_ind(1)
- td_dim(il_ind(1))%i_len=1
- td_dim(il_ind(1))%l_use=.FALSE.
-
- ENDIF
-
- ENDDO
-
- ! remove id of unused dimension
- DO ji = 1, ip_maxdim
- IF( .NOT. td_dim(ji)%l_use ) td_dim(ji)%i_id=0
- ENDDO
- ENDIF
-
- END SUBROUTINE dim__fill_unused
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine reshape real(8) 4D table
- !> to an ordered table with dimension (/'x','y','z','t'/).
+ !-------------------------------------------------------------------
+ !> @brief This function reshape real(8) 4D array
+ !> to an ordered array, as defined by dim_reorder.
+ !> @details
!> Example: (/'z','x','t','y'/) => (/'x','y','z','t'/)
!
!> @note you must have run dim_reorder before use this subroutine
!
- !> @warning output table dimension differ from input table dimension
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] dd_value : table of value to reshape
- !> @return table of value reshaped
- !-------------------------------------------------------------------
- !> @code
+ !> @warning output array dimension differ from input array dimension
+ !
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] dd_value array of value to reshape
+ !> @return array of value reshaped
+ !-------------------------------------------------------------------
FUNCTION dim__reshape_2xyzt_dp(td_dim, dd_value)
IMPLICIT NONE
@@ -835,5 +908,5 @@
IF( SIZE(td_dim(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension.")
+ CALL logger_error("DIM RESHAPE 2 XYZT: invalid dimension of array dimension.")
ELSE
@@ -841,5 +914,5 @@
CALL logger_fatal( &
- & " RESHAPE to XYZT: you should have run dim_reorder &
+ & " DIM RESHAPE 2 XYZT: you should have run dim_reorder &
& before running RESHAPE" )
@@ -854,10 +927,10 @@
DO ji=1,ip_maxdim
- CALL logger_debug(" RESHAPE to XYZT: dim "//&
+ CALL logger_debug(" DIM RESHAPE 2 XYZT: dim "//&
& TRIM(td_dim(td_dim(ji)%i_xyzt2)%c_name)//" "//&
& TRIM(fct_str(td_dim(td_dim(ji)%i_xyzt2)%i_len))//" vs "//&
& TRIM(fct_str(il_shape(ji))) )
ENDDO
- CALL logger_fatal(" RESHAPE to XYZT: wrong input dimensions " )
+ CALL logger_fatal(" DIM RESHAPE 2 XYZT: wrong input dimensions " )
ELSE
@@ -870,5 +943,5 @@
cl_dim=TRIM(cl_dim)//TRIM(fct_str(il_shape(ip_maxdim)))//"/)"
- CALL logger_info(" RESHAPE to XYZT: input dimensions are "//&
+ CALL logger_debug(" DIM RESHAPE 2 XYZT: input dimensions are "//&
& TRIM(cl_dim) )
@@ -879,5 +952,5 @@
cl_dim=TRIM(cl_dim)//TRIM(fct_str(td_dim(ip_maxdim)%i_len))//"/)"
- CALL logger_info(" RESHAPE to XYZT: ouput dimensions should be "//&
+ CALL logger_debug(" DIM RESHAPE 2 XYZT: ouput dimensions should be "//&
& TRIM(cl_dim) )
@@ -897,22 +970,21 @@
END FUNCTION dim__reshape_2xyzt_dp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine reshape ordered real(8) 4D table with dimension
- !> (/'x','y','z','t'/) to a table ordered as file variable.
+ !-------------------------------------------------------------------
+ !> @brief This function reshape ordered real(8) 4D array with dimension
+ !> (/'x','y','z','t'/) to an "unordered" array.
+ !> @details
!> Example: (/'x','y','z','t'/) => (/'z','x','t','y'/)
!
!> @note you must have run dim_reorder before use this subroutine
!
- !> @warning output table dimension differ from input table dimension
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] dd_value : table of value to reshape
- !> @return table of value reshaped
- !-------------------------------------------------------------------
- !> @code
+ !> @warning output array dimension differ from input array dimension
+ !
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] dd_value array of value to reshape
+ !> @return array of value reshaped
+ !-------------------------------------------------------------------
FUNCTION dim__reshape_xyzt2_dp(td_dim, dd_value)
IMPLICIT NONE
@@ -937,5 +1009,5 @@
IF( SIZE(td_dim(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension.")
+ CALL logger_error("DIM RESHAPE XYZT 2: invalid dimension of array dimension.")
ELSE
@@ -943,5 +1015,5 @@
CALL logger_fatal( &
- & " RESHAPE from XYZT: you should have run dim_reorder &
+ & " DIM RESHAPE XYZT 2: you should have run dim_reorder &
& before running RESHAPE" )
@@ -953,10 +1025,10 @@
DO ji=1,ip_maxdim
- CALL logger_debug(" RESHAPE from XYZT: dim "//&
+ CALL logger_trace(" DIM RESHAPE XYZT 2: dim "//&
& TRIM(td_dim(ji)%c_name)//" "//&
& TRIM(fct_str(td_dim(ji)%i_len))//" vs "//&
& TRIM(fct_str(il_shape(ji))) )
ENDDO
- CALL logger_fatal( "RESHAPE from XYZT: wrong input dimensions ")
+ CALL logger_fatal( "DIM RESHAPE XYZT 2: wrong input dimensions ")
ELSE
@@ -969,5 +1041,5 @@
cl_dim=TRIM(cl_dim)//TRIM(fct_str(il_shape(ip_maxdim)))//"/)"
- CALL logger_info(" RESHAPE from XYZT: input dimensions are "//&
+ CALL logger_debug(" DIM RESHAPE XYZT 2: input dimensions are "//&
& TRIM(cl_dim) )
@@ -980,8 +1052,8 @@
& TRIM(fct_str(td_dim(td_dim(ip_maxdim)%i_xyzt2)%i_len))//"/)"
- CALL logger_info(" RESHAPE from XYZT: ouput dimensions should be "//&
+ CALL logger_debug(" DIM RESHAPE XYZT 2: ouput dimensions should be "//&
& TRIM(cl_dim) )
- ! reshape table
+ ! reshape array
dim__reshape_xyzt2_dp(:,:,:,:)=RESHAPE(SOURCE=dd_value, &
& SHAPE = (/ td_dim(td_dim(1)%i_xyzt2)%i_len, &
@@ -994,29 +1066,26 @@
& td_dim(4)%i_xyzt2 /))
-
ENDIF
ENDIF
END FUNCTION dim__reshape_xyzt2_dp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine reordered integer(4) 1D table to be suitable
- !> with dimension ordered as (/'x','y','z','t'/)
+ !-------------------------------------------------------------------
+ !> @brief This function reordered integer(4) 1D array to be suitable
+ !> with dimension ordered as defined in dim_reorder.
!> @note you must have run dim_reorder before use this subroutine
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] id_tab : table of value to reshape
- !> @return table of value reshaped
- !-------------------------------------------------------------------
- !> @code
- FUNCTION dim__reorder_2xyzt_i4(td_dim, id_tab)
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] id_arr array of value to reshape
+ !> @return array of value reshaped
+ !-------------------------------------------------------------------
+ FUNCTION dim__reorder_2xyzt_i4(td_dim, id_arr)
IMPLICIT NONE
! Argument
TYPE(TDIM) , DIMENSION(:), INTENT(IN) :: td_dim
- INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_tab
+ INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_arr
! function
@@ -1028,12 +1097,12 @@
IF( SIZE(td_dim(:)) /= ip_maxdim .OR. &
- & SIZE(id_tab(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension"//&
- & " or of table of value.")
+ & SIZE(id_arr(:)) /= ip_maxdim )THEN
+ CALL logger_error("DIM REORDER 2 XYZT: invalid dimension of array dimension"//&
+ & " or of array of value.")
ELSE
IF( ANY(td_dim(:)%i_2xyzt==0) )THEN
CALL logger_error( &
- & " REORDER to XYZT: you should have run dim_reorder &
+ & " DIM REORDER 2 XYZT: you should have run dim_reorder &
& before running REORDER" )
@@ -1041,29 +1110,27 @@
DO ji=1,ip_maxdim
- dim__reorder_2xyzt_i4(ji)=id_tab(td_dim(ji)%i_2xyzt)
+ dim__reorder_2xyzt_i4(ji)=id_arr(td_dim(ji)%i_2xyzt)
ENDDO
ENDIF
END FUNCTION dim__reorder_2xyzt_i4
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine reordered integer(4) 1D table to be suitable with
- !> dimension read in the file.
+ !-------------------------------------------------------------------
+ !> @brief This function unordered integer(4) 1D array to be suitable with
+ !> initial dimension order (ex: dimension read in file).
!> @note you must have run dim_reorder before use this subroutine
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] id_tab : table of value to reshape
- !> @return table of value reshaped
- !-------------------------------------------------------------------
- !> @code
- FUNCTION dim__reorder_xyzt2_i4(td_dim, id_tab)
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] id_arr array of value to reshape
+ !> @return array of value reshaped
+ !-------------------------------------------------------------------
+ FUNCTION dim__reorder_xyzt2_i4(td_dim, id_arr)
IMPLICIT NONE
! Argument
TYPE(TDIM) , DIMENSION(:), INTENT(IN) :: td_dim
- INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_tab
+ INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_arr
! function
@@ -1075,12 +1142,12 @@
IF( SIZE(td_dim(:)) /= ip_maxdim .OR. &
- & SIZE(id_tab(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension"//&
- & " or of table of value.")
+ & SIZE(id_arr(:)) /= ip_maxdim )THEN
+ CALL logger_error("DIM REORDER XYZT 2: invalid dimension of array dimension"//&
+ & " or of array of value.")
ELSE
IF( ANY(td_dim(:)%i_xyzt2==0) )THEN
CALL logger_error( &
- & " REORDER from XYZT: you should have run dim_reorder &
+ & " DIM REORDER XYZT 2: you should have run dim_reorder &
& before running REORDER" )
@@ -1088,28 +1155,26 @@
DO ji=1,ip_maxdim
- dim__reorder_xyzt2_i4(ji)=id_tab(td_dim(ji)%i_xyzt2)
+ dim__reorder_xyzt2_i4(ji)=id_arr(td_dim(ji)%i_xyzt2)
ENDDO
ENDIF
END FUNCTION dim__reorder_xyzt2_i4
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine reordered logical 1D table to be suitable
- !> with dimension ordered as (/'x','y','z','t'/)
+ !-------------------------------------------------------------------
+ !> @brief This function reordered logical 1D array to be suitable
+ !> with dimension ordered as defined in dim_reorder.
!> @note you must have run dim_reorder before use this subroutine
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] ld_tab : table of value to reordered
- !> @return table of value reordered
- !-------------------------------------------------------------------
- !> @code
- FUNCTION dim__reorder_2xyzt_l(td_dim, ld_tab)
+ !> @date Nov, 2013 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] ld_arr array of value to reordered
+ !> @return array of value reordered
+ !-------------------------------------------------------------------
+ FUNCTION dim__reorder_2xyzt_l(td_dim, ld_arr)
IMPLICIT NONE
! Argument
TYPE(TDIM) , DIMENSION(:), INTENT(IN) :: td_dim
- LOGICAL , DIMENSION(:), INTENT(IN) :: ld_tab
+ LOGICAL , DIMENSION(:), INTENT(IN) :: ld_arr
! function
@@ -1121,12 +1186,12 @@
IF( SIZE(td_dim(:)) /= ip_maxdim .OR. &
- & SIZE(ld_tab(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension"//&
- & " or of table of value.")
+ & SIZE(ld_arr(:)) /= ip_maxdim )THEN
+ CALL logger_error("DIM REORDER 2 XYZT: invalid dimension of array dimension"//&
+ & " or of array of value.")
ELSE
IF( ANY(td_dim(:)%i_2xyzt==0) )THEN
CALL logger_error( &
- & " REORDER to XYZT: you should have run dim_reorder &
+ & " DIM REORDER 2 XYZT: you should have run dim_reorder &
& before running REORDER" )
@@ -1134,29 +1199,27 @@
DO ji=1,ip_maxdim
- dim__reorder_2xyzt_l(ji)=ld_tab(td_dim(ji)%i_2xyzt)
+ dim__reorder_2xyzt_l(ji)=ld_arr(td_dim(ji)%i_2xyzt)
ENDDO
ENDIF
END FUNCTION dim__reorder_2xyzt_l
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine reordered logical 1D table to be suitable with
- !> dimension read in the file.
+ !-------------------------------------------------------------------
+ !> @brief This function unordered logical 1D array to be suitable with
+ !> initial dimension order (ex: dimension read in file).
!> @note you must have run dim_reorder before use this subroutine
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] ld_tab : table of value to reordered
- !> @return table of value reordered
- !-------------------------------------------------------------------
- !> @code
- FUNCTION dim__reorder_xyzt2_l(td_dim, ld_tab)
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] ld_arr array of value to reordered
+ !> @return array of value reordered
+ !-------------------------------------------------------------------
+ FUNCTION dim__reorder_xyzt2_l(td_dim, ld_arr)
IMPLICIT NONE
! Argument
TYPE(TDIM) , DIMENSION(:), INTENT(IN) :: td_dim
- LOGICAL , DIMENSION(:), INTENT(IN) :: ld_tab
+ LOGICAL , DIMENSION(:), INTENT(IN) :: ld_arr
! function
@@ -1168,12 +1231,12 @@
IF( SIZE(td_dim(:)) /= ip_maxdim .OR. &
- & SIZE(ld_tab(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension"//&
- & " or of table of value.")
+ & SIZE(ld_arr(:)) /= ip_maxdim )THEN
+ CALL logger_error("DIM REORDER XYZT 2: invalid dimension of array dimension"//&
+ & " or of array of value.")
ELSE
IF( ANY(td_dim(:)%i_xyzt2==0) )THEN
CALL logger_error( &
- & " REORDER from XYZT: you should have run dim_reorder &
+ & " DIM REORDER XYZT 2: you should have run dim_reorder &
& before running REORDER" )
@@ -1181,28 +1244,26 @@
DO ji=1,ip_maxdim
- dim__reorder_xyzt2_l(ji)=ld_tab(td_dim(ji)%i_xyzt2)
+ dim__reorder_xyzt2_l(ji)=ld_arr(td_dim(ji)%i_xyzt2)
ENDDO
ENDIF
END FUNCTION dim__reorder_xyzt2_l
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine reordered string 1D table to be suitable
- !> with dimension ordered as (/'x','y','z','t'/)
+ !-------------------------------------------------------------------
+ !> @brief This function reordered string 1D array to be suitable
+ !> with dimension ordered as defined in dim_reorder.
!> @note you must have run dim_reorder before use this subroutine
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] cd_tab : table of value to reordered
- !> @return table of value reordered
- !-------------------------------------------------------------------
- !> @code
- FUNCTION dim__reorder_2xyzt_c(td_dim, cd_tab)
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] cd_arr array of value to reordered
+ !> @return array of value reordered
+ !-------------------------------------------------------------------
+ FUNCTION dim__reorder_2xyzt_c(td_dim, cd_arr)
IMPLICIT NONE
! Argument
TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim
- CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_tab
+ CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_arr
! function
@@ -1214,12 +1275,12 @@
IF( SIZE(td_dim(:)) /= ip_maxdim .OR. &
- & SIZE(cd_tab(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension"//&
- & " or of table of value.")
+ & SIZE(cd_arr(:)) /= ip_maxdim )THEN
+ CALL logger_error("DIM REORDER 2 XYZT: invalid dimension of array dimension"//&
+ & " or of array of value.")
ELSE
IF( ANY(td_dim(:)%i_2xyzt==0) )THEN
CALL logger_error( &
- & " REORDER to XYZT: you should have run dim_reorder"//&
+ & " DIM REORDER 2 XYZT: you should have run dim_reorder"//&
& " before running REORDER" )
@@ -1227,29 +1288,27 @@
DO ji=1,ip_maxdim
- dim__reorder_2xyzt_c(ji)=TRIM(cd_tab(td_dim(ji)%i_2xyzt))
+ dim__reorder_2xyzt_c(ji)=TRIM(cd_arr(td_dim(ji)%i_2xyzt))
ENDDO
ENDIF
END FUNCTION dim__reorder_2xyzt_c
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine reordered string 1D table to be suitable with
- !> dimension read in the file.
+ !-------------------------------------------------------------------
+ !> @brief This function unordered string 1D array to be suitable with
+ !> initial dimension order (ex: dimension read in file).
!> @note you must have run dim_reorder before use this subroutine
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] cd_tab : table of value to reordered
- !> @return table of value reordered
- !-------------------------------------------------------------------
- !> @code
- FUNCTION dim__reorder_xyzt2_c(td_dim, cd_tab)
+ !> @date Nov, 2013 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] cd_arr array of value to reordered
+ !> @return array of value reordered
+ !-------------------------------------------------------------------
+ FUNCTION dim__reorder_xyzt2_c(td_dim, cd_arr)
IMPLICIT NONE
! Argument
TYPE(TDIM), DIMENSION(:), INTENT(IN) :: td_dim
- CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_tab
+ CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_arr
! function
@@ -1261,11 +1320,11 @@
IF( SIZE(td_dim(:)) /= ip_maxdim .OR. &
- & SIZE(cd_tab(:)) /= ip_maxdim )THEN
- CALL logger_error("DIM ORDER: invalid dimension of table dimension"//&
- & " or of table of value.")
+ & SIZE(cd_arr(:)) /= ip_maxdim )THEN
+ CALL logger_error("DIM REORDER XYZT 2: invalid dimension of array dimension"//&
+ & " or of array of value.")
ELSE
IF( ANY(td_dim(:)%i_xyzt2==0) )THEN
CALL logger_error( &
- & " REORDER from XYZT: you should have run dim_reorder &
+ & " DIM REORDER XYZT 2: you should have run dim_reorder &
& before running REORDER" )
@@ -1273,19 +1332,17 @@
DO ji=1,ip_maxdim
- dim__reorder_xyzt2_c(ji)=TRIM(cd_tab(td_dim(ji)%i_xyzt2))
+ dim__reorder_xyzt2_c(ji)=TRIM(cd_arr(td_dim(ji)%i_xyzt2))
ENDDO
ENDIF
END FUNCTION dim__reorder_xyzt2_c
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine clean dimension structure
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : dimension strucutre
- !-------------------------------------------------------------------
- !> @code
+ !-------------------------------------------------------------------
+ !> @brief This subroutine clean dimension structure.
+ !
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim dimension strucutre
+ !-------------------------------------------------------------------
SUBROUTINE dim__clean_unit( td_dim )
IMPLICIT NONE
@@ -1297,6 +1354,6 @@
!----------------------------------------------------------------
- CALL logger_info( &
- & " CLEAN: reset dimension "//TRIM(td_dim%c_name) )
+ CALL logger_trace( &
+ & " DIM CLEAN: reset dimension "//TRIM(td_dim%c_name) )
! replace by empty structure
@@ -1304,15 +1361,13 @@
END SUBROUTINE dim__clean_unit
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine clean table of dimension structure
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_dim : table of dimension strucutre
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE dim__clean_tab( td_dim )
+ !-------------------------------------------------------------------
+ !> @brief This subroutine clean array of dimension structure
+ !
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
+ !
+ !> @param[in] td_dim array of dimension strucutre
+ !-------------------------------------------------------------------
+ SUBROUTINE dim__clean_arr( td_dim )
IMPLICIT NONE
! Argument
@@ -1327,6 +1382,5 @@
ENDDO
- END SUBROUTINE dim__clean_tab
- !> @endcode
+ END SUBROUTINE dim__clean_arr
END MODULE dim
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/1_install.md
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/1_install.md (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/1_install.md (revision 5214)
@@ -0,0 +1,25 @@
+# How to Install
+
+# Install NEMO
+to install SIREN, you should first install NEMO.
+see [here](http://www.nemo-ocean.eu/Using-NEMO/User-Guides/Basics/NEMO-Quick-Start-Guide)
+
+# Compile SIREN
+when NEMO is installed, you just have to compile SIREN codes:
+1. go to ./NEMOGCM/TOOLS
+2. use maketools
+ to get help: maketools -h
+
+# Fortran Compiler
+ SIREN codes were succesfully tested with :
+ - ifort (version 12.0.4)
+ - gfortran (version 4.7.2 20121109)
+
+
+
+
+ - @ref index
+ - @ref md_docsrc_3_codingRules
+ - @ref md_docsrc_4_changeLog
+ - @ref todo
+
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/3_codingRules.md
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/3_codingRules.md (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/3_codingRules.md (revision 5214)
@@ -0,0 +1,98 @@
+# Coding Rules
+
+The conventions used in SIREN coding are based on the NEMO coding rules
+(see [NEMO coding
+conventions](http://www.nemo-ocean.eu/content/download/15483/73221/file/NEMO_coding.conv_v3.pdf)).
+However some modifications were added to improve readibility of the code.
+Some of the NEMO coding rules are reminded here, and extensions are described.
+
+@tableofcontents
+
+# Fortran Standard {#std}
+
+SIREN software adhere to strict __FORTRAN 95__ standard.
+There is only one exception. The use of functions _COMMAND_ARGUMENT_COUNT_ and
+_GET_COMMAND_ARGUMENT_.
+There exist no equivalent for those Fortran 03 intrinsec functions in Fortran
+95. At least none convenient for compilers tested (see @ref md_docsrc_1_install).
+
+# Free Form Source {#free}
+Free Form Source will be used, however a self imposed limit of 80 should
+enhance readibility.
+
+# Indentation {#indent}
+Code as well as comments lines will be indented 3 characters for readibility.
+__Indentation should be write without hard tabs__.
+
+Example for vi :
+~~~~~~~~~~~~~~~~~~~~~
+:set expandtab tabstop=3 shiftwidth=3
+~~~~~~~~~~~~~~~~~~~~~
+
+# Naming conventions : variable {#namvar}
+All variables should be named as explicitly as possible.
+The naming conventions concerns prefix letters of these name, in order to
+identify the variable type and status. It must be composed of two
+letters defining type and status follow by an underscore.
+table below list the starting letters to be used for variable naming,
+depending on their type and status.
+
+ | Type / Status | byte (integer(1)) __b__ | short (integer(2)) __s__ | integer(4) __i__ | integer(8) __k__ | real(4) __r__ | real(8) __d__ | logical __l__ | character __c__ | complex __y__ | structure __t__ |
+ | :----: | :----: | :----: | :----: | :----: | :----: | :----: | :----: | :----: | :----: | :----: |
+ |global __g__ | bg_ | sg_ | ig_ | kg_ | rg_ | dg_ | lg_ | cg_ | yg_ | tg_ |
+ |global parameter __p__ | bp_ | sp_ | ip_ | kp_ | rp_ | dp_ | lp_ | cp_ | yp_ | tp_ |
+ |module __m__ | bm_ | sm_ | im_ | km_ | rm_ | dm_ | lm_ | cm_ | ym_ | tm_ |
+ |namelist __n__ | bn_ | sn_ | in_ | kn_ | rn_ | dn_ | ln_ | cn_ | yn_ | tn_ |
+ |dummy argument __d__ | bd_ | sd_ | id_ | kd_ | rd_ | dd_ | ld_ | cd_ | yd_ | td_ |
+ |local __l__ | bl_ | sl_ | il_ | kl_ | rl_ | dl_ | ll_ | cl_ | yl_ | tl_ |
+ |loop control | | | j? | | | | | | | |
+
+# Naming conventions : structure {#namstr}
+The structure name should be written in capital letter, and start with
+__T__ Example: TTRACER
+Variables inside the structure should be named as explicitly as possible.
+For those variables, the prefix naming conventions only concern the type of variable.
+It must be composed of one letter defining type follows by an
+underscore.
+see table of variable conventions.
+
+Example: __tl\_type\%i\_year__ _year_ is an integer(4) variable in a local strucure
+named _type_.
+
+# Naming conventions : function-subroutine {#namsub}
+Functions or Subroutines are defined in a module.
+Their name should start with the module name then with their "functional" name. So it will be
+easy to find it.
+Example: a function to realise addition written in a module
+__math__ should be called __math\_add__.
+
+__PUBLIC__ function or subroutine should used one undescrore: _math_add_
+__PRIVATE__ function or subroutine should used two undescrores: _math__add_
+
+# Precision {#precision}
+__All variables should make use of kinds__.
+Numerical constant need to have a suffix of __kindvalue__
+
+# Declaration for global variable and constants {#global}
+All global data must be accompanied with a comment field on the same
+line.
+_Note that using doxygen (see [header](#header)), we will use symbol !< instead of !: as separator_
+
+# Implicit none {#implicit}
+All subroutines and functions will include an IMPLICTI NONE statement.
+
+# Header {#header}
+
+SIREN use __doxigen auto documentation__ tool.
+Information could be find on
+[doxygen](http://www.stack.nl/~dimitri/doxygen/index.html) web page.
+Some basic tag are described
+[here](http://www.msg.chem.iastate.edu/gamess/DoxygenRules.oct10.pdf).
+
+
+
+ - @ref index
+ - @ref md_docsrc_1_install
+ - @ref md_docsrc_4_changeLog
+ - @ref todo
+
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/4_changeLog.md
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/4_changeLog.md (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/4_changeLog.md (revision 5214)
@@ -0,0 +1,18 @@
+# Change log
+
+@tableofcontents
+
+# Release 3.6
+Initial release (release date )
+
+## Changes
+## New Features
+## Bug fixes
+
+
+
+ - @ref index
+ - @ref md_docsrc_1_install
+ - @ref md_docsrc_3_codingRules
+ - @ref todo
+
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/main.dox
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/main.dox (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/docsrc/main.dox (revision 5214)
@@ -0,0 +1,42 @@
+/*!
+ @mainpage Main Page
+ @section descr Generic Description
+ SIREN is a software to create regional configuration with
+ [NEMO](http://www.nemo-ocean.eu).
+ Actually SIREN create input files needed for a basic NEMO configuration.
+
+ SIREN is composed of a set of 5 Fortran programs :
+ - create_coord.f90 to create fine grid coordinate file from coarse grid coordinate file.
+ - create_bathy.f90 to create fine grid bathymetry file over domain.
+ - merge_bathy.f90 to merge fine grid bathymetry with coarse grid bathymetry at boundaries.
+ - create_restart.f90 to create initial state file from coarse grid restart or standard outputs.
+ - create_boundary.f90 to create boundary condition from coarse grid standard outputs.
+
+To install those programs see @ref md_docsrc_1_install.
+
+ @note SIREN can not:
+ - create global configuration
+ - create configuarion around or close to north pole
+ - change number of vertical level
+ - change grid (horizontal or vertical)
+
+ @section howto How to use
+ @subsection howto_coord to create fine grid coordinate file
+ see create_coord.f90
+ @subsection howto_bathy to create fine grid bathymetry
+ see create_bathy.f90
+ @subsection howto_merge to merge fine grid bathymetry
+ see merge_bathy.f90
+ @subsection howto_restart to create initial state file
+ see create_restart.f90
+ @subsection howto_boundary to create boundary condition
+ see create_boundary.f90
+
+
+
+ - @ref md_docsrc_1_install
+ - @ref md_docsrc_3_codingRules
+ - @ref md_docsrc_4_changeLog
+ - @ref todo
+
+*/
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/domain.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/domain.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/domain.f90 (revision 5214)
@@ -8,17 +8,122 @@
!> @brief
!> This module manage domain computation.
-!
+!>
!> @details
-!>
-!>
-!>
-!>
+!> define type TDOM:
+!> @code
+!> TYPE(TDOM) :: tl_dom
+!> @endcode
+!>
+!> to initialize domain structure:
+!> @code
+!> tl_dom=dom_init(td_mpp, [id_imin,] [id_imax,] [id_jmin,] [id_jmax],[cd_card])
+!> @endcode
+!> - td_mpp is mpp structure of an opened file.
+!> - id_imin is i-direction sub-domain lower left point indice
+!> - id_imax is i-direction sub-domain upper right point indice
+!> - id_jmin is j-direction sub-domain lower left point indice
+!> - id_jmax is j-direction sub-domain upper right point indice
+!> - cd_card is the cardinal name (for boundary case)
+!>
+!> to get global domain dimension:
+!> - tl_dom\%t_dim0
+!>
+!> to get NEMO periodicity index of global domain:
+!> - tl_dom\%i_perio0
+!>
+!> to get NEMO pivot point index F(0),T(1):
+!> - tl_dom\%i_pivot
+!>
+!> to get East-West overlap of global domain:
+!> - tl_dom\%i_ew0
+!>
+!> to get selected sub domain dimension:
+!> - tl_dom\%t_dim
+!>
+!> to get NEMO periodicity index of sub domain:
+!> - tl_dom\%i_perio
+!>
+!> to get East-West overlap of sub domain:
+!> - tl_dom\%i_ew
+!>
+!> to get i-direction sub-domain lower left point indice:
+!> - tl_dom\%i_imin
+!>
+!> to get i-direction sub-domain upper right point indice:
+!> - tl_dom\%i_imax
+!>
+!> to get j-direction sub-domain lower left point indice:
+!> - tl_dom\%i_jmin
+!>
+!> to get j-direction sub-domain upper right point indice:
+!> - tl_dom\%i_jmax
+!>
+!> to get size of i-direction extra band:
+!> - tl_dom\%i_iextra
+!>
+!> to get size of j-direction extra band:
+!> - tl_dom\%i_jextra
+!>
+!> to get i-direction ghost cell number:
+!> - tl_dom\%i_ighost
+!>
+!> to get j-direction ghost cell number:
+!> - tl_dom\%i_jghost
+!>
+!> to get boundary index:
+!> - tl_dom\%i_bdy
+!> - 0 = no boundary
+!> - 1 = north
+!> - 2 = south
+!> - 3 = east
+!> - 4 = west
+!>
+!> to clean domain structure:
+!> @code
+!> CALL dom_clean(td_dom)
+!> @endcode
+!> - td_dom is domain structure
+!>
+!> to print information about domain structure:
+!> @code
+!> CALL dom_print(td_dom)
+!> @endcode
+!>
+!> to get East-West overlap (if any):
+!> @code
+!> il_ew=dom_get_ew_overlap(td_lon)
+!> @endcode
+!> - td_lon : longitude variable structure
+!>
+!> to add extra bands to coarse grid domain (for interpolation):
+!> @code
+!> CALL dom_add_extra( td_dom, id_iext, id_jext )
+!> @endcode
+!> - td_dom is domain structure
+!> - id_iext is i-direction size of extra bands
+!> - id_jext is j-direction size of extra bands
+!>
+!> to remove extra bands from fine grid (after interpolation):
+!> @code
+!> CALL dom_del_extra( td_var, td_dom, id_rho )
+!> @endcode
+!> - td_var is variable structure to be changed
+!> - td_dom is domain structure
+!> - id_rho is a array of refinement factor following i- and j-direction
+!>
+!> to reset coarse grid domain witouht extra bands:
+!> @code
+!> CALL dom_clean_extra( td_dom )
+!> @endcode
!>
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!> @todo
-!> - check use of id_pivot
+!> @date November, 2013 - Initial Version
+!> @date September, 2014
+!> - add header
+!> - use zero indice to defined cyclic or global domain
+!> @date October, 2014
+!> - use mpp file structure instead of file
!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
@@ -28,10 +133,9 @@
USE global ! global parameter
USE fct ! basic useful function
- USE logger ! log file manager
+ USE logger ! log file manager
USE dim ! dimension manager
USE var ! variable manager
- USE file ! file manager
+ USE mpp ! mpp file manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
@@ -39,51 +143,57 @@
PUBLIC :: TDOM !< domain structure
+ PRIVATE :: im_minext !< default minumum number of extraband
+
! function and subroutine
- PUBLIc :: dom_clean !< clean domain structure
- PUBLIC :: dom_init !< initialise domain structure
- PUBLIC :: dom_print !< print information about domain
- PUBLIC :: dom_get_ew_overlap !< get east west overlap
- PUBLIC :: dom_add_extra !< add useful extra point to coarse grid for interpolation
- PUBLIC :: dom_clean_extra !< reset domain without extra point
- PUBLIC :: dom_del_extra !< remove extra point from fine grid after interpolation
+ PUBLIC :: dom_copy !< copy domain structure
+ PUBLIc :: dom_clean !< clean domain structure
+ PUBLIC :: dom_init !< initialise domain structure
+ PUBLIC :: dom_print !< print information about domain
+ PUBLIC :: dom_add_extra !< add useful extra bands to coarse grid for interpolation
+ PUBLIC :: dom_clean_extra !< reset domain without extra bands
+ PUBLIC :: dom_del_extra !< remove extra point from fine grid after interpolation
- PRIVATE :: dom__define !< define extract domain indices
- !< define extract domain indices for input domain with
- PRIVATE :: dom__define_cyclic_north_fold !< - cyclic east-west boundary and north fold boundary condition.
- PRIVATE :: dom__define_north_fold !< - north fold boundary condition.
- PRIVATE :: dom__define_symmetric !< - symmetric boundary condition across the equator.
- PRIVATE :: dom__define_cyclic !< - cyclic east-west boundary.
- PRIVATE :: dom__define_closed !< - cyclic east-west boundary.
- PRIVATE :: dom__check_EW_index !< check East-West indices
- !< compute size of an extract domain
- PRIVATE :: dom__size_no_pole !< - without north fold condition
- PRIVATE :: dom__size_no_pole_overlap !< - without north fold condition, and which overlap east-west boundary
- PRIVATE :: dom__size_no_pole_no_overlap !< - without north fold condition, and which do not overlap east-west boundary
- PRIVATE :: dom__size_pole !< - with north fold condition
- PRIVATE :: dom__size_pole_overlap !< - with north fold condition, and which overlap east-west boundary
- PRIVATE :: dom__size_pole_no_overlap !< - with north fold condition, and which do not overlap east-west boundary
-
- !> @struct
- TYPE TDOM
- TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim0 !< global domain dimension
- TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< sub domain dimension
- INTEGER(i4) :: i_perio0 !< NEMO periodicity index
- INTEGER(i4) :: i_ew0 !< East-West overlap
- INTEGER(i4) :: i_perio !< NEMO periodicity index
- INTEGER(i4) :: i_pivot !< NEMO pivot point index F(0),T(1)
- INTEGER(i4) :: i_imin = 1 !< i-direction sub-domain lower left point indice
- INTEGER(i4) :: i_imax = 1 !< i-direction sub-domain upper right point indice
- INTEGER(i4) :: i_jmin = 1 !< j-direction sub-domain lower left point indice
- INTEGER(i4) :: i_jmax = 1 !< j-direction sub-domain upper right point indice
- INTEGER(i4) :: i_kmin = 1 !< k-direction sub-domain lower level indice
- INTEGER(i4) :: i_kmax = 1 !< k-direction sub-domain upper level indice
- INTEGER(i4) :: i_lmin = 1 !< l-direction sub-domain lower time indice
- INTEGER(i4) :: i_lmax = 1 !< l-direction sub-domain upper time indice
-
- INTEGER(i4) :: i_ighost = 0 !< i-direction ghost cell factor
- INTEGER(i4) :: i_jghost = 0 !< j-direction ghost cell factor
-
- INTEGER(i4), DIMENSION(2) :: i_iextra = 0 !< i-direction extra point
- INTEGER(i4), DIMENSION(2) :: i_jextra = 0 !< j-direction extra point
+ PRIVATE :: dom__init_mpp ! initialise domain structure, given mpp file structure
+ PRIVATE :: dom__define ! define sub domain indices
+ ! define sub domain indices for input domain with
+ PRIVATE :: dom__define_cyclic_north_fold ! - cyclic east-west boundary and north fold boundary condition.
+ PRIVATE :: dom__define_north_fold ! - north fold boundary condition.
+ PRIVATE :: dom__define_symmetric ! - symmetric boundary condition across the equator.
+ PRIVATE :: dom__define_cyclic ! - cyclic east-west boundary.
+ PRIVATE :: dom__define_closed ! - cyclic east-west boundary.
+ ! compute size of sub domain
+ PRIVATE :: dom__size_no_pole ! - without north fold condition
+ PRIVATE :: dom__size_no_pole_overlap ! - without north fold condition, and which overlap east-west boundary
+ PRIVATE :: dom__size_no_pole_no_overlap ! - without north fold condition, and which do not overlap east-west boundary
+ PRIVATE :: dom__size_pole ! - with north fold condition
+ PRIVATE :: dom__size_pole_overlap ! - with north fold condition, and which overlap east-west boundary
+ PRIVATE :: dom__size_pole_no_overlap ! - with north fold condition, and which do not overlap east-west boundary
+ ! compute size of
+ PRIVATE :: dom__size_global ! - global domain
+ PRIVATE :: dom__size_semi_global ! - semi global domain
+ PRIVATE :: dom__copy_unit ! copy attribute structure
+
+ TYPE TDOM !< domain structure
+ TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim0 !< global domain dimension
+ TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< sub domain dimension
+ INTEGER(i4) :: i_perio0 !< NEMO periodicity index of global domain
+ INTEGER(i4) :: i_ew0 !< East-West overlap of global domain
+ INTEGER(i4) :: i_perio !< NEMO periodicity index of sub domain
+ INTEGER(i4) :: i_pivot !< NEMO pivot point index F(0),T(1)
+ INTEGER(i4) :: i_imin = 0 !< i-direction sub-domain lower left point indice
+ INTEGER(i4) :: i_imax = 0 !< i-direction sub-domain upper right point indice
+ INTEGER(i4) :: i_jmin = 0 !< j-direction sub-domain lower left point indice
+ INTEGER(i4) :: i_jmax = 0 !< j-direction sub-domain upper right point indice
+
+ INTEGER(i4) :: i_bdy = 0 !< boundary index : 0 = no boundary
+ !< 1 = north
+ !< 2 = south
+ !< 3 = east
+ !< 4 = west
+ INTEGER(i4), DIMENSION(2,2) :: i_ghost0 = 0 !< array of ghost cell factor of global domain
+ INTEGER(i4), DIMENSION(2,2) :: i_ghost = 0 !< array of ghost cell factor of sub domain
+
+ INTEGER(i4), DIMENSION(2) :: i_iextra = 0 !< i-direction extra point
+ INTEGER(i4), DIMENSION(2) :: i_jextra = 0 !< j-direction extra point
END TYPE TDOM
@@ -92,10 +202,45 @@
INTERFACE dom_init
- MODULE PROCEDURE dom_init_file
-! MODULE PROCEDURE dom_init_mpp
+ MODULE PROCEDURE dom__init_file
+ MODULE PROCEDURE dom__init_mpp
END INTERFACE dom_init
+ INTERFACE dom_copy
+ MODULE PROCEDURE dom__copy_unit ! copy attribute structure
+ END INTERFACE
+
CONTAINS
!-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine copy an domain structure in another one
+ !> @details
+ !> dummy function to get the same use for all structure
+ !>
+ !> @warning do not use on the output of a function who create or read an
+ !> structure (ex: tl_dom=dom_copy(dom_init()) is forbidden).
+ !> This will create memory leaks.
+ !> @warning to avoid infinite loop, do not use any function inside
+ !> this subroutine
+ !>
+ !> @author J.Paul
+ !> @date November, 2014 - Initial Version
+ !>
+ !> @param[in] td_dom domain structure
+ !> @return copy of input domain structure
+ !-------------------------------------------------------------------
+ FUNCTION dom__copy_unit( td_dom )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TDOM), INTENT(IN) :: td_dom
+ ! function
+ TYPE(TDOM) :: dom__copy_unit
+
+ ! local variable
+ !----------------------------------------------------------------
+
+ dom__copy_unit=td_dom
+
+ END FUNCTION dom__copy_unit
+ !-------------------------------------------------------------------
!> @brief This subroutine print some information about domain strucutre.
!
@@ -103,7 +248,6 @@
!> - Nov, 2013- Initial Version
!
- !> @param[inout] td_dom : dom structure
- !-------------------------------------------------------------------
- !> @code
+ !> @param[inout] td_dom dom structure
+ !-------------------------------------------------------------------
SUBROUTINE dom_print(td_dom)
IMPLICIT NONE
@@ -123,7 +267,10 @@
END SELECT
- WRITE(*,'((a,4(i0,1x)),(/a,i2,a,a),(/a,4(i0,1x)),(/a,i2/),10(/a,i0))') &
+ WRITE(*,'((a,4(i0,1x)),(/a,i2,a,a),2(/a,2(i0,1x)),(/a,4(i0,1x)),(/a,i2/),&
+ & 4(/a,i0),4(/a,2(i0,1x)))') &
& " global domain size ",td_dom%t_dim0(:)%i_len, &
& " domain periodicity ",td_dom%i_perio0,", pivot: ",TRIM(cl_pivot), &
+ & " i-direction ghost cell factor of global domain ",td_dom%i_ghost0(jp_I,:), &
+ & " j-direction ghost cell factor of global domain ",td_dom%i_ghost0(jp_J,:), &
& " sub-domain size : ",td_dom%t_dim(:)%i_len, &
& " sub domain periodicity ",td_dom%i_perio, &
@@ -132,58 +279,181 @@
& " j-direction sub-domain lower left point indice ",td_dom%i_jmin, &
& " j-direction sub-domain upper right point indice ",td_dom%i_jmax, &
-! & " k-direction sub-domain lower level indice ",td_dom%i_kmin, &
-! & " k-direction sub-domain upper level indice ",td_dom%i_kmax, &
-! & " l-direction sub-domain lower time indice ",td_dom%i_lmin, &
-! & " l-direction sub-domain upper time indice ",td_dom%i_lmax, &
- & " i-direction ghost cell factor ",td_dom%i_ighost, &
- & " j-direction ghost cell factor ",td_dom%i_jghost
+ & " i-direction ghost cell factor ",td_dom%i_ghost(jp_I,:), &
+ & " j-direction ghost cell factor ",td_dom%i_ghost(jp_J,:), &
+ & " i-direction extra point for interpolation ",td_dom%i_iextra(:), &
+ & " j-direction extra point for interpolation ",td_dom%i_jextra(:)
END SUBROUTINE dom_print
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function intialise domain structure, given open file structure,
- !> and grid periodicity.
+ !> and sub domain indices.
+ !> @details
+ !> sub domain indices are computed, taking into account coarse grid
+ !> periodicity, pivot point, and East-West overlap.
!
!> @author J.Paul
!> - June, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_perio : grid periodicity
- !> @param[in] id_imin : i-direction sub-domain lower left point indice
- !> @param[in] id_imax : i-direction sub-domain upper right point indice
- !> @param[in] id_jmin : j-direction sub-domain lower left point indice
- !> @param[in] id_jmax : j-direction sub-domain upper right point indice
- !> @param[in] id_kmin : k-direction sub-domain lower level indice
- !> @param[in] id_kmax : k-direction sub-domain upper level indice
- !> @param[in] id_lmin : l-direction sub-domain lower time indice
- !> @param[in] id_lmax : l-direction sub-domain upper time indice
+ !> @date September, 2014
+ !> - add boundary index
+ !> - add ghost cell factor
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[in] id_perio grid periodicity
+ !> @param[in] id_imin i-direction sub-domain lower left point indice
+ !> @param[in] id_imax i-direction sub-domain upper right point indice
+ !> @param[in] id_jmin j-direction sub-domain lower left point indice
+ !> @param[in] id_jmax j-direction sub-domain upper right point indice
+ !> @param[in] cd_card name of cardinal (for boundary)
!> @return domain structure
- !>
- !> @todo
- !> - initialiser domain
- !> - add info new perio.. dans sortie
- !-------------------------------------------------------------------
- !> @code
- TYPE(TDOM) FUNCTION dom_init_file( td_file, &
- & id_imin, id_imax, id_jmin, id_jmax )
-! & id_kmin, id_kmax, id_lmin, id_lmax )
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(IN) :: td_file
- INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin
- INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax
- INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin
- INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax
-! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmin
-! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmax
-! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmin
-! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmax
-
+ !-------------------------------------------------------------------
+ TYPE(TDOM) FUNCTION dom__init_mpp( td_mpp, &
+ & id_imin, id_imax, id_jmin, id_jmax, &
+ & cd_card )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP) , INTENT(IN) :: td_mpp
+
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_imin
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_imax
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_jmin
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_jmax
+
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_card
!local variable
!----------------------------------------------------------------
! clean domain structure
- CALL dom_clean(dom_init_file)
+ CALL dom_clean(dom__init_mpp)
+
+ IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
+
+ CALL logger_error( &
+ & " DOM INIT: no processor file associated to mpp "//&
+ & TRIM(td_mpp%c_name))
+
+ ELSE
+ ! global domain define by file
+
+ ! look for boundary index
+ IF( PRESENT(cd_card) )THEN
+ SELECT CASE(TRIM(cd_card))
+ CASE('north')
+ dom__init_mpp%i_bdy=jp_north
+ CASE('south')
+ dom__init_mpp%i_bdy=jp_south
+ CASE('east')
+ dom__init_mpp%i_bdy=jp_east
+ CASE('west')
+ dom__init_mpp%i_bdy=jp_west
+ CASE DEFAULT
+ ! no boundary
+ dom__init_mpp%i_bdy=0
+ END SELECT
+ ELSE
+ ! no boundary
+ dom__init_mpp%i_bdy=0
+ ENDIF
+
+ ! use global dimension define by mpp file
+ dom__init_mpp%t_dim0(:) = dim_copy(td_mpp%t_dim(:))
+
+ IF( td_mpp%i_perio < 0 .OR. td_mpp%i_perio > 6 )THEN
+ CALL logger_error("DOM INIT: invalid grid periodicity. "//&
+ & "you should use grid_get_perio to compute it")
+ ELSE
+ dom__init_mpp%i_perio0=td_mpp%i_perio
+ ENDIF
+
+ ! global domain pivot point
+ SELECT CASE(dom__init_mpp%i_perio0)
+ CASE(3,4)
+ dom__init_mpp%i_pivot = 0
+ CASE(5,6)
+ dom__init_mpp%i_pivot = 1
+ CASE DEFAULT
+ dom__init_mpp%i_pivot = 0
+ END SELECT
+
+ ! add ghost cell factor of global domain
+ dom__init_mpp%i_ghost0(:,:)=0
+ SELECT CASE(dom__init_mpp%i_perio0)
+ CASE(0)
+ dom__init_mpp%i_ghost0(:,:)=1
+ CASE(1)
+ dom__init_mpp%i_ghost0(jp_J,:)=1
+ CASE(2)
+ dom__init_mpp%i_ghost0(jp_I,:)=1
+ dom__init_mpp%i_ghost0(jp_J,2)=1
+ CASE(3,5)
+ dom__init_mpp%i_ghost0(jp_I,:)=1
+ dom__init_mpp%i_ghost0(jp_J,1)=1
+ CASE(4,6)
+ dom__init_mpp%i_ghost0(jp_J,1)=1
+ END SELECT
+
+ ! look for EW overlap
+ dom__init_mpp%i_ew0=td_mpp%i_ew
+
+ ! initialise domain as global
+ dom__init_mpp%i_imin = 1
+ dom__init_mpp%i_imax = dom__init_mpp%t_dim0(1)%i_len
+
+ dom__init_mpp%i_jmin = 1
+ dom__init_mpp%i_jmax = dom__init_mpp%t_dim0(2)%i_len
+
+ ! sub domain dimension
+ dom__init_mpp%t_dim(:) = dim_copy(td_mpp%t_dim(:))
+
+ ! define sub domain indices
+ CALL dom__define( dom__init_mpp, &
+ & id_imin, id_imax, id_jmin, id_jmax )
+
+ ENDIF
+
+ END FUNCTION dom__init_mpp
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This function intialise domain structure, given open file structure,
+ !> and sub domain indices.
+ !> @details
+ !> sub domain indices are computed, taking into account coarse grid
+ !> periodicity, pivot point, and East-West overlap.
+ !
+ !> @author J.Paul
+ !> - June, 2013- Initial Version
+ !> @date September, 2014
+ !> - add boundary index
+ !> - add ghost cell factor
+ !>
+ !> @param[in] td_file file structure
+ !> @param[in] id_perio grid periodicity
+ !> @param[in] id_imin i-direction sub-domain lower left point indice
+ !> @param[in] id_imax i-direction sub-domain upper right point indice
+ !> @param[in] id_jmin j-direction sub-domain lower left point indice
+ !> @param[in] id_jmax j-direction sub-domain upper right point indice
+ !> @param[in] cd_card name of cardinal (for boundary)
+ !> @return domain structure
+ !-------------------------------------------------------------------
+ TYPE(TDOM) FUNCTION dom__init_file( td_file, &
+ & id_imin, id_imax, id_jmin, id_jmax, &
+ & cd_card )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TFILE) , INTENT(IN) :: td_file
+
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_imin
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_imax
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_jmin
+ INTEGER(i4) , INTENT(IN), OPTIONAL :: id_jmax
+
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_card
+ !local variable
+ !----------------------------------------------------------------
+
+ ! clean domain structure
+ CALL dom_clean(dom__init_file)
IF( td_file%i_id == 0 )THEN
@@ -195,144 +465,97 @@
! global domain define by file
+ ! look for boundary index
+ IF( PRESENT(cd_card) )THEN
+ SELECT CASE(TRIM(cd_card))
+ CASE('north')
+ dom__init_file%i_bdy=jp_north
+ CASE('south')
+ dom__init_file%i_bdy=jp_south
+ CASE('east')
+ dom__init_file%i_bdy=jp_east
+ CASE('west')
+ dom__init_file%i_bdy=jp_west
+ CASE DEFAULT
+ ! no boundary
+ dom__init_file%i_bdy=0
+ END SELECT
+ ELSE
+ ! no boundary
+ dom__init_file%i_bdy=0
+ ENDIF
+
! use global dimension define by file
- dom_init_file%t_dim0(:) = td_file%t_dim(:)
+ dom__init_file%t_dim0(:) = dim_copy(td_file%t_dim(:))
IF( td_file%i_perio < 0 .OR. td_file%i_perio > 6 )THEN
CALL logger_error("DOM INIT: invalid grid periodicity. "//&
- & "you should use dom_get_perio to compute it")
+ & "you should use grid_get_perio to compute it")
ELSE
- dom_init_file%i_perio0=td_file%i_perio
+ dom__init_file%i_perio0=td_file%i_perio
ENDIF
! global domain pivot point
- SELECT CASE(dom_init_file%i_perio0)
+ SELECT CASE(dom__init_file%i_perio0)
CASE(3,4)
- dom_init_file%i_pivot = 0
+ dom__init_file%i_pivot = 0
CASE(5,6)
- dom_init_file%i_pivot = 1
+ dom__init_file%i_pivot = 1
CASE DEFAULT
- dom_init_file%i_pivot = 0
+ dom__init_file%i_pivot = 0
END SELECT
+ ! add ghost cell factor of global domain
+ dom__init_file%i_ghost0(:,:)=0
+ SELECT CASE(dom__init_file%i_perio0)
+ CASE(0)
+ dom__init_file%i_ghost0(:,:)=1
+ CASE(1)
+ dom__init_file%i_ghost0(jp_J,:)=1
+ CASE(2)
+ dom__init_file%i_ghost0(jp_I,:)=1
+ dom__init_file%i_ghost0(jp_J,2)=1
+ CASE(3,5)
+ dom__init_file%i_ghost0(jp_I,:)=1
+ dom__init_file%i_ghost0(jp_J,1)=1
+ CASE(4,6)
+ dom__init_file%i_ghost0(jp_J,1)=1
+ END SELECT
+
! look for EW overlap
- dom_init_file%i_ew0=td_file%i_ew
+ dom__init_file%i_ew0=td_file%i_ew
! initialise domain as global
- dom_init_file%i_imin = 1
- dom_init_file%i_imax = dom_init_file%t_dim0(1)%i_len
-
- dom_init_file%i_jmin = 1
- dom_init_file%i_jmax = dom_init_file%t_dim0(2)%i_len
-
-! dom_init_file%i_kmin = 1
-! dom_init_file%i_kmax = dom_init_file%t_dim(3)%i_len
-!
-! dom_init_file%i_lmin = 1
-! dom_init_file%i_lmax = dom_init_file%t_dim(4)%i_len
-
- ! extract domain dimension
- dom_init_file%t_dim(:) = td_file%t_dim(:)
-
- ! define extract domain indices
- CALL dom__define( dom_init_file, &
- & id_imin, id_imax, id_jmin, id_jmax )
-! & id_kmin, id_kmax, id_lmin, id_lmax )
-
- ENDIF
-
- END FUNCTION dom_init_file
- !> @endcode
- ! !-------------------------------------------------------------------
- ! !> @brief
- ! !> This function intialise domain structure, given mpp structure,
- ! !> and variable name. domain indices could be specify.
- ! !
- ! !> @details
- ! !>
- ! !
- ! !> @author J.Paul
- ! !> - Nov, 2013- Initial Version
- ! !
- ! !> @param[in] td_mpp : mpp structure
- ! !> @param[in] cd_varname : variable name
- ! !> @return domain structure
- ! !>
- ! !> @todo
- ! !> - initialiser domain
- ! !-------------------------------------------------------------------
- ! !> @code
- ! TYPE(TDOM) FUNCTION dom_init_mpp( td_mpp, cd_varname )
- ! IMPLICIT NONE
- ! ! Argument
- ! TYPE(TMPP), INTENT(IN) :: td_mpp
- ! CHARACTER(LEN=*), INTENT(IN) :: cd_varname
- ! !----------------------------------------------------------------
-
- ! ! clean domain structure
- ! CALL dom_clean(dom_init_mpp)
-
- ! IF( ASSOCIATED(td_mpp%t_proc) )THEN
-
- ! CALL logger_error( " INIT: mpp strcuture "//TRIM(td_mpp%c_name)//&
- ! & " not define" )
-
- ! ELSE
- ! ! global domain define by mpp
-
- ! ! use global dimension define by mpp
- ! dom_init_mpp%t_dim(:) = td_mpp%t_dim(:)
-
- ! ! get global domain periodicity ??
- ! dom_init_mpp%i_perio = dom_get_perio(td_mpp, cd_varname)
-
- ! ! global domain pivot point
- ! SELECT CASE(dom_init%i_perio)
- ! CASE(3,4)
- ! dom_init%i_pivot = 0
- ! CASE(5,6)
- ! dom_init%i_pivot = 1
- ! CASE DEFAULT
- ! dom_init%i_pivot = 0
- ! END SELECT
-
- ! ! initialise domain as global
- ! dom_init_mpp%i_imin = 1
- ! dom_init_mpp%i_imax = dom_init_mpp%t_dim(1)%i_len
-
- ! dom_init_mpp%i_jmin = 1
- ! dom_init_mpp%i_jmax = dom_init_mpp%t_dim(2)%i_len
-
- ! dom_init_mpp%i_kmin = 1
- ! dom_init_mpp%i_kmax = dom_init_mpp%t_dim(3)%i_len
-
- ! dom_init_mpp%i_lmin = 1
- ! dom_init_mpp%i_lmax = dom_init_mpp%t_dim(4)%i_len
-
- ! ENDIF
-
- ! END FUNCTION dom_init_mpp
- ! !> @endcode
+ dom__init_file%i_imin = 1
+ dom__init_file%i_imax = dom__init_file%t_dim0(1)%i_len
+
+ dom__init_file%i_jmin = 1
+ dom__init_file%i_jmax = dom__init_file%t_dim0(2)%i_len
+
+ ! sub domain dimension
+ dom__init_file%t_dim(:) = dim_copy(td_file%t_dim(:))
+
+ ! define sub domain indices
+ CALL dom__define( dom__init_file, &
+ & id_imin, id_imax, id_jmin, id_jmax )
+
+ ENDIF
+
+ END FUNCTION dom__init_file
!-------------------------------------------------------------------
!> @brief
- !> This subroutine define extract domain indices, and compute the size
- !> of the domain.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain structure
- !> @param[in] id_imin : i-direction sub-domain lower left point indice
- !> @param[in] id_imax : i-direction sub-domain upper right point indice
- !> @param[in] id_jmin : j-direction sub-domain lower left point indice
- !> @param[in] id_jmax : j-direction sub-domain upper right point indice
- !> @param[in] id_kmin : k-direction sub-domain lower level indice
- !> @param[in] id_kmax : k-direction sub-domain upper level indice
- !> @param[in] id_lmin : l-direction sub-domain lower time indice
- !> @param[in] id_lmax : l-direction sub-domain upper time indice
- !-------------------------------------------------------------------
- !> @code
+ !> This subroutine define sub domain indices, and compute the size
+ !> of the sub domain.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain structure
+ !> @param[in] id_imin i-direction sub-domain lower left point indice
+ !> @param[in] id_imax i-direction sub-domain upper right point indice
+ !> @param[in] id_jmin j-direction sub-domain lower left point indice
+ !> @param[in] id_jmax j-direction sub-domain upper right point indice
+ !-------------------------------------------------------------------
SUBROUTINE dom__define(td_dom, &
& id_imin, id_imax, id_jmin, id_jmax )
-! & id_kmin, id_kmax, id_lmin, id_lmax )
IMPLICIT NONE
! Argument
@@ -342,8 +565,4 @@
INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin
INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax
-! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmin
-! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmax
-! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmin
-! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmax
!----------------------------------------------------------------
@@ -354,64 +573,62 @@
IF( PRESENT(id_jmax) ) td_dom%i_jmax = id_jmax
-! IF( PRESENT(id_kmin) ) td_dom%i_kmin = id_kmin
-! IF( PRESENT(id_kmax) ) td_dom%i_kmax = id_kmax
-!
-! IF( PRESENT(id_lmin) ) td_dom%i_lmin = id_lmin
-! IF( PRESENT(id_lmax) ) td_dom%i_lmax = id_lmax
-
! check indices
- IF(( td_dom%i_imin < 0 .OR. td_dom%i_imin > td_dom%t_dim0(1)%i_len ).OR. &
- & ( td_dom%i_imax < 0 .OR. td_dom%i_imax > td_dom%t_dim0(1)%i_len ).OR. &
- & ( td_dom%i_jmin < 0 .OR. td_dom%i_jmin > td_dom%t_dim0(2)%i_len ).OR. &
- & ( td_dom%i_jmax < 0 .OR. td_dom%i_jmax > td_dom%t_dim0(2)%i_len ))THEN
-! & ( td_dom%i_kmin < 0 .OR. td_dom%i_kmin > td_dom%t_dim0(3)%i_len ).OR. &
-! & ( td_dom%i_kmax < 0 .OR. td_dom%i_kmax > td_dom%t_dim0(3)%i_len ).OR. &
-! & ( td_dom%i_lmin < 0 .OR. td_dom%i_lmin > td_dom%t_dim0(4)%i_len ).OR. &
-! & ( td_dom%i_lmax < 0 .OR. td_dom%i_lmax > td_dom%t_dim0(4)%i_len ))THEN
- CALL logger_error( "DOM INIT DEFINE: invalid grid definition."// &
+ IF(( td_dom%i_imin < -1 .OR. td_dom%i_imin > td_dom%t_dim0(1)%i_len ).OR. &
+ & ( td_dom%i_imax < -1 .OR. td_dom%i_imax > td_dom%t_dim0(1)%i_len ).OR. &
+ & ( td_dom%i_jmin < -1 .OR. td_dom%i_jmin > td_dom%t_dim0(2)%i_len ).OR. &
+ & ( td_dom%i_jmax < -1 .OR. td_dom%i_jmax > td_dom%t_dim0(2)%i_len ))THEN
+ CALL logger_debug("0 <= imin ("//TRIM(fct_str(id_imin))//") < "//&
+ & TRIM(fct_str(td_dom%t_dim0(1)%i_len)))
+ CALL logger_debug("0 <= imax ("//TRIM(fct_str(id_imax))//") < "//&
+ & TRIM(fct_str(td_dom%t_dim0(1)%i_len)))
+ CALL logger_debug("0 <= jmin ("//TRIM(fct_str(id_jmin))//") < "//&
+ & TRIM(fct_str(td_dom%t_dim0(2)%i_len)))
+ CALL logger_debug("0 <= jmax ("//TRIM(fct_str(id_jmax))//") < "//&
+ & TRIM(fct_str(td_dom%t_dim0(2)%i_len)))
+ CALL logger_fatal( "DOM INIT DEFINE: invalid grid definition."// &
& " check min and max indices")
- CALL logger_debug("0 < imin ("//TRIM(fct_str(id_imin))//") < "//&
- & TRIM(fct_str(td_dom%t_dim0(1)%i_len)))
- CALL logger_debug("0 < imax ("//TRIM(fct_str(id_imax))//") < "//&
- & TRIM(fct_str(td_dom%t_dim0(1)%i_len)))
- CALL logger_debug("0 < jmin ("//TRIM(fct_str(id_jmin))//") < "//&
- & TRIM(fct_str(td_dom%t_dim0(2)%i_len)))
- CALL logger_debug("0 < jmax ("//TRIM(fct_str(id_jmax))//") < "//&
- & TRIM(fct_str(td_dom%t_dim0(2)%i_len)))
-! CALL logger_debug("0 < kmin ("//TRIM(fct_str(id_kmin))//") < "//&
-! & TRIM(fct_str(td_dom%t_dim0(3)%i_len)))
-! CALL logger_debug("0 < kmax ("//TRIM(fct_str(id_kmax))//") < "//&
-! & TRIM(fct_str(td_dom%t_dim0(3)%i_len)))
-! CALL logger_debug("0 < lmin ("//TRIM(fct_str(id_lmin))//") < "//&
-! & TRIM(fct_str(td_dom%t_dim0(4)%i_len)))
-! CALL logger_debug("0 < lmax ("//TRIM(fct_str(id_lmax))//") < "//&
-! & TRIM(fct_str(td_dom%t_dim0(4)%i_len)))
ELSE
-! td_dom%t_dim(3)%i_len=td_dom%i_kmax-td_dom%i_kmin+1
-! td_dom%t_dim(4)%i_len=td_dom%i_lmax-td_dom%i_lmin+1
+ ! force to select north fold
+ IF( td_dom%i_perio0 > 2 .AND. &
+ & ( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 .OR. &
+ & td_dom%i_jmax < td_dom%i_jmin .OR. &
+ & td_dom%i_jmin == 0 ) )THEN
+ td_dom%i_jmax=0
+ ENDIF
+
+ ! force to use cyclic boundary
+ IF( ( td_dom%i_perio0 == 1 .OR. &
+ & td_dom%i_perio0 == 4 .OR. &
+ & td_dom%i_perio0 == 6 ) .AND. &
+ & ( td_dom%i_imin == 0 .OR. td_dom%i_imax == 0 .OR. &
+ & ABS(td_dom%i_imax-td_dom%i_imin)+1 == td_dom%t_dim0(1)%i_len ) &
+ & )THEN
+ td_dom%i_imin = 0
+ td_dom%i_imax = 0
+ ENDIF
SELECT CASE(td_dom%i_perio0)
CASE(0) ! closed boundary
- CALL logger_trace("DEFINE: closed boundary")
+ CALL logger_trace("DOM INIT DEFINE: closed boundary")
CALL dom__define_closed( td_dom )
CASE(1) ! cyclic east-west boundary
- CALL logger_trace("DEFINE: cyclic east-west boundary")
+ CALL logger_trace("DOM INIT DEFINE: cyclic east-west boundary")
CALL dom__define_cyclic( td_dom )
CASE(2) ! symmetric boundary condition across the equator
- CALL logger_trace("DEFINE: symmetric boundary condition "//&
+ CALL logger_trace("DOM INIT DEFINE: symmetric boundary condition "//&
& " across the equator")
CALL dom__define_symmetric( td_dom )
CASE(3) ! North fold boundary (with a F-point pivot)
- CALL logger_trace("DEFINE: North fold boundary "//&
+ CALL logger_trace("DOM INIT DEFINE: North fold boundary "//&
& "(with a F-point pivot)")
CALL dom__define_north_fold( td_dom )
CASE(5) ! North fold boundary (with a T-point pivot)
- CALL logger_trace("DEFINE: North fold boundary "//&
+ CALL logger_trace("DOM INIT DEFINE: North fold boundary "//&
& "(with a T-point pivot)")
CALL dom__define_north_fold( td_dom )
CASE(4) ! North fold boundary (with a F-point pivot)
! and cyclic east-west boundary
- CALL logger_trace("DEFINE: North fold boundary "//&
+ CALL logger_trace("DOM INIT DEFINE: North fold boundary "//&
& "(with a F-point pivot) and cyclic "//&
& "east-west boundary")
@@ -419,10 +636,10 @@
CASE(6) ! North fold boundary (with a T-point pivot)
! and cyclic east-west boundary
- CALL logger_trace("DEFINE: North fold boundary "//&
+ CALL logger_trace("DOM INIT DEFINE: North fold boundary "//&
& "(with a T-point pivot) and cyclic "//&
& "east-west boundary")
CALL dom__define_cyclic_north_fold( td_dom )
CASE DEFAULT
- CALL logger_error("DEFINE: invalid grid periodicity index")
+ CALL logger_error("DOM INIT DEFINE: invalid grid periodicity index")
END SELECT
@@ -430,16 +647,16 @@
END SUBROUTINE dom__define
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine define domain indices from global domain with
+ !> This subroutine define sub domain indices from global domain with
!> cyclic east-west boundary and north fold boundary condition.
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Subroutine written
+ !> @date September, 2014
+ !> - use zero indice to defined cyclic or global domain
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom__define_cyclic_north_fold( td_dom )
IMPLICIT NONE
@@ -448,10 +665,10 @@
!----------------------------------------------------------------
- CALL dom__check_EW_index( td_dom )
-
- IF( td_dom%i_imin == td_dom%i_imax .AND. &
- & td_dom%i_jmin == td_dom%i_jmax )THEN
-
- CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
+ !CALL dom__check_EW_index( td_dom )
+
+ IF( td_dom%i_imin == 0 .AND. td_dom%i_imax == 0 .AND. &
+ & td_dom%i_jmin == 0 .AND. td_dom%i_jmax == 0 )THEN
+
+ CALL logger_trace("DOM DEFINE CYCLIC NORTH FOLD: "//&
& "domain to extract is global" )
! coarse domain is global domain
@@ -459,52 +676,38 @@
CALL dom__size_global( td_dom )
- ELSEIF( td_dom%i_imin == td_dom%i_imax .AND. &
- & td_dom%i_jmin >= td_dom%i_jmax )THEN
-
- CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
+ ELSEIF( td_dom%i_imin == 0 .AND. td_dom%i_imax == 0 .AND. &
+ & td_dom%i_jmax == 0 )THEN
+
+ CALL logger_trace("DOM DEFINE CYCLIC NORTH FOLD: "//&
& "domain to extract is semi-global" )
CALL dom__size_semi_global( td_dom )
- ELSEIF( td_dom%i_imin == td_dom%i_imax .AND. &
- & td_dom%i_jmin < td_dom%i_jmax )THEN
-
- CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
+ ELSEIF( td_dom%i_imin == 0 .AND. td_dom%i_imax == 0 .AND. &
+ & td_dom%i_jmax /= 0 )THEN
+
+ CALL logger_trace("DOM DEFINE CYCLIC NORTH FOLD: "//&
& "domain to extract is band of latidue" )
CALL dom__size_no_pole( td_dom )
- ELSEIF( td_dom%i_imin /= td_dom%i_imax .AND. &
- & td_dom%i_jmin == td_dom%i_jmax )THEN
-
- CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
- & "domain to extract has north boundary" )
+ ELSEIF( td_dom%i_jmax == 0 )THEN
+
+ CALL logger_trace("DOM DEFINE CYCLIC NORTH FOLD: "//&
+ & "domain to extract use north fold" )
CALL dom__size_pole( td_dom )
- ELSEIF( td_dom%i_imin /= td_dom%i_imax .AND. &
- & td_dom%i_jmin /= td_dom%i_jmax )THEN
-
- IF( td_dom%i_jmax < td_dom%t_dim0(2)%i_len-1 .AND. &
- & td_dom%i_jmax > td_dom%i_jmin )THEN
-
- CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
- & "domain to extract has no north boundary" )
- ! no North Pole
-
- CALL dom__size_no_pole( td_dom )
-
- ELSE
-
- CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
- & "domain to extract has north boundary" )
-
- CALL dom__size_pole( td_dom )
-
- ENDIF
+ ELSEIF( td_dom%i_jmax /= 0 )THEN
+
+ CALL logger_trace("DOM DEFINE CYCLIC NORTH FOLD: "//&
+ & "domain to extract do not use north fold" )
+ ! no North Pole
+
+ CALL dom__size_no_pole( td_dom )
ELSE
- CALL logger_error("DEFINE CYCLIC NORTH FOLD: "//&
+ CALL logger_error("DOM DEFINE CYCLIC NORTH FOLD: "//&
& "should have been an impossible case" )
@@ -512,16 +715,14 @@
END SUBROUTINE dom__define_cyclic_north_fold
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine define extract domain indices from global domain
+ !> This subroutine define sub domain indices from global domain
!> with north fold boundary condition.
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom__define_north_fold( td_dom )
IMPLICIT NONE
@@ -530,8 +731,7 @@
!----------------------------------------------------------------
- IF( td_dom%i_jmax < td_dom%t_dim0(2)%i_len-1 .AND. &
- & td_dom%i_jmax > td_dom%i_jmin )THEN
-
- CALL logger_trace("DEFINE NORTH FOLD: "//&
+ IF( td_dom%i_jmax /= 0 )THEN
+
+ CALL logger_trace("DOM DEFINE NORTH FOLD: "//&
& "domain to extract has no north boundary" )
! no North Pole
@@ -541,6 +741,6 @@
ELSE
- CALL logger_trace("DEFINE NORTH FOLD: "//&
- & "domain to extract has north boundary" )
+ CALL logger_trace("DOM DEFINE NORTH FOLD: "//&
+ & "sub domain has north boundary" )
CALL dom__size_pole_no_overlap( td_dom )
@@ -549,16 +749,14 @@
END SUBROUTINE dom__define_north_fold
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine define extract domain indices from global domain
+ !> This subroutine define sub domain indices from global domain
!> with symmetric boundary condition across the equator.
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom__define_symmetric( td_dom )
IMPLICIT NONE
@@ -570,16 +768,14 @@
END SUBROUTINE dom__define_symmetric
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine define extract domain indices from global domain
+ !> This subroutine define sub domain indices from global domain
!> with cyclic east-west boundary.
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom__define_cyclic( td_dom )
IMPLICIT NONE
@@ -587,8 +783,7 @@
TYPE(TDOM), INTENT(INOUT) :: td_dom
!----------------------------------------------------------------
- CALL dom__check_EW_index( td_dom )
IF( td_dom%i_imin >= td_dom%i_imax )THEN
- CALL logger_trace("DEFINE CYCLIC: "//&
+ CALL logger_trace("DOM DEFINE CYCLIC: "//&
& "domain to extract overlap east-west boundary")
@@ -597,5 +792,5 @@
ELSE
! id_imin < id_imax
- CALL logger_trace("DEFINE CYCLIC: "//&
+ CALL logger_trace("DOM DEFINE CYCLIC: "//&
& "domain to extract do not overlap east-west boundary")
@@ -605,16 +800,14 @@
END SUBROUTINE dom__define_cyclic
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine define extract domain indices from global domain
+ !> This subroutine define sub domain indices from global domain
!> with closed boundaries.
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom__define_closed( td_dom )
IMPLICIT NONE
@@ -626,35 +819,4 @@
END SUBROUTINE dom__define_closed
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine check East-West indices, use inside a cyclic domain,
- !> and redefine it in some particular cases.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE dom__check_EW_index( td_dom )
- IMPLICIT NONE
- ! Argument
- TYPE(TDOM), INTENT(INOUT) :: td_dom
- !----------------------------------------------------------------
-
- IF( td_dom%i_imin /= td_dom%i_imax )THEN
-
- IF((ABS(td_dom%i_imax-td_dom%i_imin) >= td_dom%t_dim0(1)%i_len-1).OR.&
- (ABS(td_dom%i_imax-td_dom%i_imin) <= td_dom%i_ew0 ) )THEN
-
- td_dom%i_imin = td_dom%i_imax
-
- ENDIF
-
- ENDIF
-
- END SUBROUTINE dom__check_EW_index
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -662,9 +824,8 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom__size_global( td_dom )
IMPLICIT NONE
@@ -684,8 +845,7 @@
! no ghost cell to add
- td_dom%i_ighost=0
- td_dom%i_jghost=0
-
- ! peiordicity
+ td_dom%i_ghost(:,:)=0
+
+ ! periodicity
IF( td_dom%i_pivot == 0 )THEN ! 0-F
td_dom%i_perio=4
@@ -697,5 +857,4 @@
END SUBROUTINE dom__size_global
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -703,10 +862,9 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
!> @note never tested
!-------------------------------------------------------------------
- !> @code
SUBROUTINE dom__size_semi_global( td_dom )
IMPLICIT NONE
@@ -715,5 +873,5 @@
! local variable
- INTEGER(i4) :: il_imid ! cananadian bipole index (middle of global domain)
+ INTEGER(i4) :: il_imid ! canadian bipole index (middle of global domain)
!----------------------------------------------------------------
@@ -723,23 +881,18 @@
td_dom%i_imax = il_imid !td_dom%t_dim0(1)%i_len
- IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN
- td_dom%i_jmax=MIN( td_dom%i_jmin, &
- & td_dom%t_dim0(2)%i_len-td_dom%i_jmax )
- ELSE
- td_dom%i_jmin=td_dom%i_jmax
- ENDIF
+ IF( td_dom%i_jmin == 0 ) td_dom%i_jmin=1
+ td_dom%i_jmax = td_dom%t_dim0(2)%i_len
! domain size
- td_dom%t_dim(1)%i_len = (td_dom%i_imax ) - &
- & (td_dom%i_imin ) + 1
+ td_dom%t_dim(1)%i_len = td_dom%i_imax - &
+ & td_dom%i_imin + 1
td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmin ) + 1 ) + &
+ & td_dom%i_jmin + 1 ) + &
& ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmax ) + 1 ) - 2 ! remove north fold condition ?
+ & td_dom%i_jmin + 1 ) - 2 ! remove north fold condition ?
! ghost cell to add
- td_dom%i_ighost=1
- td_dom%i_jghost=1
+ td_dom%i_ghost(:,:)=1
! periodicity
@@ -753,16 +906,14 @@
END SUBROUTINE dom__size_semi_global
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine compute size of an extract domain without north fold
+ !> This subroutine compute size of sub domain without north fold
!> condition
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom__size_no_pole( td_dom )
IMPLICIT NONE
@@ -771,12 +922,13 @@
!----------------------------------------------------------------
- IF( td_dom%i_jmin >= td_dom%i_jmax )THEN
- CALL logger_fatal("DOM INIT: invalid domain. "//&
+ IF( td_dom%i_jmax == 0 )THEN
+ CALL logger_fatal("DOM SIZE NO POLE: invalid domain. "//&
& "can not get north pole from this coarse grid. "//&
& "check namelist and coarse grid periodicity." )
ENDIF
- IF( td_dom%i_imin >= td_dom%i_imax )THEN
- CALL logger_trace("DEFINE NO POLE: "// &
+ IF( td_dom%i_imin == 0 .AND. td_dom%i_imax == 0 .OR. &
+ & td_dom%i_imin > td_dom%i_imax )THEN
+ CALL logger_trace("DOM SIZE NO POLE: "// &
& "domain to extract overlap east-west boundary")
@@ -785,5 +937,5 @@
ELSE
! id_imin < id_imax
- CALL logger_trace("DEFINE NO POLE: "// &
+ CALL logger_trace("DOM SIZE NO POLE: "// &
& "domain to extract do not overlap east-west boundary")
@@ -793,16 +945,15 @@
END SUBROUTINE dom__size_no_pole
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine compute size of an extract domain with north fold
- !> condition
+ !> This subroutine compute size of sub domain with north fold
+ !> condition.
!>
!> @author J.Paul
!> - April, 2013- Subroutine written
!
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> @param[inout] td_dom domain strcuture
+ !> @note never tested
+ !-------------------------------------------------------------------
SUBROUTINE dom__size_pole( td_dom )
IMPLICIT NONE
@@ -811,10 +962,10 @@
!----------------------------------------------------------------
- IF( td_dom%i_imin > td_dom%i_imax )THEN
- CALL logger_trace("DEFINE POLE: "//&
+ IF( td_dom%i_imin >= td_dom%i_imax )THEN
+ CALL logger_trace("DOM SIZE POLE: "//&
& "domain to extract overlap east-west boundary")
CALL dom__size_pole_overlap( td_dom )
ELSEIF( td_dom%i_imin < td_dom%i_imax )THEN
- CALL logger_trace("DEFINE POLE: "//&
+ CALL logger_trace("DOM SIZE POLE: "//&
& "domain to extract do not overlap east-west boundary")
CALL dom__size_pole_no_overlap( td_dom )
@@ -822,16 +973,14 @@
END SUBROUTINE dom__size_pole
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine compute size of an extract domain without north fold
+ !> This subroutine compute size of sub domain without north fold
!> condition, and which overlap east-west boundary
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom__size_no_pole_overlap( td_dom )
IMPLICIT NONE
@@ -840,13 +989,13 @@
!----------------------------------------------------------------
- IF( td_dom%i_jmin >= td_dom%i_jmax )THEN
- CALL logger_fatal("DOM INIT: invalid domain. "//&
+ IF( td_dom%i_jmax == 0 )THEN
+ CALL logger_fatal("DOM SIZE NO POLE OVERLAP: invalid domain. "//&
& "can not get north pole from this coarse grid. "//&
& "check namelist and coarse grid periodicity." )
ENDIF
- IF( td_dom%i_imin == td_dom%i_imax )THEN
+ IF( td_dom%i_imin == 0 .AND. td_dom%i_imax == 0 )THEN
! domain to extract with east west cyclic boundary
- CALL logger_trace("DEFINE NO POLE OVERLAP: "//&
+ CALL logger_trace("DOM SIZE NO POLE OVERLAP: "//&
& "domain to extract has cyclic east-west boundary")
@@ -857,5 +1006,5 @@
! no ghost cell
- td_dom%i_ighost=0
+ td_dom%i_ghost(jp_I,:)=0
! periodicity
@@ -867,10 +1016,10 @@
! extract domain overlap east-west boundary
- td_dom%t_dim(1)%i_len = td_dom%t_dim0(1)%i_len - &
- & (td_dom%i_imin ) + 1 + &
- & (td_dom%i_imax ) - 2 ! remove cyclic boundary
+ td_dom%t_dim(1)%i_len = td_dom%i_imax + &
+ & td_dom%t_dim0(1)%i_len - td_dom%i_imin + 1 - &
+ & td_dom%i_ew0 ! remove cyclic boundary
! add ghost cell
- td_dom%i_ighost=1
+ td_dom%i_ghost(jp_I,:)=1
! periodicity
@@ -879,23 +1028,21 @@
ENDIF
- td_dom%t_dim(2)%i_len = (td_dom%i_jmax ) - &
- & (td_dom%i_jmin ) + 1
+ td_dom%t_dim(2)%i_len = td_dom%i_jmax - &
+ & td_dom%i_jmin + 1
! add ghost cell
- td_dom%i_jghost=1
+ td_dom%i_ghost(jp_J,:)=1
END SUBROUTINE dom__size_no_pole_overlap
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine compute size of an extract domain without north fold
+ !> This subroutine compute size of sub domain without north fold
!> condition, and which do not overlap east-west boundary
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom__size_no_pole_no_overlap( td_dom )
IMPLICIT NONE
@@ -904,25 +1051,24 @@
!----------------------------------------------------------------
- IF( td_dom%i_jmin >= td_dom%i_jmax )THEN
- CALL logger_fatal("DOM INIT: invalid domain. "//&
+ IF( td_dom%i_jmax == 0 )THEN
+ CALL logger_fatal("DOM SIZE NO POLE NO OVERLAP: invalid domain. "//&
& "can not get north pole from this coarse grid. "//&
- & "check namelist and coarse grid periodicity." )
- ENDIF
-
- IF( td_dom%i_imin >= td_dom%i_imax )THEN
- CALL logger_fatal("DOM INIT: invalid domain. "//&
+ & "check domain indices and grid periodicity." )
+ ENDIF
+
+ IF( td_dom%i_imin == 0 .OR. td_dom%i_imax == 0 )THEN
+ CALL logger_fatal("DOM SIZE NO POLE NO OVERLAP: invalid domain. "//&
& "can not overlap East-West boundary with this coarse grid. "//&
- & "check namelist and coarse grid periodicity." )
- ENDIF
-
- td_dom%t_dim(1)%i_len = ( td_dom%i_imax ) - &
- & ( td_dom%i_imin ) + 1
-
- td_dom%t_dim(2)%i_len = ( td_dom%i_jmax ) - &
- & ( td_dom%i_jmin ) + 1
+ & "check domain indices and grid periodicity." )
+ ENDIF
+
+ td_dom%t_dim(1)%i_len = td_dom%i_imax - &
+ & td_dom%i_imin + 1
+
+ td_dom%t_dim(2)%i_len = td_dom%i_jmax - &
+ & td_dom%i_jmin + 1
! add ghost cell
- td_dom%i_ighost=1
- td_dom%i_jghost=1
+ td_dom%i_ghost(:,:)=1
! periodicity
@@ -930,17 +1076,15 @@
END SUBROUTINE dom__size_no_pole_no_overlap
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine compute size of an extract domain with north fold
+ !> This subroutine compute size of sub domain with north fold
!> condition, and which overlap east-west boundary
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
!> @note never tested
!-------------------------------------------------------------------
- !> @code
SUBROUTINE dom__size_pole_overlap( td_dom )
IMPLICIT NONE
@@ -954,5 +1098,5 @@
!----------------------------------------------------------------
- CALL logger_trace("DEFINE POLE OVERLAP: "//&
+ CALL logger_trace("DOM SIZE POLE OVERLAP: "//&
& "asian bipole inside domain to extract")
@@ -964,9 +1108,10 @@
IF( il_idom1 > il_imid .OR. il_idom2 > il_imid )THEN
- CALL logger_trace("DEFINE POLE OVERLAP: "//&
+ CALL logger_trace("DOM SIZE POLE OVERLAP: "//&
& "canadian bipole inside domain to extract")
- td_dom%i_imin = td_dom%i_imax
-
- IF( td_dom%i_jmin == td_dom%i_jmax )THEN
+ td_dom%i_imin = 0
+ td_dom%i_imax = 0
+
+ IF( td_dom%i_jmin == 0 .AND. td_dom%i_jmax == 0 )THEN
CALL dom__size_global( td_dom )
ELSE
@@ -980,27 +1125,21 @@
! east part bigger than west part
- CALL logger_trace("DEFINE POLE OVERLAP: east part bigger than west part ")
+ CALL logger_trace("DOM SIZE POLE OVERLAP: east part bigger than west part ")
! to respect symmetry around asian bipole
td_dom%i_imax = il_idom1
+ IF( td_dom%i_jmin == 0 ) td_dom%i_jmin = 1
! north pole
- IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN
- td_dom%i_jmax=MIN( td_dom%i_jmin, &
- & td_dom%t_dim0(2)%i_len-td_dom%i_jmax )
- ELSE
- td_dom%i_jmax=MIN( td_dom%i_jmin, td_dom%i_jmax )
- ENDIF
- td_dom%i_jmin=td_dom%i_jmax
+ td_dom%i_jmax = td_dom%t_dim0(2)%i_len
! compute size
td_dom%t_dim(1)%i_len = il_idom1 !! no ghost cell ??
td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmin ) + 1 ) + &
+ & td_dom%i_jmin + 1 ) + &
& ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmax ) + 1 ) - 2 ! remove north fold condition ?
+ & td_dom%i_jmin + 1 ) - 2 ! remove north fold condition ?
! add ghost cell
- td_dom%i_ighost=1
- td_dom%i_jghost=1
+ td_dom%i_ghost(:,:)=1
! periodicity
@@ -1010,28 +1149,22 @@
! west part bigger than east part
- CALL logger_trace("DEFINE POLE OVERLAP: west part bigger than east part ")
+ CALL logger_trace("DOM SIZE POLE OVERLAP: west part bigger than east part ")
! to respect symmetry around asian bipole
td_dom%i_imin = td_dom%t_dim0(1)%i_len - il_idom2 + 1
+ IF( td_dom%i_jmin == 0 ) td_dom%i_jmin = 1
! north pole
- IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN
- td_dom%i_jmax=MIN( td_dom%i_jmin, &
- & td_dom%t_dim0(2)%i_len-td_dom%i_jmax )
- ELSE
- td_dom%i_jmax=MIN( td_dom%i_jmin, td_dom%i_jmax )
- ENDIF
- td_dom%i_jmin=td_dom%i_jmax
+ td_dom%i_jmax=td_dom%t_dim0(2)%i_len
! compute size
td_dom%t_dim(1)%i_len = il_idom2
td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmin ) + 1 ) + &
+ & td_dom%i_jmin + 1 ) + &
& ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmax ) + 1 ) - 2
+ & td_dom%i_jmin + 1 ) - 2
! add ghost cell
- td_dom%i_ighost=1
- td_dom%i_jghost=1
+ td_dom%i_ghost(:,:)=1
! periodicity
@@ -1041,17 +1174,15 @@
END SUBROUTINE dom__size_pole_overlap
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine compute size of an extract domain with north fold
+ !> This subroutine compute size of sub domain with north fold
!> condition, and which do not overlap east-west boundary
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @param[inout] td_dom : domain strcuture
+ !> - November, 2013- Subroutine written
+ !
+ !> @param[inout] td_dom domain strcuture
!> @note never tested
!-------------------------------------------------------------------
- !> @code
SUBROUTINE dom__size_pole_no_overlap( td_dom )
IMPLICIT NONE
@@ -1065,21 +1196,16 @@
!----------------------------------------------------------------
- IF( td_dom%i_imin >= td_dom%i_imax )THEN
- CALL logger_fatal("DOM INIT: invalid domain. "//&
+ IF( td_dom%i_imin == 0 .OR. td_dom%i_imax == 0 .OR. &
+ & td_dom%i_imin > td_dom%i_imax )THEN
+ CALL logger_fatal("DOM SIZE POLE NO OVERLAP: invalid domain. "//&
& "can not overlap East-West boundary with this coarse grid. "//&
& "check namelist and coarse grid periodicity." )
ENDIF
- CALL logger_trace("DEFINE POLE NO OVERLAP: "//&
+ CALL logger_trace("DOM SIZE POLE NO OVERLAP: "//&
& "no asian bipole inside domain to extract")
- ! north pole
- IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN
- td_dom%i_jmax=MIN( td_dom%i_jmin, &
- & td_dom%t_dim0(2)%i_len-td_dom%i_jmax )
- ELSE
- td_dom%i_jmax=MIN( td_dom%i_jmin, td_dom%i_jmax )
- ENDIF
- td_dom%i_jmin=td_dom%i_jmax
+ IF( td_dom%i_jmin==0 ) td_dom%i_jmin = 1
+ IF( td_dom%i_jmax==0 ) td_dom%i_jmax = td_dom%t_dim0(2)%i_len
!
@@ -1088,18 +1214,17 @@
IF( (td_dom%i_imin < il_mid .AND. td_dom%i_imax < il_mid) .OR. &
& (td_dom%i_imin > il_mid .AND. td_dom%i_imax > il_mid) )THEN
- CALL logger_trace("DEFINE POLE NO OVERLAP: "//&
+ CALL logger_trace("DOM SIZE POLE NO OVERLAP: "//&
& "no canadian bipole inside domain to extract")
- td_dom%t_dim(1)%i_len = ( td_dom%i_imax ) - &
- & ( td_dom%i_imin ) + 1
+ td_dom%t_dim(1)%i_len = td_dom%i_imax - &
+ & td_dom%i_imin + 1
td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmin ) + 1 ) + &
+ & td_dom%i_jmin + 1 ) + &
& ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmax ) + 1 ) - 2 ! remove north fold condition ?
+ & td_dom%i_jmin + 1 ) - 2 ! remove north fold condition ?
! add ghost cell
- td_dom%i_ighost=1
- td_dom%i_jghost=1
+ td_dom%i_ghost(:,:)=1
! periodicity
@@ -1107,5 +1232,5 @@
ELSE ! id_imin < il_mid .AND. id_imax > il_mid
- CALL logger_trace("DEFINE POLE NO OVERLAP: "//&
+ CALL logger_trace("DOM SIZE POLE NO OVERLAP: "//&
& "canadian bipole inside domain to extract")
@@ -1114,5 +1239,5 @@
IF( il_idom1 > il_idom2 )THEN
! east part bigger than west part
- CALL logger_trace("DEFINE POLE NO OVERLAP: east part bigger than west part ")
+ CALL logger_trace("DOM SIZE POLE NO OVERLAP: east part bigger than west part ")
! to respect symmetry around canadian bipole
td_dom%i_imin = il_mid - il_idom1
@@ -1120,12 +1245,11 @@
td_dom%t_dim(1)%i_len = il_idom1 + 1
td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmin ) + 1 ) + &
+ & td_dom%i_jmin + 1 ) + &
& ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmax ) + 1 ) &
+ & td_dom%i_jmin + 1 ) &
& - 2 - 2 * td_dom%i_pivot ! remove north fold condition ?
! add ghost cell
- td_dom%i_ighost=1
- td_dom%i_jghost=1
+ td_dom%i_ghost(:,:)=1
! periodicity
@@ -1134,5 +1258,5 @@
ELSE ! il_idom2 >= il_idom1
! west part bigger than east part
- CALL logger_trace("DEFINE POLE NO OVERLAP: west part bigger than east part ")
+ CALL logger_trace("DOM SIZE POLE NO OVERLAP: west part bigger than east part ")
! to respect symmetry around canadian bipole
@@ -1141,12 +1265,11 @@
td_dom%t_dim(1)%i_len = il_idom2 + 1
td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmin ) + 1 ) + &
+ & td_dom%i_jmin + 1 ) + &
& ( td_dom%t_dim0(2)%i_len - &
- & ( td_dom%i_jmax ) + 1 ) &
+ & td_dom%i_jmax + 1 ) &
& - 2 - 2 * td_dom%i_pivot ! remove north fold condition ?
! add ghost cell
- td_dom%i_ighost=1
- td_dom%i_jghost=1
+ td_dom%i_ghost(:,:)=1
! periodicity
@@ -1157,121 +1280,24 @@
END SUBROUTINE dom__size_pole_no_overlap
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function get east west overlap.
- !
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine add extra bands to coarse domain to get enough point for
+ !> interpolation...
+ !>
!> @details
- !> If no east -west wrap return -1,
- !> else return the size of the ovarlap band
- !
- !> @author J.Paul
- !> - 2013- Initial Version
- !
- !> @param[in]
- !-------------------------------------------------------------------
- !> @code
- FUNCTION dom_get_ew_overlap(td_lon)
- IMPLICIT NONE
- ! Argument
- TYPE(TVAR), INTENT(IN) :: td_lon
-
- ! function
- INTEGER(i4) :: dom_get_ew_overlap
-
- ! local variable
- REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
- REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_lone
- REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_lonw
-
- REAL(dp) :: dl_delta
- REAL(dp) :: dl_lonmax
- REAL(dp) :: dl_lonmin
-
- INTEGER(i4) :: il_east
- INTEGER(i4) :: il_west
- INTEGER(i4) :: il_jmin
- INTEGER(i4) :: il_jmax
-
- INTEGER(i4), PARAMETER :: ip_max_overlap = 5
-
- ! loop indices
- INTEGER(i4) :: ji
- !----------------------------------------------------------------
- ! init
- dom_get_ew_overlap=-1
-
- il_west=1
- il_east=td_lon%t_dim(1)%i_len
-
- ALLOCATE( dl_value(td_lon%t_dim(1)%i_len, &
- & td_lon%t_dim(2)%i_len, &
- & td_lon%t_dim(3)%i_len, &
- & td_lon%t_dim(4)%i_len) )
-
- dl_value(:,:,:,:)=td_lon%d_value(:,:,:,:)
- WHERE( dl_value(:,:,:,:) > 180._dp .AND. &
- & dl_value(:,:,:,:) /= td_lon%d_fill )
- dl_value(:,:,:,:)=360.-dl_value(:,:,:,:)
- END WHERE
-
- ! we do not use jmax as dimension length due to north fold boundary
- il_jmin=1+ig_ghost
- il_jmax=(td_lon%t_dim(2)%i_len-ig_ghost)/2
-
- ALLOCATE( dl_lone(il_jmax-il_jmin+1) )
- ALLOCATE( dl_lonw(il_jmax-il_jmin+1) )
-
- dl_lone(:)=dl_value(il_east,il_jmin:il_jmax,1,1)
- dl_lonw(:)=dl_value(il_west,il_jmin:il_jmax,1,1)
-
- IF( .NOT.( ALL(dl_lone(:)==td_lon%d_fill) .AND. &
- & ALL(dl_lonw(:)==td_lon%d_fill) ) )THEN
-
- dl_lonmax=MAXVAL(dl_value(:,il_jmin:il_jmax,:,:))
- dl_lonmin=MINVAL(dl_value(:,il_jmin:il_jmax,:,:))
-
- dl_delta=(dl_lonmax-dl_lonmin)/td_lon%t_dim(1)%i_len
-
- IF( ALL(ABS(dl_lone(:)) - ABS(dl_lonw(:)) == dl_delta) )THEN
-
- dom_get_ew_overlap=0
-
- ELSE IF( ALL( ABS(dl_lone(:)) - ABS(dl_lonw(:)) < &
- & ip_max_overlap*dl_delta ) )THEN
- DO ji=0,ip_max_overlap
-
- IF( il_east-ji == il_west )THEN
- ! case of small domain
- EXIT
- ELSE
- dl_lone(:)=dl_value(il_east-ji,il_jmin:il_jmax,1,1)
-
- IF( ALL( dl_lonw(:) == dl_lone(:) ) )THEN
- dom_get_ew_overlap=ji+1
- EXIT
- ENDIF
- ENDIF
-
- ENDDO
- ENDIF
-
- ENDIF
-
- DEALLOCATE( dl_value )
-
- END FUNCTION dom_get_ew_overlap
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine add extra point to domain
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_dom : domain strcuture
- !> @param [in] id_iext : i-direction size of extra bands (default=im_minext)
- !> @param [in] id_jext : j-direction size of extra bands (default=im_minext)
- !-------------------------------------------------------------------
- !> @code
+ !> - domain periodicity is take into account.
+ !> - domain indices are changed, and size of extra bands are saved.
+ !> - optionaly, i- and j- direction size of extra bands could be specify
+ !> (default=im_minext)
+ !>
+ !> @author J.Paul
+ !> @date November, 2013
+ !> @date September, 2014
+ !> - take into account number of ghost cell
+ !
+ !> @param[inout] td_dom domain strcuture
+ !> @param [in] id_iext i-direction size of extra bands (default=im_minext)
+ !> @param [in] id_jext j-direction size of extra bands (default=im_minext)
+ !-------------------------------------------------------------------
SUBROUTINE dom_add_extra( td_dom, id_iext, id_jext )
IMPLICIT NONE
@@ -1288,5 +1314,4 @@
!----------------------------------------------------------------
! init
- !WARNING: two extrabands are required for cubic interpolation
il_iext=im_minext
IF( PRESENT(id_iext) ) il_iext=id_iext
@@ -1305,4 +1330,5 @@
! nothing to be done
ELSE
+
IF( td_dom%i_imin == 1 .AND. &
& td_dom%i_imax == td_dom%t_dim0(1)%i_len )THEN
@@ -1310,71 +1336,105 @@
! nothing to be done
ELSE
- IF( td_dom%i_imin /= 1 )THEN
- td_dom%i_iextra(1)=il_iext
-
- ELSE
- IF( td_dom%i_ew0 > 0 )THEN
- td_dom%i_iextra(1)=il_iext
-
+ IF( td_dom%i_ew0 < 0 )THEN
+ ! EW not cyclic
+ IF( td_dom%i_imin - il_iext > td_dom%i_ghost0(jp_I,1)*ip_ghost )THEN
+ td_dom%i_iextra(1) = il_iext
+ td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1)
+ ELSE ! td_dom%i_imin - il_iext <= td_dom%i_ghost0(jp_I,1)*ip_ghost
+ td_dom%i_iextra(1) = MIN(0, &
+ & td_dom%i_imin - &
+ & td_dom%i_ghost0(jp_I,1)*ip_ghost -1)
+ td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1)
ENDIF
+
+ IF( td_dom%i_imax + il_iext < &
+ & td_dom%t_dim0(1)%i_len - td_dom%i_ghost0(jp_I,2)*ip_ghost )THEN
+ td_dom%i_iextra(2) = il_iext
+ td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2)
+ ELSE ! td_dom%i_imax + il_iext >= &
+ ! td_dom%t_dim0(1)%i_len - td_dom%i_ghost0(jp_I,2)*ip_ghost
+ td_dom%i_iextra(2) = MIN(0, &
+ & td_dom%t_dim0(1)%i_len - &
+ & td_dom%i_ghost0(jp_I,2)*ip_ghost - &
+ & td_dom%i_imax )
+ td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2)
+ ENDIF
+
+ ELSE ! td_dom%i_ew0 >= 0
+ ! EW cyclic
+ IF( td_dom%i_imin - il_iext > 0 )THEN
+ td_dom%i_iextra(1) = il_iext
+ td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1)
+ ELSE ! td_dom%i_imin - il_iext <= 0
+ td_dom%i_iextra(1) = il_iext
+ td_dom%i_imin = td_dom%t_dim0(1)%i_len + &
+ & td_dom%i_imin - td_dom%i_iextra(1) -&
+ & td_dom%i_ew0
+ ENDIF
+
+ IF( td_dom%i_imax + il_iext <= td_dom%t_dim0(1)%i_len )THEN
+ td_dom%i_iextra(2) = il_iext
+ td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2)
+ ELSE ! td_dom%i_imax + il_iext > td_dom%t_dim0(1)%i_len
+ td_dom%i_iextra(2) = il_iext
+ td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2) - &
+ & (td_dom%t_dim0(1)%i_len-td_dom%i_ew0)
+ ENDIF
ENDIF
- IF( td_dom%i_imax /= td_dom%t_dim(1)%i_len )THEN
- td_dom%i_iextra(2)=1
-
- ELSE
- IF( td_dom%i_ew0 > 0 )THEN
- td_dom%i_iextra(2)=il_jext
-
- ENDIF
+ ENDIF
+
+ IF( td_dom%i_jmin == 1 .AND. &
+ & td_dom%i_jmax == td_dom%t_dim0(2)%i_len )THEN
+ ! nothing to be done
+ ELSE
+ IF( td_dom%i_jmin - il_jext > td_dom%i_ghost0(jp_J,1)*ip_ghost )THEN
+ td_dom%i_jextra(1) = il_jext
+ td_dom%i_jmin = td_dom%i_jmin - td_dom%i_jextra(1)
+ ELSE ! td_dom%i_jmin - il_jext <= td_dom%i_ghost0(jp_J,1)*ip_ghost
+ td_dom%i_jextra(1) = MIN(0, &
+ & td_dom%i_jmin - &
+ & td_dom%i_ghost0(jp_J,1)*ip_ghost - 1)
+ td_dom%i_jmin = td_dom%i_jmin - td_dom%i_jextra(1)
ENDIF
- ENDIF
-
- IF( td_dom%i_jmin == td_dom%i_jmax )THEN
- td_dom%i_jextra(1)=il_iext
- td_dom%i_jextra(2)=il_jext
-
- ELSE
- IF( td_dom%i_jmin /= 1)THEN
- td_dom%i_jextra(1)=il_iext
-
+ IF( td_dom%i_jmax + il_jext < &
+ & td_dom%t_dim0(2)%i_len - td_dom%i_ghost0(jp_J,2)*ip_ghost )THEN
+ td_dom%i_jextra(2) = il_jext
+ td_dom%i_jmax = td_dom%i_jmax + td_dom%i_jextra(2)
+ ELSE ! td_dom%i_jmax + il_jext >= &
+ ! td_dom%t_dim0(2)%i_len - td_dom%i_ghost0(jp_J,2)*ip_ghost
+ td_dom%i_jextra(2) = MIN(0, &
+ & td_dom%t_dim0(2)%i_len - &
+ & td_dom%i_ghost0(jp_J,2)*ip_ghost - &
+ & td_dom%i_jmax )
+ td_dom%i_jmax = td_dom%i_jmax + td_dom%i_jextra(2)
ENDIF
- IF( td_dom%i_jmax /= td_dom%t_dim(2)%i_len )THEN
- td_dom%i_jextra(2)=il_jext
-
- ENDIF
-
- ENDIF
-
- ENDIF
-
- ! change domain
- td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1)
- td_dom%i_jmin = td_dom%i_jmin - td_dom%i_jextra(1)
-
- td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2)
- td_dom%i_jmax = td_dom%i_jmax + td_dom%i_jextra(2)
-
- td_dom%t_dim(1)%i_len = td_dom%t_dim(1)%i_len + &
- & td_dom%i_iextra(1) + &
- & td_dom%i_iextra(2)
- td_dom%t_dim(2)%i_len = td_dom%t_dim(2)%i_len + &
- & td_dom%i_jextra(1) + &
- & td_dom%i_jextra(2)
+ ENDIF
+
+ ENDIF
+
+ IF( td_dom%i_imin <= td_dom%i_imax )THEN
+ td_dom%t_dim(1)%i_len = td_dom%i_imax - td_dom%i_imin +1
+ ELSE ! td_dom%i_imin > td_dom%i_imax
+ td_dom%t_dim(1)%i_len = td_dom%i_imax + &
+ & td_dom%t_dim0(1)%i_len - td_dom%i_imin + 1 - &
+ & td_dom%i_ew0 ! remove overlap
+ ENDIF
+
+ td_dom%t_dim(2)%i_len = td_dom%i_jmax-td_dom%i_jmin+1
END SUBROUTINE dom_add_extra
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine clean domain structure. it remove extra point added.
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> This subroutine clean coarse grid domain structure.
+ !> it remove extra point added.
+ !
+ !> @author J.Paul
+ !> @date November, 2013
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom_clean_extra( td_dom )
IMPLICIT NONE
@@ -1404,24 +1464,34 @@
END SUBROUTINE dom_clean_extra
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_var : variable strcuture
- !> @param[inout] td_dom : domain strcuture
- !> @param[inout] id_rhoi : i-direction refinement factor
- !> @param[inout] id_rhoj : j-direction refinement factor
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE dom_del_extra( td_var, td_dom, id_rho )
- IMPLICIT NONE
- ! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_var
- TYPE(TDOM) , INTENT(IN ) :: td_dom
- INTEGER(i4), DIMENSION(:), INTENT(IN ) :: id_rho
+ !> This subroutine delete extra band, from fine grid variable value,
+ !> and dimension, taking into account refinement factor.
+ !>
+ !> @details
+ !> @note This subroutine should be used before clean domain structure.
+ !>
+ !> @warning if work on coordinates grid, do not remove all extra point.
+ !> save value on ghost cell.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013
+ !> @date September, 2014
+ !> - take into account boundary for one point size domain
+ !> @date December, 2014
+ !> - add special case for coordinates file.
+ !
+ !> @param[inout] td_var variable strcuture
+ !> @param[in] td_dom domain strcuture
+ !> @param[in] id_rho array of refinement factor
+ !> @param[in] ld_coord work on coordinates file or not
+ !-------------------------------------------------------------------
+ SUBROUTINE dom_del_extra( td_var, td_dom, id_rho, ld_coord )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
+ TYPE(TDOM) , INTENT(IN ) :: td_dom
+ INTEGER(i4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_rho
+ LOGICAL , INTENT(IN ), OPTIONAL :: ld_coord
! local variable
@@ -1434,8 +1504,23 @@
INTEGER(i4) :: il_jmax
- REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
-
+ INTEGER(i4), DIMENSION(2) :: il_rho
+ INTEGER(i4), DIMENSION(2,2) :: il_ghost
+
+ REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
+
+ LOGICAL :: ll_coord
! loop indices
!----------------------------------------------------------------
+
+ IF( PRESENT(id_rho) )THEN
+ ! work on coarse grid
+ il_rho(:)=id_rho(jp_I:jp_J)
+ ELSE
+ ! work on fine grid
+ il_rho(:)=1
+ ENDIF
+
+ ll_coord=.false.
+ IF( PRESENT(ld_coord) ) ll_coord=ld_coord
IF( .NOT. ASSOCIATED(td_var%d_value) )THEN
@@ -1443,8 +1528,6 @@
& "variable "//TRIM(td_var%c_name) )
ELSE
- ! get vairbale right domain
+ ! get variable right domain
IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
- il_iextra=SUM(td_dom%i_iextra(:))*id_rho(jp_I)
- il_jextra=SUM(td_dom%i_jextra(:))*id_rho(jp_J)
ALLOCATE(dl_value(td_var%t_dim(1)%i_len, &
@@ -1454,12 +1537,161 @@
dl_value(:,:,:,:)=td_var%d_value(:,:,:,:)
- il_imin=1 + td_dom%i_iextra(1)*id_rho(jp_I)
- il_imax=td_var%t_dim(1)%i_len - td_dom%i_iextra(2)*id_rho(jp_I)
-
- il_jmin=1 + td_dom%i_jextra(1)*id_rho(jp_J)
- il_jmax=td_var%t_dim(2)%i_len - td_dom%i_jextra(2)*id_rho(jp_J)
-
- td_var%t_dim(1)%i_len=td_var%t_dim(1)%i_len-il_iextra
- td_var%t_dim(2)%i_len=td_var%t_dim(2)%i_len-il_jextra
+ il_iextra=SUM(td_dom%i_iextra(:))*il_rho(jp_I)
+ il_jextra=SUM(td_dom%i_jextra(:))*il_rho(jp_J)
+
+ il_ghost(:,:)=0
+ IF( ll_coord )THEN
+ il_ghost(:,:)=td_dom%i_ghost(:,:)
+ ENDIF
+
+ IF( il_iextra >= td_var%t_dim(1)%i_len )THEN
+ ! case one point size dimension
+ SELECT CASE(td_dom%i_bdy)
+
+ CASE(jp_north,jp_east)
+
+ CALL logger_info("DOM DEL EXTRA: special case for north"//&
+ & " or east boundary.")
+ IF( td_dom%i_iextra(1) <= 0 )THEN
+ il_imin= 1
+ il_ghost(jp_I,1) = 0
+ ELSE
+ il_imin= 1 + (td_dom%i_iextra(1)-1)*il_rho(jp_I) + 1 &
+ & - il_ghost(jp_I,1)
+ ENDIF
+ IF( td_dom%i_iextra(2) <= 0 )THEN;
+ il_imax= td_var%t_dim(1)%i_len
+ il_ghost(jp_I,2) = 0
+ ELSE
+ il_imax= td_var%t_dim(1)%i_len - &
+ & td_dom%i_iextra(2)*il_rho(jp_I) &
+ & + il_ghost(jp_I,2)
+ ENDIF
+
+ CASE(jp_south,jp_west)
+
+ CALL logger_info("DOM DEL EXTRA: special case for south"//&
+ & " or west boundary.")
+ IF( td_dom%i_iextra(1) <= 0 )THEN
+ il_imin= 1
+ il_ghost(jp_I,1) = 0
+ ELSE
+ il_imin= 1 + td_dom%i_iextra(1)*il_rho(jp_I) &
+ & - il_ghost(jp_I,1)
+ ENDIF
+ IF( td_dom%i_iextra(2) <= 0 )THEN
+ il_imax= td_var%t_dim(1)%i_len
+ il_ghost(jp_I,2) = 0
+ ELSE
+ il_imax= td_var%t_dim(1)%i_len - &
+ & (td_dom%i_iextra(2)-1)*il_rho(jp_I) - 1 &
+ & + il_ghost(jp_I,2)
+ ENDIF
+
+ CASE DEFAULT
+
+ IF( MOD(il_iextra-td_var%t_dim(1)%i_len,2)==0 )THEN
+ ! case one point size dimension with even refinment
+ CALL logger_fatal("DOM DEL EXTRA: should have been"//&
+ & "an impossible case: domain of "//&
+ & " one point size and even refinment.")
+ ELSE
+ il_imin= 1 + &
+ & (td_dom%i_iextra(1)-1)*il_rho(jp_I) + &
+ & (il_rho(jp_I)-1)/2 + 1 &
+ & - il_ghost(jp_I,1)
+ il_imax= td_var%t_dim(1)%i_len - &
+ & (td_dom%i_iextra(2)-1)*il_rho(jp_I) - &
+ & (il_rho(jp_I)-1)/2 - 1 &
+ & + il_ghost(jp_I,2)
+ ENDIF
+
+ END SELECT
+
+ td_var%t_dim(1)%i_len = 1 + SUM(il_ghost(jp_I,:))
+
+ ELSE
+ ! general case
+ il_imin=1 + td_dom%i_iextra(1)*il_rho(jp_I) &
+ & - il_ghost(jp_I,1)
+ il_imax=td_var%t_dim(1)%i_len - td_dom%i_iextra(2)*il_rho(jp_I) &
+ & + il_ghost(jp_I,2)
+
+ td_var%t_dim(1)%i_len=td_var%t_dim(1)%i_len - il_iextra &
+ & + SUM(il_ghost(jp_I,:))
+ ENDIF
+
+ IF( il_jextra >= td_var%t_dim(2)%i_len )THEN
+ ! case one point size dimension
+ SELECT CASE(td_dom%i_bdy)
+
+ CASE(jp_north,jp_east)
+
+ IF( td_dom%i_jextra(1) <= 0 )THEN
+ il_jmin= 1
+ il_ghost(jp_J,1) = 0
+ ELSE
+ il_jmin= 1 + (td_dom%i_jextra(1)-1)*il_rho(jp_J) + 1 &
+ & - il_ghost(jp_J,1)
+ ENDIF
+ IF( td_dom%i_jextra(2) <= 0 )THEN
+ il_jmax= td_var%t_dim(2)%i_len
+ il_ghost(jp_J,2) = 0
+ ELSE
+ il_jmax= td_var%t_dim(2)%i_len - &
+ & td_dom%i_jextra(2)*il_rho(jp_J) &
+ & + il_ghost(jp_J,2)
+ ENDIF
+
+ CASE(jp_south,jp_west)
+
+ IF( td_dom%i_iextra(2) <= 0 )THEN
+ il_jmin= 1
+ il_ghost(jp_J,1) = 0
+ ELSE
+ il_jmin= 1 + td_dom%i_jextra(1)*il_rho(jp_J) &
+ & - il_ghost(jp_J,1)
+ ENDIF
+ IF( td_dom%i_jextra(2) <= 0 )THEN
+ il_jmax= td_var%t_dim(2)%i_len
+ il_ghost(jp_J,2) = 0
+ ELSE
+ il_jmax= td_var%t_dim(2)%i_len - &
+ & (td_dom%i_jextra(2)-1)*il_rho(jp_J) - 1 &
+ & + il_ghost(jp_J,2)
+ ENDIF
+
+ CASE DEFAULT
+
+ IF( MOD(il_jextra-td_var%t_dim(2)%i_len,2)==0 )THEN
+ ! case one point size dimension with even refinment
+ CALL logger_fatal("DOM DEL EXTRA: should have been"//&
+ & "an impossible case: domain of "//&
+ & " one point size and even refinment.")
+ ELSE
+ il_jmin= 1 + &
+ & (td_dom%i_jextra(1)-1)*il_rho(jp_J) + &
+ & (il_rho(jp_J)-1)/2 + 1 &
+ & - il_ghost(jp_J,1)
+ il_jmax= td_var%t_dim(2)%i_len - &
+ & (td_dom%i_jextra(2)-1)*il_rho(jp_J) - &
+ & (il_rho(jp_J)-1)/2 - 1 &
+ & + il_ghost(jp_J,2)
+ ENDIF
+
+ END SELECT
+
+ td_var%t_dim(2)%i_len = 1 + SUM(il_ghost(jp_J,:))
+
+ ELSE
+ ! general case
+ il_jmin=1 + td_dom%i_jextra(1)*il_rho(jp_J) &
+ & - il_ghost(jp_J,1)
+ il_jmax=td_var%t_dim(2)%i_len - td_dom%i_jextra(2)*il_rho(jp_J) &
+ & + il_ghost(jp_J,2)
+
+ td_var%t_dim(2)%i_len= td_var%t_dim(2)%i_len - il_jextra &
+ & + SUM(il_ghost(jp_J,:))
+ ENDIF
DEALLOCATE(td_var%d_value)
@@ -1478,15 +1710,13 @@
END SUBROUTINE dom_del_extra
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine clean mpp strcuture.
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> This subroutine clean domain structure.
+ !
+ !> @author J.Paul
+ !> @date November, 2013
+ !
+ !> @param[inout] td_dom domain strcuture
+ !-------------------------------------------------------------------
SUBROUTINE dom_clean( td_dom )
IMPLICIT NONE
@@ -1495,5 +1725,5 @@
! local variable
- TYPE(TDOM) :: tl_dom ! empty file structure
+ TYPE(TDOM) :: tl_dom ! empty dom structure
! loop indices
@@ -1501,5 +1731,5 @@
!----------------------------------------------------------------
- CALL logger_info( " CLEAN: reset domain " )
+ CALL logger_info( "DOM CLEAN: reset domain " )
! del dimension
@@ -1511,4 +1741,4 @@
td_dom=tl_dom
- END SUBROUTINE dom_clean
+ END SUBROUTINE dom_clean
END MODULE dom
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/extrap.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/extrap.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/extrap.f90 (revision 5214)
@@ -7,7 +7,86 @@
! DESCRIPTION:
!> @brief
-!> This module
+!> This module manage extrapolation.
!>
!> @details
+!> Extrapolation method to be used is specify inside variable
+!> strcuture, as array of string character.
+!> - td_var\%c_extrap(1) string character is the interpolation name choose between:
+!> - 'dist_weight'
+!> - 'min_error'
+!>
+!> @note Extrapolation method could be specify for each variable in namelist _namvar_,
+!> defining string character _cn\_varinfo_. By default _dist_weight_.
+!> Example:
+!> - cn_varinfo='varname1:dist_weight', 'varname2:min_error'
+!>
+!> to detect point to be extrapolated:
+!> @code
+!> il_detect(:,:,:)=extrap_detect(td_var, [td_level], [id_offset,] [id_rho,] [id_ext])
+!> @endcode
+!> - il_detect(:,:,:) is 3D array of point to be extrapolated
+!> - td_var is coarse grid variable to be extrapolated
+!> - td_level is fine grid array of level (see vgrid_get_level) [optional]
+!> - id_offset is array of offset between fine and coarse grid [optional]
+!> - id_rho is array of refinment factor [optional]
+!> - id_ext is array of number of points to be extrapolated [optional]
+!>
+!> to extrapolate variable:
+!> @code
+!> CALL extrap_fill_value( td_var, [td_level], [id_offset], [id_rho], [id_iext], [id_jext], [id_kext], [id_radius], [id_maxiter])
+!> @endcode
+!> - td_var is coarse grid variable to be extrapolated
+!> - td_level is fine grid array of level (see vgrid_get_level) [optional]
+!> - id_offset is array of offset between fine and coarse grid [optional]
+!> - id_rho is array of refinment factor [optional]
+!> - id_iext is number of points to be extrapolated in i-direction [optional]
+!> - id_jext is number of points to be extrapolated in j-direction [optional]
+!> - id_kext is number of points to be extrapolated in k-direction [optional]
+!> - id_radius is radius of the halo used to compute extrapolation [optional]
+!> - id_maxiter is maximum number of iteration [optional]
+!>
+!> to add extraband to the variable (to be extrapolated):
+!> @code
+!> CALL extrap_add_extrabands(td_var, [id_isize,] [id_jsize] )
+!> @endcode
+!> - td_var is variable structure
+!> - id_isize : i-direction size of extra bands [optional]
+!> - id_jsize : j-direction size of extra bands [optional]
+!>
+!> to delete extraband of a variable:
+!> @code
+!> CALL extrap_del_extrabands(td_var, [id_isize,] [id_jsize] )
+!> @endcode
+!> - td_var is variable structure
+!> - id_isize : i-direction size of extra bands [optional]
+!> - id_jsize : j-direction size of extra bands [optional]
+!>
+!> to compute first derivative of 1D array:
+!> @code
+!> dl_value(:)=extrap_deriv_1D( dd_value(:), dd_fill, [ld_discont] )
+!> @endcode
+!> - dd_value is 1D array of variable
+!> - dd_fill is FillValue of variable
+!> - ld_discont is logical to take into account longitudinal East-West discontinuity [optional]
+!>
+!> to compute first derivative of 2D array:
+!> @code
+!> dl_value(:,:)=extrap_deriv_2D( dd_value(:,:), dd_fill, cd_dim, [ld_discont] )
+!> @endcode
+!> - dd_value is 2D array of variable
+!> - dd_fill is FillValue of variable
+!> - cd_dim is character to compute derivative on first (I) or second (J) dimension
+!> - ld_discont is logical to take into account longitudinal East-West discontinuity [optional]
+!>
+!> to compute first derivative of 3D array:
+!> @code
+!> dl_value(:,:,:)=extrap_deriv_3D( dd_value(:,:,:), dd_fill, cd_dim, [ld_discont] )
+!> @endcode
+!> - dd_value is 3D array of variable
+!> - dd_fill is FillValue of variable
+!> - cd_dim is character to compute derivative on first (I), second (J), or third (K) dimension
+!> - ld_discont is logical to take into account longitudinal East-West discontinuity [optional]
+!>
+!> @warning _FillValue must not be zero (use var_chg_FillValue())
!>
!> @author
@@ -15,47 +94,50 @@
! REVISION HISTORY:
!> @date Nov, 2013 - Initial Version
+!> @date September, 2014
+!> - add header
!>
-!> @note WARNING: FillValue must not be zero (use var_chg_FillValue)
+!> @todo
+!> - create module for each extrapolation method
!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!> @todo
-!> - something wrong when computing point to be extralopated
-!> - take care of ew value in variable structure
!----------------------------------------------------------------------
MODULE extrap
USE netcdf ! nf90 library
- USE kind
- USE phycst
- USE global
- USE fct
- USE logger
- USE dim
- USE att
- USE var
+ USE kind ! F90 kind parameter
+ USE phycst ! physical constant
+ USE global ! global variable
+ USE fct ! basic useful function
+ USE date ! date manager
+ USE logger ! log file manager
+ USE att ! attribute manager
+ USE dim ! dimension manager
+ USE var ! variable manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! type and variable
+ PRIVATE :: im_maxiter !< default maximum number of iteration
+ PRIVATE :: im_minext !< default minumum number of point to extrapolate
+ PRIVATE :: im_mincubic !< default minumum number of point to extrapolate for cubic interpolation
! function and subroutine
PUBLIC :: extrap_detect !< detected point to be extrapolated
PUBLIC :: extrap_fill_value !< extrapolate value over detected point
- PUBLIC :: extrap_add_extrabands !<
- PUBLIC :: extrap_del_extrabands !<
- PUBLIC :: extrap_deriv_1D !<
- PUBLIC :: extrap_deriv_2D !<
-
- PRIVATE :: extrap__detect_wrapper !< detected point to be extrapolated
- PRIVATE :: extrap__detect !< detected point to be extrapolated
- PRIVATE :: extrap__fill_value_wrapper !< extrapolate value over detected point
- PRIVATE :: extrap__fill_value !< extrapolate value over detected point
- PRIVATE :: extrap__3D
- PRIVATE :: extrap_deriv_3D
- PRIVATE :: extrap__3D_min_error_coef
- PRIVATE :: extrap__3D_min_error_fill
- PRIVATE :: extrap__3D_dist_weight_coef
- PRIVATE :: extrap__3D_dist_weight_fill
+ PUBLIC :: extrap_add_extrabands !< add extraband to the variable (to be extrapolated)
+ PUBLIC :: extrap_del_extrabands !< delete extraband of the variable
+ PUBLIC :: extrap_deriv_1D !< compute first derivative of 1D array
+ PUBLIC :: extrap_deriv_2D !< compute first derivative of 2D array
+ PUBLIC :: extrap_deriv_3D !< compute first derivative of 3D array
+
+ PRIVATE :: extrap__detect_wrapper ! detected point to be extrapolated wrapper
+ PRIVATE :: extrap__detect ! detected point to be extrapolated
+ PRIVATE :: extrap__fill_value_wrapper ! extrapolate value over detected point wrapper
+ PRIVATE :: extrap__fill_value ! extrapolate value over detected point
+ PRIVATE :: extrap__3D !
+ PRIVATE :: extrap__3D_min_error_coef !
+ PRIVATE :: extrap__3D_min_error_fill !
+ PRIVATE :: extrap__3D_dist_weight_coef !
+ PRIVATE :: extrap__3D_dist_weight_fill !
INTEGER(i4), PARAMETER :: im_maxiter = 10 !< default maximum number of iteration
@@ -64,5 +146,5 @@
INTERFACE extrap_detect
- MODULE PROCEDURE extrap__detect_wrapper !< detected point to be extrapolated
+ MODULE PROCEDURE extrap__detect_wrapper !< detected point to be extrapolated
END INTERFACE extrap_detect
@@ -74,23 +156,33 @@
!-------------------------------------------------------------------
!> @brief
- !> This function detected point to be extrapolated.
+ !> This function detected point to be extrapolated, given variable structure.
!>
!> @details
+ !> optionaly, you could sepcify fine grid level, refinment factor (default 1),
+ !> offset between fine and coarse grid (default compute from refinment factor
+ !> as offset=(rho-1)/2), number of point to be extrapolated in each direction
+ !> (default im_minext).
!>
+ !> First coarsening fine grid level, if need be, then select point near
+ !> grid point already inform.
+ !>
+ !> @note point to be extrapolated are selected using FillValue,
+ !> so to avoid mistake FillValue should not be zero (use var_chg_FillValue)
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
- !> @param[in] td_var : variable to extrapolate
- !> @param[in] id_iext : number of points to be extrapolated in i-direction
- !> @param[in] id_jext : number of points to be extrapolated in j-direction
- !> @param[in] id_kext : number of points to be extrapolated in k-direction
- !> @return
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] td_var0 coarse grid variable to extrapolate
+ !> @param[in] td_level1 fine grid array of level
+ !> @param[in] id_offset array of offset between fine and coarse grid
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] id_ext array of number of points to be extrapolated
+ !> @return array of point to be extrapolated
+ !-------------------------------------------------------------------
FUNCTION extrap__detect( td_var0, td_level1, &
& id_offset, id_rho, id_ext )
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_var0
+ TYPE(TVAR) , INTENT(IN ) :: td_var0
TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level1
INTEGER(i4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset
@@ -106,6 +198,7 @@
CHARACTER(LEN=lc) :: cl_level
- INTEGER(i4) :: il_varid
+ INTEGER(i4) :: il_ind
INTEGER(i4) , DIMENSION(:,:,:), ALLOCATABLE :: il_detect
+ INTEGER(i4) , DIMENSION(:,:,:), ALLOCATABLE :: il_tmp
INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_offset
INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_level1
@@ -143,9 +236,10 @@
ALLOCATE( il_offset(ip_maxdim,2) )
il_offset(:,:)=0
- il_offset(jp_I,:)=FLOOR(REAL(il_rho(jp_I)-1,dp)*0.5)
- il_offset(jp_J,:)=FLOOR(REAL(il_rho(jp_J)-1,dp)*0.5)
IF( PRESENT(id_offset) )THEN
il_offset(1:SIZE(id_offset(:,:),DIM=1),&
& 1:SIZE(id_offset(:,:),DIM=2) )= id_offset(:,:)
+ ELSE
+ il_offset(jp_I,:)=FLOOR(REAL(il_rho(jp_I)-1,dp)*0.5)
+ il_offset(jp_J,:)=FLOOR(REAL(il_rho(jp_J)-1,dp)*0.5)
ENDIF
@@ -160,19 +254,26 @@
! select point already inform
- WHERE( td_var0%d_value(:,:,:,1) /= td_var0%d_fill ) il_detect(:,:,:)=1
+ DO jk0=1,td_var0%t_dim(3)%i_len
+ DO jj0=1,td_var0%t_dim(2)%i_len
+ DO ji0=1,td_var0%t_dim(1)%i_len
+ IF( td_var0%d_value(ji0,jj0,jk0,1) /= td_var0%d_fill ) il_detect(ji0,jj0,jk0)=1
+ ENDDO
+ ENDDO
+ ENDDO
IF( PRESENT(td_level1) )THEN
SELECT CASE(TRIM(td_var0%c_point))
- CASE DEFAULT !'T'
- cl_level='tlevel'
- CASE('U')
- cl_level='ulevel'
- CASE('V')
- cl_level='vlevel'
- CASE('F')
- cl_level='flevel'
+ CASE DEFAULT !'T'
+ cl_level='tlevel'
+ CASE('U')
+ cl_level='ulevel'
+ CASE('V')
+ cl_level='vlevel'
+ CASE('F')
+ cl_level='flevel'
END SELECT
- il_varid=var_get_id(td_level1(:),TRIM(cl_level))
- IF( il_varid == 0 )THEN
+
+ il_ind=var_get_index(td_level1(:),TRIM(cl_level))
+ IF( il_ind == 0 )THEN
CALL logger_error("EXTRAP DETECT: can not compute point to be "//&
& "extrapolated for variable "//TRIM(td_var0%c_name)//&
@@ -180,84 +281,66 @@
& "level for variable point "//TRIM(TRIM(td_var0%c_point)))
ELSE
- print *,'read ',trim(cl_level)
- tl_var1=td_level1(il_varid)
+ tl_var1=var_copy(td_level1(il_ind))
+
+ ALLOCATE( il_level1_G0( il_dim0(1), il_dim0(2)) )
+ IF( ALL(tl_var1%t_dim(1:2)%i_len == il_dim0(1:2)) )THEN
+
+ ! variable to be extrapolated use same resolution than level
+ il_level1_G0(:,:)=INT(tl_var1%d_value(:,:,1,1),i4)
+
+ ELSE
+ ! variable to be extrapolated do not use same resolution than level
+ ALLOCATE( il_level1(tl_var1%t_dim(1)%i_len, &
+ & tl_var1%t_dim(2)%i_len) )
+ ! match fine grid vertical level with coarse grid
+ il_level1(:,:)=INT(tl_var1%d_value(:,:,1,1),i4)/il_rho(jp_K)
+
+ ALLOCATE( il_extra(ip_maxdim,2) )
+ ! coarsening fine grid level
+ il_extra(jp_I,1)=CEILING(REAL(il_rho(jp_I)-1,dp)*0.5_dp)
+ il_extra(jp_I,2)=FLOOR(REAL(il_rho(jp_I)-1,dp)*0.5_dp)
+
+ il_extra(jp_J,1)=CEILING(REAL(il_rho(jp_J)-1,dp)*0.5_dp)
+ il_extra(jp_J,2)=FLOOR(REAL(il_rho(jp_J)-1,dp)*0.5_dp)
+
+ DO jj0=1,td_var0%t_dim(2)%i_len
+
+ jj1=(jj0-1)*il_rho(jp_J)+1-il_offset(jp_J,1)
+
+ jj1m=MAX( jj1-il_extra(jp_J,1), 1 )
+ jj1p=MIN( jj1+il_extra(jp_J,2), &
+ & tl_var1%t_dim(2)%i_len-il_offset(jp_J,2) )
+
+ DO ji0=1,td_var0%t_dim(1)%i_len
+
+ ji1=(ji0-1)*il_rho(jp_I)+1-id_offset(jp_I,1)
+
+ ji1m=MAX( ji1-il_extra(jp_I,1), 1 )
+ ji1p=MIN( ji1+il_extra(jp_I,2), &
+ & tl_var1%t_dim(1)%i_len-id_offset(jp_I,2) )
+
+ il_level1_G0(ji0,jj0)=MAXVAL(il_level1(ji1m:ji1p,jj1m:jj1p))
+
+ ENDDO
+ ENDDO
+
+ ! clean
+ DEALLOCATE( il_extra )
+ DEALLOCATE( il_level1 )
+
+ ENDIF
+
+ ! look for sea point
+ DO jk0=1,td_var0%t_dim(3)%i_len
+ WHERE( il_level1_G0(:,:) >= jk0)
+ il_detect(:,:,jk0)=1
+ END WHERE
+ ENDDO
+
+ ! clean
+ DEALLOCATE( il_level1_G0 )
+ CALL var_clean(tl_var1)
+
ENDIF
-
- ALLOCATE( il_level1_G0( il_dim0(1), il_dim0(2)) )
- IF( ALL(tl_var1%t_dim(1:2)%i_len == il_dim0(1:2)) )THEN
-
- ! variable to be extrapolated use same resolution than level
- il_level1_G0(:,:)=INT(tl_var1%d_value(:,:,1,1),i4)
-
- ELSE
- ! variable to be extrapolated do not use same resolution than level
- ALLOCATE( il_level1(tl_var1%t_dim(1)%i_len, &
- & tl_var1%t_dim(2)%i_len) )
- ! match fine grid vertical level with coarse grid
- il_level1(:,:)=INT(tl_var1%d_value(:,:,1,1),i4)/il_rho(jp_K)
-
- ALLOCATE( il_extra(ig_ndim,2) )
- ! coarsening fine grid level
- il_extra(jp_I,1)=CEILING(REAL(il_rho(jp_I)-1,dp)/2._dp)
- il_extra(jp_I,2)=FLOOR(REAL(il_rho(jp_I)-1,dp)/2._dp)
-
- il_extra(jp_J,1)=CEILING(REAL(il_rho(jp_J)-1,dp)/2._dp)
- il_extra(jp_J,2)=FLOOR(REAL(il_rho(jp_J)-1,dp)/2._dp)
-
- DO jj0=1,td_var0%t_dim(2)%i_len
-
- jj1=(jj0-1)*il_rho(jp_J)+1-il_offset(jp_J,1)
-
- jj1m=MAX( jj1-il_extra(jp_J,1), 1 )
- jj1p=MIN( jj1+il_extra(jp_J,2), &
- & tl_var1%t_dim(2)%i_len-il_offset(jp_J,2) )
-
- DO ji0=1,td_var0%t_dim(1)%i_len
-
- ji1=(ji0-1)*il_rho(jp_I)+1-id_offset(jp_I,1)
-
- ji1m=MAX( ji1-il_extra(jp_I,1), 1 )
- ji1p=MIN( ji1+il_extra(jp_I,2), &
- & tl_var1%t_dim(1)%i_len-id_offset(jp_I,2) )
-
- il_level1_G0(ji0,jj0)=MAXVAL(il_level1(ji1m:ji1p,jj1m:jj1p))
- ENDDO
- ENDDO
-
- !il_level1_G0(:,:)=0
- !DO jj1=1,tl_var1%t_dim(2)%i_len
-
- ! jj0=INT(REAL((jj1+il_offset(jp_J,1)-1)-1,dp)/REAL(il_rho(jp_J),dp)) +1
-
- ! DO ji1=1,tl_var1%t_dim(1)%i_len
-
- ! ji0=INT(REAL((ji1+il_offset(jp_I,1)-1)-1,dp)/REAL(il_rho(jp_I),dp)) +1
-
- ! il_level1_G0(ji0,jj0)=MAX(il_level1_G0(ji0,jj0),il_level1(ji1,jj1))
- !
- ! ENDDO
- !ENDDO
-
- ! clean
- DEALLOCATE( il_extra )
- DEALLOCATE( il_level1 )
-
- ENDIF
-
- ! look for sea point
- !il_detect(:,:,1)=0
- DO jk0=1,td_var0%t_dim(3)%i_len
- WHERE( il_level1_G0(:,:) >= jk0)
- il_detect(:,:,jk0)=1
- END WHERE
- !il_detect(:,:,jk0)=il_level1_G0(:,:)
- !WHERE( td_var0%d_value(:,:,jk0,1) /= td_var0%d_fill )
- ! il_detect(:,:,1)=jk0-1
- !END WHERE
- ENDDO
-
- ! clean
- DEALLOCATE( il_level1_G0 )
-
ENDIF
@@ -265,19 +348,37 @@
DEALLOCATE( il_offset )
- !! select extra point depending on interpolation method
- !! compute point near grid point already inform
- !FORALL( ji0=1:il_dim0(1), &
- !& jj0=1:il_dim0(2), &
- !& jk0=1:il_dim0(3), &
- !& il_detect(ji0,jj0,jk0) == 1 )
-
- ! il_detect(MAX(1,ji0-il_ext(jp_I)):MIN(ji0+il_ext(jp_I),il_dim0(1)),&
- ! & MAX(1,jj0-il_ext(jp_J)):MIN(jj0+il_ext(jp_J),il_dim0(2)),&
- ! & MAX(1,jk0-il_ext(jp_K)):MIN(jk0+il_ext(jp_K),il_dim0(3)) )=1
-
- !END FORALL
+ ALLOCATE( il_tmp(il_dim0(1),&
+ & il_dim0(2),&
+ & il_dim0(3)) )
+ il_tmp(:,:,:)=il_detect(:,:,:)
+ ! select extra point depending on interpolation method
+ ! compute point near grid point already inform
+ DO jk0=1,il_dim0(3)
+ DO jj0=1,il_dim0(2)
+ DO ji0=1,il_dim0(1)
+
+ IF( il_tmp(ji0,jj0,jk0) == 1 )THEN
+ il_detect( &
+ & MAX(1,ji0-il_ext(jp_I)):MIN(ji0+il_ext(jp_I),il_dim0(1)),&
+ & MAX(1,jj0-il_ext(jp_J)):MIN(jj0+il_ext(jp_J),il_dim0(2)),&
+ & MAX(1,jk0-il_ext(jp_K)):MIN(jk0+il_ext(jp_K),il_dim0(3)) &
+ & ) = 1
+ ENDIF
+
+ ENDDO
+ ENDDO
+ ENDDO
+ ! clean
+ DEALLOCATE( il_tmp )
+
! do not compute grid point already inform
- WHERE( td_var0%d_value(:,:,:,1) /= td_var0%d_fill ) il_detect(:,:,:)=0
+ DO jk0=1,td_var0%t_dim(3)%i_len
+ DO jj0=1,td_var0%t_dim(2)%i_len
+ DO ji0=1,td_var0%t_dim(1)%i_len
+ IF( td_var0%d_value(ji0,jj0,jk0,1) /= td_var0%d_fill ) il_detect(ji0,jj0,jk0)=0
+ ENDDO
+ ENDDO
+ ENDDO
! save result
@@ -288,23 +389,22 @@
DEALLOCATE( il_ext )
DEALLOCATE( il_detect )
+ DEALLOCATE( il_rho )
END FUNCTION extrap__detect
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function detected point to be extrapolated.
+ !> This function sort variable to be extrapolated, depending on number of
+ !> dimentsion, then detected point to be extrapolated.
!>
- !> @details
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
!>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : variable to extrapolate
- !> @param[in] id_iext : number of points to be extrapolated in i-direction
- !> @param[in] id_jext : number of points to be extrapolated in j-direction
- !> @param[in] id_kext : number of points to be extrapolated in k-direction
- !> @return
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] td_var coarse grid variable to extrapolate
+ !> @param[in] td_level fine grid array of level
+ !> @param[in] id_offset array of offset between fine and coarse grid
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] id_ext array of number of points to be extrapolated
+ !> @return 3D array of point to be extrapolated
+ !-------------------------------------------------------------------
FUNCTION extrap__detect_wrapper( td_var, td_level, &
& id_offset, id_rho, id_ext )
@@ -312,6 +412,6 @@
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_var
- TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level
+ TYPE(TVAR) , INTENT(IN ) :: td_var
+ TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level
INTEGER(i4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset
INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho
@@ -335,5 +435,5 @@
ELSE IF( ALL(td_var%t_dim(1:3)%l_use) )THEN
- ! detect point to be interpolated on I-J-K
+ ! detect point to be extrapolated on I-J-K
CALL logger_debug(" EXTRAP DETECT: detect point "//&
& " for variable "//TRIM(td_var%c_name) )
@@ -346,5 +446,5 @@
ELSE IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
- ! detect point to be interpolated on I-J
+ ! detect point to be extrapolated on I-J
CALL logger_debug(" EXTRAP DETECT: detect horizontal point "//&
& " for variable "//TRIM(td_var%c_name) )
@@ -357,5 +457,5 @@
ELSE IF( td_var%t_dim(3)%l_use )THEN
- ! detect point to be interpolated on K
+ ! detect point to be extrapolated on K
CALL logger_debug(" EXTRAP DETECT: detect vertical point "//&
& " for variable "//TRIM(td_var%c_name) )
@@ -373,98 +473,32 @@
END FUNCTION extrap__detect_wrapper
- !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief
-! !> This function detected point to be extrapolated.
-! !>
-! !> @details
-! !>
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in] td_var : variable to extrapolate
-! !> @param[in] id_iext : number of points to be extrapolated in i-direction
-! !> @param[in] id_jext : number of points to be extrapolated in j-direction
-! !> @param[in] id_kext : number of points to be extrapolated in k-direction
-! !> @return
-! !
-! !> @todo
-! !-------------------------------------------------------------------
-! !> @code
-! FUNCTION extrap__detect(td_var, id_iext, id_jext, id_kext)
-! IMPLICIT NONE
-! ! Argument
-! TYPE(TVAR) , INTENT(INOUT) :: td_var
-! !INTEGER(i4), DIMENSION(:,:,:), INTENT(OUT ) :: id_detect
-! INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext
-! INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext
-! INTEGER(i4), INTENT(IN ), OPTIONAL :: id_kext
-!
-! ! function
-! INTEGER(i4), DIMENSION(td_var%t_dim(1)%i_len, &
-! & td_var%t_dim(2)%i_len, &
-! & td_var%t_dim(3)%i_len) :: extrap__detect
-!
-! ! local variable
-! INTEGER(i4) :: il_iext
-! INTEGER(i4) :: il_jext
-! INTEGER(i4) :: il_kext
-!
-! INTEGER(i4), DIMENSION(3) :: il_dim
-!
-! ! loop indices
-! INTEGER(i4) :: ji
-! INTEGER(i4) :: jj
-! INTEGER(i4) :: jk
-! !----------------------------------------------------------------
-!
-! ! optional argument
-! il_iext=im_minext
-! IF( PRESENT(id_iext) ) il_iext=id_iext
-! il_jext=im_minext
-! IF( PRESENT(id_jext) ) il_jext=id_jext
-! il_kext=im_minext
-! IF( PRESENT(id_kext) ) il_kext=id_kext
-!
-! ! init
-! extrap__detect(:,:,:)=0
-!
-! il_dim(:)=td_var%t_dim(1:3)%i_len
-!
-! ! compute point near grid point already inform
-! FORALL( ji=1:il_dim(1), &
-! & jj=1:il_dim(2), &
-! & jk=1:il_dim(3), &
-! & td_var%d_value(ji,jj,jk,1) /= td_var%d_fill )
-!
-! extrap__detect(MAX(1,ji-il_iext):MIN(ji+il_iext,il_dim(1)),&
-! & MAX(1,jj-il_jext):MIN(jj+il_jext,il_dim(2)),&
-! & MAX(1,jk-il_kext):MIN(jk+il_kext,il_dim(3)) )=1
-!
-!
-! END FORALL
-!
-! ! do not compute grid point already inform
-! WHERE( td_var%d_value(:,:,:,1) /= td_var%d_fill ) extrap__detect(:,:,:)=0
-!
-! END FUNCTION extrap__detect
-! !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This subroutine select method to be used for extrapolation.
+ !> If need be, increase number of points to be extrapolated.
+ !> Finally launch extrap__fill_value.
!>
- !> @details
+ !> @details
+ !> optionaly, you could specify :
+ !> - refinment factor (default 1)
+ !> - offset between fine and coarse grid (default compute from refinment factor
+ !> as offset=(rho-1)/2)
+ !> - number of point to be extrapolated in each direction (default im_minext)
+ !> - radius of the halo used to compute extrapolation
+ !> - maximum number of iteration
!>
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
- !> @param[inout] td_var : variable structure
- !> @param[in] id_iext : number of points to be extrapolated in i-direction
- !> @param[in] id_jext : number of points to be extrapolated in j-direction
- !> @param[in] id_kext : number of points to be extrapolated in k-direction
- !> @param[in] id_extend : radius of the box used to compute extrapolation
- !> @param[in] id_maxiter : maximum nuber of iteration
- !-------------------------------------------------------------------
- !> @code
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_level fine grid array of level
+ !> @param[in] id_offset array of offset between fine and coarse grid
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] id_iext number of points to be extrapolated in i-direction
+ !> @param[in] id_jext number of points to be extrapolated in j-direction
+ !> @param[in] id_kext number of points to be extrapolated in k-direction
+ !> @param[in] id_radius radius of the halo used to compute extrapolation
+ !> @param[in] id_maxiter maximum number of iteration
+ !-------------------------------------------------------------------
SUBROUTINE extrap__fill_value_wrapper( td_var, td_level, &
& id_offset, &
@@ -496,5 +530,5 @@
!----------------------------------------------------------------
IF( .NOT. ASSOCIATED(td_var%d_value) )THEN
- CALL logger_error("EXTRAP FILL VALUE: no table of value "//&
+ CALL logger_error("EXTRAP FILL VALUE: no value "//&
& "associted to variable "//TRIM(td_var%c_name) )
ELSE
@@ -542,6 +576,5 @@
IF( (il_iext /= 0 .AND. td_var%t_dim(1)%l_use) .OR. &
& (il_jext /= 0 .AND. td_var%t_dim(2)%l_use) .OR. &
- & (il_kext /= 0 .AND. td_var%t_dim(3)%l_use) .OR. &
- & PRESENT(td_level) )THEN
+ & (il_kext /= 0 .AND. td_var%t_dim(3)%l_use) )THEN
! number of point use to compute box
@@ -577,23 +610,28 @@
END SUBROUTINE extrap__fill_value_wrapper
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This subroutine compute point to be extrapolated, then extrapolate point.
!>
!> @details
+ !> optionaly, you could specify :
+ !> - refinment factor (default 1)
+ !> - offset between fine and coarse grid (default compute from refinment factor
+ !> as offset=(rho-1)/2)
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
- !> @param[inout] td_var : variable structure
- !> @param[in] cd_method : extrapolation method
- !> @param[in] id_iext : number of points to be extrapolated in i-direction
- !> @param[in] id_jext : number of points to be extrapolated in j-direction
- !> @param[in] id_kext : number of points to be extrapolated in k-direction
- !> @param[in] id_radius : radius of the halo used to compute extrapolation
- !> @param[in] id_maxiter : maximum nuber of iteration
- !-------------------------------------------------------------------
- !> @code
+ !> @param[inout] td_var variable structure
+ !> @param[in] cd_method extrapolation method
+ !> @param[in] id_iext number of points to be extrapolated in i-direction
+ !> @param[in] id_jext number of points to be extrapolated in j-direction
+ !> @param[in] id_kext number of points to be extrapolated in k-direction
+ !> @param[in] id_radius radius of the halo used to compute extrapolation
+ !> @param[in] id_maxiter maximum number of iteration
+ !> @param[in] td_level fine grid array of level
+ !> @param[in] id_offset array of offset between fine and coarse grid
+ !> @param[in] id_rho array of refinment factor
+ !-------------------------------------------------------------------
SUBROUTINE extrap__fill_value( td_var, cd_method, &
& id_iext, id_jext, id_kext, &
@@ -619,11 +657,8 @@
INTEGER(i4), DIMENSION(:,:,:) , ALLOCATABLE :: il_detect
- INTEGER(i4) :: il_radius
- INTEGER(i4) :: il_iter
TYPE(TATT) :: tl_att
! loop indices
- INTEGER(i4) :: jl
!----------------------------------------------------------------
@@ -637,5 +672,4 @@
& id_rho, &
& id_ext=(/id_iext, id_jext, id_kext/) )
-
!2- add attribute to variable
cl_extrap=fct_concat(td_var%c_extrap(:))
@@ -643,65 +677,50 @@
CALL var_move_att(td_var, tl_att)
- CALL logger_warn(" EXTRAP FILL: "//&
+ CALL att_clean(tl_att)
+
+ CALL logger_info(" EXTRAP FILL: "//&
& TRIM(fct_str(SUM(il_detect(:,:,:))))//&
& " point(s) to extrapolate " )
!3- extrapolate
- DO jl=1,td_var%t_dim(4)%i_len
-
-! td_var%d_value(:,:,:,jl)=il_detect(:,:,:)
- il_iter=1
- DO WHILE( ANY(il_detect(:,:,:)==1) )
- ! change extend value to minimize number of iteration
- il_radius=id_radius+(il_iter/id_maxiter)
-
- CALL logger_debug(" EXTRAP FILL VALUE: "//&
- & TRIM(fct_str(SUM(il_detect(:,:,:))))//&
- & " points to extrapolate " )
-
- CALL extrap__3D(td_var%d_value(:,:,:,jl), td_var%d_fill, &
- & il_detect(:,:,:), &
- & cd_method, il_radius )
-
- il_iter=il_iter+1
- ENDDO
-
- ENDDO
-
- IF( SUM(il_detect(:,:,:)) /= 0 )THEN
- CALL logger_warn(" EXTRAP FILL: still "//&
- & TRIM(fct_str(SUM(il_detect(:,:,:))))//&
- & " point(s) to extrapolate " )
- ENDIF
+ CALL extrap__3D(td_var%d_value(:,:,:,:), td_var%d_fill, &
+ & il_detect(:,:,:), &
+ & cd_method, id_radius, id_maxiter )
DEALLOCATE(il_detect)
END SUBROUTINE extrap__fill_value
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This subroutine compute point to be extrapolated in 3D array.
!>
!> @details
+ !> in case of 'min_error' method:
+ !> - compute derivative in i-, j- and k- direction
+ !> - compute minimum error coefficient (distance to center of halo)
+ !> - compute extrapolatd values by calculated minimum error using taylor expansion
+ !> in case of 'dist_weight' method:
+ !> - compute distance weight coefficient (inverse of distance to center of halo)
+ !> - compute extrapolatd values using Inverse Distance Weighting
!>
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
- !> @param[inout] dd_value : 3D table of variable to be extrapolated
- !> @param[in] dd_fill : FillValue of variable
- !> @param[inout] id_detect : table of point to extrapolate
- !> @param[in] id_ext : number of point use to compute box
- !> @param[in] cd_method : extrapolation method
- !-------------------------------------------------------------------
- !> @code
+ !> @param[inout] dd_value 3D array of variable to be extrapolated
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[inout] id_detect array of point to extrapolate
+ !> @param[in] cd_method extrapolation method
+ !> @param[in] id_radius radius of the halo used to compute extrapolation
+ !-------------------------------------------------------------------
SUBROUTINE extrap__3D( dd_value, dd_fill, id_detect,&
- & cd_method, id_ext )
+ & cd_method, id_radius, id_maxiter )
IMPLICIT NONE
! Argument
- REAL(dp) , DIMENSION(:,:,:), INTENT(INOUT) :: dd_value
+ REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value
REAL(dp) , INTENT(IN ) :: dd_fill
INTEGER(i4), DIMENSION(:,:,:), INTENT(INOUT) :: id_detect
CHARACTER(LEN=*), INTENT(IN ) :: cd_method
- INTEGER(i4), INTENT(IN ) :: id_ext
+ INTEGER(i4), INTENT(IN ) :: id_radius
+ INTEGER(i4), INTENT(IN ) :: id_maxiter
! local variable
@@ -712,7 +731,11 @@
INTEGER(i4) :: il_kmin
INTEGER(i4) :: il_kmax
-
- INTEGER(i4), DIMENSION(3) :: il_shape
+ INTEGER(i4) :: il_iter
+ INTEGER(i4) :: il_radius
+
+ INTEGER(i4), DIMENSION(4) :: il_shape
INTEGER(i4), DIMENSION(3) :: il_dim
+
+ INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_detect
REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_dfdx
@@ -725,187 +748,217 @@
INTEGER(i4) :: jj
INTEGER(i4) :: jk
+ INTEGER(i4) :: jl
!----------------------------------------------------------------
il_shape(:)=SHAPE(dd_value)
+ ALLOCATE( il_detect( il_shape(1), il_shape(2), il_shape(3)) )
+
SELECT CASE(TRIM(cd_method))
- CASE('min_error')
-
- ALLOCATE( dl_dfdx(il_shape(1), il_shape(2), il_shape(3)) )
- ALLOCATE( dl_dfdy(il_shape(1), il_shape(2), il_shape(3)) )
- ALLOCATE( dl_dfdz(il_shape(1), il_shape(2), il_shape(3)) )
-
-
- ! compute derivative in i-direction
- dl_dfdx(:,:,:)=dd_fill
- IF( il_shape(1) > 1 )THEN
- dl_dfdx(:,:,:)=extrap_deriv_3D( dd_value(:,:,:), dd_fill, 'I' )
- ENDIF
-
- ! compute derivative in i-direction
- dl_dfdy(:,:,:)=dd_fill
- IF( il_shape(2) > 1 )THEN
- dl_dfdy(:,:,:)=extrap_deriv_3D( dd_value(:,:,:), dd_fill, 'J' )
- ENDIF
-
- ! compute derivative in i-direction
- dl_dfdz(:,:,:)=dd_fill
- IF( il_shape(3) > 1 )THEN
- dl_dfdz(:,:,:)=extrap_deriv_3D( dd_value(:,:,:), dd_fill, 'K' )
- ENDIF
-
- il_dim(1)=2*id_ext+1
- IF( il_shape(1) < 2*id_ext+1 ) il_dim(1)=1
- il_dim(2)=2*id_ext+1
- IF( il_shape(2) < 2*id_ext+1 ) il_dim(2)=1
- il_dim(3)=2*id_ext+1
- IF( il_shape(3) < 2*id_ext+1 ) il_dim(3)=1
-
- ALLOCATE( dl_coef(il_dim(1), il_dim(2), il_dim(3)) )
-
- dl_coef(:,:,:)=extrap__3D_min_error_coef(dd_value( 1:il_dim(1), &
- & 1:il_dim(2), &
- & 1:il_dim(3)))
-
- DO jk=1,il_shape(3)
- IF( ALL(id_detect(:,:,jk) == 0) ) CYCLE
- DO jj=1,il_shape(2)
- IF( ALL(id_detect(:,jj,jk) == 0) ) CYCLE
- DO ji=1,il_shape(1)
-
- IF( id_detect(ji,jj,jk) == 1 )THEN
-
- il_imin=MAX(ji-id_ext,1)
- il_imax=MIN(ji+id_ext,il_shape(1))
- IF( il_dim(1) == 1 )THEN
- il_imin=ji
- il_imax=ji
+ CASE('min_error')
+ DO jl=1,il_shape(4)
+
+ ! intitialise table of poitn to be extrapolated
+ il_detect(:,:,:)=id_detect(:,:,:)
+
+ il_iter=1
+ DO WHILE( ANY(il_detect(:,:,:)==1) )
+ ! change extend value to minimize number of iteration
+ il_radius=id_radius+(il_iter/id_maxiter)
+
+ ALLOCATE( dl_dfdx(il_shape(1), il_shape(2), il_shape(3)) )
+ ALLOCATE( dl_dfdy(il_shape(1), il_shape(2), il_shape(3)) )
+ ALLOCATE( dl_dfdz(il_shape(1), il_shape(2), il_shape(3)) )
+
+ ! compute derivative in i-direction
+ dl_dfdx(:,:,:)=dd_fill
+ IF( il_shape(1) > 1 )THEN
+ dl_dfdx(:,:,:)=extrap_deriv_3D( dd_value(:,:,:,jl), dd_fill, 'I' )
+ ENDIF
+
+ ! compute derivative in j-direction
+ dl_dfdy(:,:,:)=dd_fill
+ IF( il_shape(2) > 1 )THEN
+ dl_dfdy(:,:,:)=extrap_deriv_3D( dd_value(:,:,:,jl), dd_fill, 'J' )
+ ENDIF
+
+ ! compute derivative in k-direction
+ dl_dfdz(:,:,:)=dd_fill
+ IF( il_shape(3) > 1 )THEN
+ dl_dfdz(:,:,:)=extrap_deriv_3D( dd_value(:,:,:,jl), dd_fill, 'K' )
+ ENDIF
+
+ il_dim(1)=2*il_radius+1
+ IF( il_shape(1) < 2*il_radius+1 ) il_dim(1)=1
+ il_dim(2)=2*il_radius+1
+ IF( il_shape(2) < 2*il_radius+1 ) il_dim(2)=1
+ il_dim(3)=2*il_radius+1
+ IF( il_shape(3) < 2*il_radius+1 ) il_dim(3)=1
+
+ ALLOCATE( dl_coef(il_dim(1), il_dim(2), il_dim(3)) )
+
+ dl_coef(:,:,:)=extrap__3D_min_error_coef(dd_value( 1:il_dim(1), &
+ & 1:il_dim(2), &
+ & 1:il_dim(3), &
+ & jl ))
+
+ DO jk=1,il_shape(3)
+ IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE
+ DO jj=1,il_shape(2)
+ IF( ALL(il_detect(:,jj,jk) == 0) ) CYCLE
+ DO ji=1,il_shape(1)
+
+ IF( il_detect(ji,jj,jk) == 1 )THEN
+
+ il_imin=MAX(ji-il_radius,1)
+ il_imax=MIN(ji+il_radius,il_shape(1))
+ IF( il_dim(1) == 1 )THEN
+ il_imin=ji
+ il_imax=ji
+ ENDIF
+
+ il_jmin=MAX(jj-il_radius,1)
+ il_jmax=MIN(jj+il_radius,il_shape(2))
+ IF( il_dim(2) == 1 )THEN
+ il_jmin=jj
+ il_jmax=jj
+ ENDIF
+
+ il_kmin=MAX(jk-il_radius,1)
+ il_kmax=MIN(jk+il_radius,il_shape(3))
+ IF( il_dim(3) == 1 )THEN
+ il_kmin=jk
+ il_kmax=jk
+ ENDIF
+
+ dd_value(ji,jj,jk,jl)=extrap__3D_min_error_fill( &
+ & dd_value( il_imin:il_imax, &
+ & il_jmin:il_jmax, &
+ & il_kmin:il_kmax,jl ), dd_fill, il_radius, &
+ & dl_dfdx( il_imin:il_imax, &
+ & il_jmin:il_jmax, &
+ & il_kmin:il_kmax ), &
+ & dl_dfdy( il_imin:il_imax, &
+ & il_jmin:il_jmax, &
+ & il_kmin:il_kmax ), &
+ & dl_dfdz( il_imin:il_imax, &
+ & il_jmin:il_jmax, &
+ & il_kmin:il_kmax ), &
+ & dl_coef(:,:,:) )
+
+ IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN
+ il_detect(ji,jj,jk)= 0
+ ENDIF
+
ENDIF
- il_jmin=MAX(jj-id_ext,1)
- il_jmax=MIN(jj+id_ext,il_shape(2))
- IF( il_dim(2) == 1 )THEN
- il_jmin=jj
- il_jmax=jj
- ENDIF
-
- il_kmin=MAX(jk-id_ext,1)
- il_kmax=MIN(jk+id_ext,il_shape(3))
- IF( il_dim(3) == 1 )THEN
- il_kmin=jk
- il_kmax=jk
- ENDIF
-
- dd_value(ji,jj,jk)=extrap__3D_min_error_fill( &
- & dd_value( il_imin:il_imax, &
- & il_jmin:il_jmax, &
- & il_kmin:il_kmax ), dd_fill, id_ext, &
- & dl_dfdx( il_imin:il_imax, &
- & il_jmin:il_jmax, &
- & il_kmin:il_kmax ), &
- & dl_dfdy( il_imin:il_imax, &
- & il_jmin:il_jmax, &
- & il_kmin:il_kmax ), &
- & dl_dfdz( il_imin:il_imax, &
- & il_jmin:il_jmax, &
- & il_kmin:il_kmax ), &
- & dl_coef(:,:,:) )
-
- IF( dd_value(ji,jj,jk) /= dd_fill )THEN
- id_detect(ji,jj,jk)= 0
- ENDIF
-
- ENDIF
-
+ ENDDO
ENDDO
ENDDO
+
+ DEALLOCATE( dl_dfdx )
+ DEALLOCATE( dl_dfdy )
+ DEALLOCATE( dl_dfdz )
+ DEALLOCATE( dl_coef )
+
+ il_iter=il_iter+1
ENDDO
-
- IF( ALLOCATED(dl_dfdx) ) DEALLOCATE( dl_dfdx )
- IF( ALLOCATED(dl_dfdy) ) DEALLOCATE( dl_dfdy )
- IF( ALLOCATED(dl_dfdz) ) DEALLOCATE( dl_dfdz )
- IF( ALLOCATED(dl_coef) ) DEALLOCATE( dl_coef )
-
- CASE DEFAULT ! 'dist_weight'
-
- il_dim(1)=2*id_ext+1
- IF( il_shape(1) < 2*id_ext+1 ) il_dim(1)=1
- il_dim(2)=2*id_ext+1
- IF( il_shape(2) < 2*id_ext+1 ) il_dim(2)=1
- il_dim(3)=2*id_ext+1
- IF( il_shape(3) < 2*id_ext+1 ) il_dim(3)=1
-
- ALLOCATE( dl_coef(il_dim(1), il_dim(2), il_dim(3)) )
-
- dl_coef(:,:,:)=extrap__3D_dist_weight_coef(dd_value(1:il_dim(1), &
- & 1:il_dim(2), &
- & 1:il_dim(3)) )
-
- DO jk=1,il_shape(3)
- IF( ALL(id_detect(:,:,jk) == 0) ) CYCLE
- DO jj=1,il_shape(2)
- IF( ALL(id_detect(:,jj,jk) == 0) ) CYCLE
- DO ji=1,il_shape(1)
-
- IF( id_detect(ji,jj,jk) == 1 )THEN
-
- il_imin=MAX(ji-id_ext,1)
- il_imax=MIN(ji+id_ext,il_shape(1))
- IF( il_dim(1) == 1 )THEN
- il_imin=ji
- il_imax=ji
+ ENDDO
+
+ CASE DEFAULT ! 'dist_weight'
+ DO jl=1,il_shape(4)
+
+ ! intitialise table of poitn to be extrapolated
+ il_detect(:,:,:)=id_detect(:,:,:)
+
+ il_iter=1
+ DO WHILE( ANY(il_detect(:,:,:)==1) )
+ ! change extend value to minimize number of iteration
+ il_radius=id_radius+(il_iter/id_maxiter)
+
+ il_dim(1)=2*il_radius+1
+ IF( il_shape(1) < 2*il_radius+1 ) il_dim(1)=1
+ il_dim(2)=2*il_radius+1
+ IF( il_shape(2) < 2*il_radius+1 ) il_dim(2)=1
+ il_dim(3)=2*il_radius+1
+ IF( il_shape(3) < 2*il_radius+1 ) il_dim(3)=1
+
+ ALLOCATE( dl_coef(il_dim(1), il_dim(2), il_dim(3)) )
+
+ dl_coef(:,:,:)=extrap__3D_dist_weight_coef(dd_value(1:il_dim(1), &
+ & 1:il_dim(2), &
+ & 1:il_dim(3), &
+ & jl ) )
+
+ DO jk=1,il_shape(3)
+ IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE
+ DO jj=1,il_shape(2)
+ IF( ALL(il_detect(:,jj,jk) == 0) ) CYCLE
+ DO ji=1,il_shape(1)
+
+ IF( il_detect(ji,jj,jk) == 1 )THEN
+
+ il_imin=MAX(ji-il_radius,1)
+ il_imax=MIN(ji+il_radius,il_shape(1))
+ IF( il_dim(1) == 1 )THEN
+ il_imin=ji
+ il_imax=ji
+ ENDIF
+
+ il_jmin=MAX(jj-il_radius,1)
+ il_jmax=MIN(jj+il_radius,il_shape(2))
+ IF( il_dim(2) == 1 )THEN
+ il_jmin=jj
+ il_jmax=jj
+ ENDIF
+
+ il_kmin=MAX(jk-il_radius,1)
+ il_kmax=MIN(jk+il_radius,il_shape(3))
+ IF( il_dim(3) == 1 )THEN
+ il_kmin=jk
+ il_kmax=jk
+ ENDIF
+
+ dd_value(ji,jj,jk,jl)=extrap__3D_dist_weight_fill( &
+ & dd_value( il_imin:il_imax, &
+ & il_jmin:il_jmax, &
+ & il_kmin:il_kmax, &
+ & jl), dd_fill, il_radius, &
+ & dl_coef(:,:,:) )
+
+ IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN
+ il_detect(ji,jj,jk)= 0
+ ENDIF
+
ENDIF
- il_jmin=MAX(jj-id_ext,1)
- il_jmax=MIN(jj+id_ext,il_shape(2))
- IF( il_dim(2) == 1 )THEN
- il_jmin=jj
- il_jmax=jj
- ENDIF
-
- il_kmin=MAX(jk-id_ext,1)
- il_kmax=MIN(jk+id_ext,il_shape(3))
- IF( il_dim(3) == 1 )THEN
- il_kmin=jk
- il_kmax=jk
- ENDIF
-
- dd_value(ji,jj,jk)=extrap__3D_dist_weight_fill( &
- & dd_value( il_imin:il_imax, &
- & il_jmin:il_jmax, &
- & il_kmin:il_kmax ), dd_fill, id_ext, &
- & dl_coef(:,:,:) )
-
- IF( dd_value(ji,jj,jk) /= dd_fill )THEN
- id_detect(ji,jj,jk)= 0
- ENDIF
-
- ENDIF
-
+ ENDDO
ENDDO
ENDDO
+
+ DEALLOCATE( dl_coef )
+ il_iter=il_iter+1
ENDDO
-
- IF( ALLOCATED(dl_coef) ) DEALLOCATE( dl_coef )
-
+ ENDDO
END SELECT
+ DEALLOCATE( il_detect )
+
END SUBROUTINE extrap__3D
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function compute derivative of a function in i- and
- !> j-direction
+ !> This function compute derivative of 1D array.
!>
!> @details
+ !> optionaly you could specify to take into account east west discontinuity
+ !> (-180° 180° or 0° 360° for longitude variable)
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
- !> @param[in] dd_value : 1D table of variable to be extrapolated
- !> @param[in] dd_fill : FillValue of variable
- !> @param[in] cd_dim : compute derivative on first (I) or second (J) dimension
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] dd_value 1D array of variable to be extrapolated
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[in] ld_discont logical to take into account east west discontinuity
+ !-------------------------------------------------------------------
PURE FUNCTION extrap_deriv_1D( dd_value, dd_fill, ld_discont )
@@ -1003,20 +1056,22 @@
END FUNCTION extrap_deriv_1D
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function compute derivative of a function in i- and
- !> j-direction
- !>
+ !> This function compute derivative of 2D array.
+ !> you have to specify in which direction derivative have to be computed:
+ !> first (I) or second (J) dimension.
+ !>
!> @details
+ !> optionaly you could specify to take into account east west discontinuity
+ !> (-180° 180° or 0° 360° for longitude variable)
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
- !> @param[in] dd_value : 2D table of variable to be extrapolated
- !> @param[in] dd_fill : FillValue of variable
- !> @param[in] cd_dim : compute derivative on first (I) or second (J) dimension
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] dd_value 2D array of variable to be extrapolated
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[in] cd_dim compute derivative on first (I) or second (J) dimension
+ !> @param[in] ld_discont logical to take into account east west discontinuity
+ !-------------------------------------------------------------------
FUNCTION extrap_deriv_2D( dd_value, dd_fill, cd_dim, ld_discont )
@@ -1123,5 +1178,5 @@
END WHERE
- ENDDO
+ ENDDO
CASE('J')
@@ -1187,20 +1242,22 @@
END FUNCTION extrap_deriv_2D
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function compute derivative of a function in i- and
- !> j-direction
+ !> This function compute derivative of 3D array.
+ !> you have to specify in which direction derivative have to be computed:
+ !> first (I), second (J) or third (K) dimension.
!>
!> @details
+ !> optionaly you could specify to take into account east west discontinuity
+ !> (-180° 180° or 0° 360° for longitude variable)
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
- !> @param[inout] dd_value : 3D table of variable to be extrapolated
- !> @param[in] dd_fill : FillValue of variable
- !> @param[in] cd_dim : compute derivative on first (I) second (J) or third (K) dimension
- !-------------------------------------------------------------------
- !> @code
+ !> @param[inout] dd_value 3D array of variable to be extrapolated
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[in] cd_dim compute derivative on first (I) second (J) or third (K) dimension
+ !> @param[in] ld_discont logical to take into account east west discontinuity
+ !-------------------------------------------------------------------
PURE FUNCTION extrap_deriv_3D( dd_value, dd_fill, cd_dim, ld_discont )
@@ -1431,26 +1488,18 @@
END FUNCTION extrap_deriv_3D
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function compute extrapolatd values by calculated minimum error using
- !> taylor expansion
+ !> This function compute coefficient for min_error extrapolation.
!>
!> @details
+ !> coefficients are "grid distance" to the center of the box choosed to compute
+ !> extrapolation.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
- !> @param[in] dd_value : 3D table of variable to be extrapolated
- !> @param[in] dd_fill : FillValue of variable
- !> @param[in] dd_ideriv : derivative of function in i-direction
- !> @param[in] dd_jderiv : derivative of function in j-direction
- !> @param[in] dd_kderiv : derivative of function in k-direction
- !> @param[in] id_ji : i-direction indices table
- !> @param[in] id_jj : j-direction indices table
- !> @param[in] id_ii : i-direction indices of the point to extrapolate
- !> @param[in] id_ij : j-direction indices of the point to extrapolate
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] dd_value 3D array of variable to be extrapolated
+ !> @return 3D array of coefficient for minimum error extrapolation
+ !-------------------------------------------------------------------
PURE FUNCTION extrap__3D_min_error_coef( dd_value )
@@ -1514,24 +1563,22 @@
END FUNCTION extrap__3D_min_error_coef
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function compute extrapolatd values by calculated minimum error using
+ !> This function compute extrapolatd value by calculated minimum error using
!> taylor expansion
!>
- !> @details
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
!>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_value : 3D table of variable to be extrapolated
- !> @param[in] dd_fill : FillValue of variable
- !> @param[in] dd_dfdx : derivative of function in i-direction
- !> @param[in] dd_dfdy : derivative of function in j-direction
- !> @param[in] dd_dfdz : derivative of function in k-direction
- !> @param[in] dd_coef :
- !-------------------------------------------------------------------
- !> @code
- PURE FUNCTION extrap__3D_min_error_fill( dd_value, dd_fill, id_ext, &
+ !> @param[in] dd_value 3D array of variable to be extrapolated
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[in] id_radius radius of the halo used to compute extrapolation
+ !> @param[in] dd_dfdx derivative of function in i-direction
+ !> @param[in] dd_dfdy derivative of function in j-direction
+ !> @param[in] dd_dfdz derivative of function in k-direction
+ !> @param[in] dd_coef array of coefficient for min_error extrapolation
+ !> @return extrapolatd value
+ !-------------------------------------------------------------------
+ PURE FUNCTION extrap__3D_min_error_fill( dd_value, dd_fill, id_radius, &
& dd_dfdx, dd_dfdy, dd_dfdz, &
& dd_coef )
@@ -1540,5 +1587,5 @@
REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_value
REAL(dp) , INTENT(IN) :: dd_fill
- INTEGER(i4), INTENT(IN) :: id_ext
+ INTEGER(i4), INTENT(IN) :: id_radius
REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_dfdx
REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_dfdy
@@ -1564,5 +1611,5 @@
extrap__3D_min_error_fill=dd_fill
- il_min=MAX(1,(SIZE(dd_value(:,:,:)))/(1+id_ext*2))
+ il_min=MAX(1,(SIZE(dd_value(:,:,:)))/(1+id_radius*2))
IF( COUNT(dd_value(:,:,:) /= dd_fill) >= il_min )THEN
@@ -1602,18 +1649,18 @@
END FUNCTION extrap__3D_min_error_fill
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function compute extrapolatd values by calculated minimum error using
- !> taylor expansion
+ !> This function compute coefficient for inverse distance weighted method
!>
!> @details
+ !> coefficients are inverse "grid distance" to the center of the box choosed to compute
+ !> extrapolation.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
- !> @param[in] dd_value : 3D table of variable to be extrapolated
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] dd_value 3D array of variable to be extrapolated
+ !> @return 3D array of coefficient for inverse distance weighted extrapolation
+ !-------------------------------------------------------------------
PURE FUNCTION extrap__3D_dist_weight_coef( dd_value )
@@ -1677,27 +1724,27 @@
END FUNCTION extrap__3D_dist_weight_coef
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function compute extrapolatd values by calculated minimum error using
- !> taylor expansion
+ !> This function compute extrapolatd value using inverse distance weighted
+ !> method
!>
!> @details
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
- !> @param[in] dd_value : 3D table of variable to be extrapolated
- !> @param[in] dd_fill : FillValue of variable
- !> @param[in] dd_coef :
- !-------------------------------------------------------------------
- !> @code
- FUNCTION extrap__3D_dist_weight_fill( dd_value, dd_fill, id_ext, &
- & dd_coef )
+ !> @param[in] dd_value 3D array of variable to be extrapolated
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[in] id_radius radius of the halo used to compute extrapolation
+ !> @param[in] dd_coef 3D array of coefficient for inverse distance weighted extrapolation
+ !> @return extrapolatd value
+ !-------------------------------------------------------------------
+ FUNCTION extrap__3D_dist_weight_fill( dd_value, dd_fill, id_radius, &
+ & dd_coef )
IMPLICIT NONE
! Argument
REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_value
REAL(dp) , INTENT(IN) :: dd_fill
- INTEGER(i4), INTENT(IN) :: id_ext
+ INTEGER(i4), INTENT(IN) :: id_radius
REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_coef
@@ -1722,5 +1769,5 @@
extrap__3D_dist_weight_fill=dd_fill
- il_min=MAX(1,(SIZE(dd_value(:,:,:)))/(1+id_ext*2))
+ il_min=MAX(1,(SIZE(dd_value(:,:,:)))/(1+id_radius*2))
IF( COUNT(dd_value(:,:,:)/= dd_fill) >= il_min )THEN
@@ -1733,18 +1780,22 @@
dl_coef(:,:,:)=0
- FORALL( ji=1:il_shape(1), &
- & jj=1:il_shape(2), &
- & jk=1:il_shape(3), &
- & dd_value(ji,jj,jk) /= dd_fill )
-
- ! compute factor
- dl_value(ji,jj,jk)=dd_coef(ji,jj,jk)*dd_value(ji,jj,jk)
- dl_coef(ji,jj,jk)=dd_coef(ji,jj,jk)
-
- END FORALL
+ DO jk=1,il_shape(3)
+ DO jj=1,il_shape(2)
+ DO ji=1,il_shape(1)
+
+ IF( dd_value(ji,jj,jk) /= dd_fill )THEN
+ ! compute factor
+ dl_value(ji,jj,jk)=dd_coef(ji,jj,jk)*dd_value(ji,jj,jk)
+ dl_coef(ji,jj,jk)=dd_coef(ji,jj,jk)
+ ENDIF
+
+ ENDDO
+ ENDDO
+ ENDDO
! return value
IF( SUM( dl_coef(:,:,:) ) /= 0 )THEN
- extrap__3D_dist_weight_fill=SUM( dl_value(:,:,:) )/SUM( dl_coef(:,:,:) )
+ extrap__3D_dist_weight_fill = &
+ & SUM( dl_value(:,:,:) )/SUM( dl_coef(:,:,:) )
ENDIF
@@ -1755,5 +1806,4 @@
END FUNCTION extrap__3D_dist_weight_fill
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -1761,14 +1811,16 @@
!> extraband of N points at north,south,east and west boundaries.
!>
+ !> @details
+ !> optionaly you could specify size of extra bands in i- and j-direction
+ !>
!> @author J.Paul
- !> - 2013-Initial version
+ !> - November, 2013-Initial version
!
- !> @param[inout] td_var : variable
- !> @param[in] id_isize : i-direction size of extra bands (default=im_minext)
- !> @param[in] id_jsize : j-direction size of extra bands (default=im_minext)
+ !> @param[inout] td_var variable
+ !> @param[in] id_isize i-direction size of extra bands (default=im_minext)
+ !> @param[in] id_jsize j-direction size of extra bands (default=im_minext)
!> @todo
!> - invalid special case for grid with north fold
!-------------------------------------------------------------------
- !> @code
SUBROUTINE extrap_add_extrabands(td_var, id_isize, id_jsize )
IMPLICIT NONE
@@ -1821,4 +1873,5 @@
dl_value(:,:,:,:)=td_var%d_value(:,:,:,:)
+
td_var%t_dim(1)%i_len = td_var%t_dim(1)%i_len + 2*il_isize
td_var%t_dim(2)%i_len = td_var%t_dim(2)%i_len + 2*il_jsize
@@ -1855,5 +1908,4 @@
END SUBROUTINE extrap_add_extrabands
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -1861,16 +1913,18 @@
!> of N points at north,south,east and west boundaries.
!>
+ !> @details
+ !> optionaly you could specify size of extra bands in i- and j-direction
+ !>
!> @author J.Paul
- !> - 2013-Initial version
- !
- !> @param[inout] td_var : variable
- !> @param[in] id_isize : i-direction size of extra bands (default=im_minext)
- !> @param[in] id_jsize : j-direction size of extra bands (default=im_minext)
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013-Initial version
+ !>
+ !> @param[inout] td_var variable
+ !> @param[in] id_isize i-direction size of extra bands (default=im_minext)
+ !> @param[in] id_jsize j-direction size of extra bands (default=im_minext)
+ !-------------------------------------------------------------------
SUBROUTINE extrap_del_extrabands(td_var, id_isize, id_jsize )
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_var
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
INTEGER(i4), INTENT(IN ), OPTIONAL :: id_isize
INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jsize
@@ -1881,5 +1935,5 @@
INTEGER(i4) :: il_isize
INTEGER(i4) :: il_jsize
-
+
INTEGER(i4) :: il_imin
INTEGER(i4) :: il_imax
@@ -1935,50 +1989,3 @@
END SUBROUTINE extrap_del_extrabands
- !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief
-! !> This function
-! !>
-! !> @details
-! !>
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !> @param[out]
-! !-------------------------------------------------------------------
-! !> @code
-! FUNCTION extrap_( )
-! IMPLICIT NONE
-! ! Argument
-!
-! ! local variable
-!
-! ! loop indices
-! !----------------------------------------------------------------
-! END FUNCTION extrap_
-! !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief
-! !> This subroutine
-! !>
-! !> @details
-! !>
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !> @param[out]
-! !-------------------------------------------------------------------
-! !> @code
-! SUBROUTINE extrap_( )
-! IMPLICIT NONE
-! ! Argument
-!
-! ! local variable
-!
-! ! loop indices
-! !----------------------------------------------------------------
-! END SUBROUTINE extrap_
-! !> @endcode
END MODULE extrap
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/file.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/file.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/file.f90 (revision 5214)
@@ -7,15 +7,23 @@
!> @brief
!> This module manage file structure.
-!
+!>
!> @details
-!>
!> define type TFILE:
-!> TYPE(TFILE) :: tl_file
-!>
-!> to initialise a file structure:
-!> tl_file=file_init(cd_file [,cd_type] [,ld_wrt])
+!> @code
+!> TYPE(TFILE) :: tl_file
+!> @endcode
+!>
+!> to initialize a file structure:
+!> @code
+!> tl_file=file_init(cd_file [,cd_type] [,ld_wrt] [,cd_grid])
+!% tl_file=file_init(cd_file [,cd_type] [,ld_wrt] [,id_ew] [,id_perio] [,id_pivot] [,cd_grid])
+!> @endcode
!> - cd_file is the file name
-!> - cd_type is the type of the file ('cdf', 'dimg') (optional)
-!> - ld_wrt file in write mode or not (optional)
+!> - cd_type is the type of the file ('cdf', 'dimg') [optional]
+!> - ld_wrt file in write mode or not [optional]
+!% - id_ew is the number of point for east-west overlap [optional]
+!% - id_perio is the NEMO periodicity index [optional]
+!% - id_pivot is the NEMO pivot point index F(0),T(1) [optional]
+!> - cd_grid is the grid type (default 'ARAKAWA-C')
!>
!> to get file name:
@@ -38,5 +46,5 @@
!> - tl_file\%i_nvar
!>
-!> to get the table of variable structure associated to the file:
+!> to get the array of variable structure associated to the file:
!> - tl_file\%t_var(:)
!>
@@ -45,5 +53,5 @@
!> - tl_file\%i_natt
!>
-!> to get the table of attributes structure associated to the file:
+!> to get the array of attributes structure associated to the file:
!> - tl_file\%t_att(:)
!>
@@ -52,49 +60,76 @@
!> - tl_file\%i_ndim
!>
-!> to get the table of dimension structure (4 elts) associated to the
+!> to get the array of dimension structure (4 elts) associated to the
!> file:
!> - tl_file\%t_dim(:)
!>
!> to print information about file structure:
+!> @code
!> CALL file_print(td_file)
+!> @endcode
+!>
+!> to clean file structure:
+!> @code
+!> CALL file_clean(td_file)
+!> @endcode
!>
!> to add a global attribute structure in file structure:
+!> @code
!> CALL file_add_att(td_file, td_att)
+!> @endcode
!> - td_att is an attribute structure
!>
!> to add a dimension structure in file structure:
+!> @code
!> CALL file_add_dim(td_file, td_dim)
+!> @endcode
!> - td_dim is a dimension structure
!>
!> to add a variable structure in file structure:
+!> @code
!> CALL file_add_var(td_file, td_var)
+!> @endcode
!> - td_var is a variable structure
!>
!> to delete a global attribute structure in file structure:
+!> @code
!> CALL file_del_att(td_file, td_att)
+!> @endcode
!> - td_att is an attribute structure
!>
!> to delete a dimension structure in file structure:
+!> @code
!> CALL file_del_dim(td_file, td_dim)
+!> @endcode
!> - td_dim is a dimension structure
!>
!> to delete a variable structure in file structure:
+!> @code
!> CALL file_del_var(td_file, td_var)
+!> @endcode
!> - td_var is a variable structure
!>
!> to overwrite one attribute structure in file structure:
+!> @code
!> CALL file_move_att(td_file, td_att)
+!> @endcode
!> - td_att is an attribute structure
!>
!> to overwrite one dimension strucutre in file structure:
+!> @code
!> CALL file_move_dim(td_file, td_dim)
+!> @endcode
!> - td_dim is a dimension structure
!>
!> to overwrite one variable structure in file structure:
+!> @code
!> CALL file_move_var(td_file, td_var)
+!> @endcode
!> - td_var is a variable structure
!>
!> to check if file and variable structure share same dimension:
+!> @code
!> ll_check_dim = file_check_var_dim(td_file, td_var)
+!> @endcode
!> - td_var is a variable structure
!>
@@ -102,10 +137,8 @@
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013- Initial Version
+!> @date November, 2013- Initial Version
+!> @date November, 2014 - Fix memory leaks bug
!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!> @todo
-!> - file_get_var(td_file, varname)
-!> - add description generique de l'objet file
!----------------------------------------------------------------------
MODULE file
@@ -113,100 +146,107 @@
USE global ! global variable
USE fct ! basic useful function
- USE logger ! log file manager
+ USE logger ! log file manager
USE dim ! dimension manager
USE att ! attribute manager
USE var ! variable manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! type and variable
- PUBLIC :: TFILE ! file structure
+ PUBLIC :: TFILE !< file structure
! function and subroutine
- PUBLIC :: ASSIGNMENT(=) !< copy file structure
- PUBLIC :: file_print !< print information about file structure
- PUBLIC :: file_clean !< clean file structure
- PUBLIC :: file_init !< initialise file structure
- PUBLIC :: file_add_att !< add one attribute structure in file structure
- PUBLIC :: file_add_var !< add one variable structure in file structure
- PUBLIC :: file_add_dim !< add one dimension strucutre in file structure
- PUBLIC :: file_del_att !< delete one attribute structure of file structure
- PUBLIC :: file_del_var !< delete one variable structure of file structure
- PUBLIC :: file_del_dim !< delete one dimension strucutre of file structure
- PUBLIC :: file_move_att !< overwrite one attribute structure in file structure
- PUBLIC :: file_move_var !< overwrite one variable structure in file structure
- PUBLIC :: file_move_dim !< overwrite one dimension strucutre in file structure
+ PUBLIC :: file_copy !< copy file structure
+ PUBLIC :: file_print !< print information about file structure
+ PUBLIC :: file_clean !< clean file structure
+ PUBLIC :: file_init !< initialize file structure
+ PUBLIC :: file_add_att !< add one attribute structure in file structure
+ PUBLIC :: file_add_var !< add one variable structure in file structure
+ PUBLIC :: file_add_dim !< add one dimension strucutre in file structure
+ PUBLIC :: file_del_att !< delete one attribute structure of file structure
+ PUBLIC :: file_del_var !< delete one variable structure of file structure
+ PUBLIC :: file_del_dim !< delete one dimension strucutre of file structure
+ PUBLIC :: file_move_att !< overwrite one attribute structure in file structure
+ PUBLIC :: file_move_var !< overwrite one variable structure in file structure
+ PUBLIC :: file_move_dim !< overwrite one dimension strucutre in file structure
PUBLIC :: file_check_var_dim !< check if file and variable structure use same dimension.
- PUBLIC :: file_get_type !< get type of file
- PUBLIC :: file_get_id !< get file id
- PUBLIC :: file_rename !< rename file name
- PUBLIC :: file_add_suffix !< add suffix to file name
+ PUBLIC :: file_get_type !< get type of file
+ PUBLIC :: file_get_id !< get file id
+ PUBLIC :: file_rename !< rename file name
+ PUBLIC :: file_add_suffix !< add suffix to file name
- PRIVATE :: file__del_var_name !< delete a variable structure in file structure, given variable name or standard name
- PRIVATE :: file__del_var_str !< delete a variable structure in file structure, given variable structure
- PRIVATE :: file__del_att_name !< delete a attribute structure in file structure, given attribute name
- PRIVATE :: file__del_att_str !< delete a attribute structure in file structure, given attribute structure
- PRIVATE :: file__get_number !< get number in file name without suffix
- PRIVATE :: file__get_suffix !< get suffix of file name
- PRIVATE :: file__copy_unit !< copy file structure
- PRIVATE :: file__copy_tab !< copy file structure
-
- !> @struct
- TYPE TFILE
+ PRIVATE :: file__clean_unit ! clean file structure
+ PRIVATE :: file__clean_arr ! clean array of file structure
+ PRIVATE :: file__del_var_name ! delete a variable structure in file structure, given variable name or standard name
+ PRIVATE :: file__del_var_str ! delete a variable structure in file structure, given variable structure
+ PRIVATE :: file__del_att_name ! delete a attribute structure in file structure, given attribute name
+ PRIVATE :: file__del_att_str ! delete a attribute structure in file structure, given attribute structure
+ PRIVATE :: file__get_number ! get number in file name without suffix
+ PRIVATE :: file__get_suffix ! get suffix of file name
+ PRIVATE :: file__copy_unit ! copy file structure
+ PRIVATE :: file__copy_arr ! copy array of file structure
+ PRIVATE :: file__rename_char ! rename file name, given processor number.
+ PRIVATE :: file__rename_str ! rename file name, given file structure.
+
+ TYPE TFILE !< file structure
! general
- CHARACTER(LEN=lc) :: c_name = "" !< file name
- CHARACTER(LEN=lc) :: c_type = "" !< type of the file (cdf, cdf4, dimg)
- INTEGER(i4) :: i_id = 0 !< file id
- LOGICAL :: l_wrt = .FALSE. !< read or write mode
- INTEGER(i4) :: i_nvar = 0 !< number of variable
- TYPE(TVAR), DIMENSION(:), POINTER :: t_var => NULL() !< file variables
+ CHARACTER(LEN=lc) :: c_name = "" !< file name
+ CHARACTER(LEN=lc) :: c_type = "" !< type of the file (cdf, cdf4, dimg)
+ INTEGER(i4) :: i_id = 0 !< file id
+ LOGICAL :: l_wrt = .FALSE. !< read or write mode
+ INTEGER(i4) :: i_nvar = 0 !< number of variable
+ TYPE(TVAR), DIMENSION(:), POINTER :: t_var => NULL() !< file variables
CHARACTER(LEN=lc) :: c_grid = 'ARAKAWA-C' !< grid type
- INTEGER(i4) :: i_ew =-1 !< east-west overlap
- INTEGER(i4) :: i_perio =-1 !< NEMO periodicity index
- INTEGER(i4) :: i_pivot =-1 !< NEMO pivot point index F(0),T(1)
-
- INTEGER(i4) :: i_depthid = 0 !< variable id of depth
- INTEGER(i4) :: i_timeid = 0 !< variable id of time
+ INTEGER(i4) :: i_ew =-1 !< east-west overlap
+ INTEGER(i4) :: i_perio =-1 !< NEMO periodicity index
+ INTEGER(i4) :: i_pivot =-1 !< NEMO pivot point index F(0),T(1)
+
+ INTEGER(i4) :: i_depthid = 0 !< variable id of depth
+ INTEGER(i4) :: i_timeid = 0 !< variable id of time
! netcdf file
- INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in the file
- INTEGER(i4) :: i_natt = 0 !< number of global attributes in the file
- INTEGER(i4) :: i_uldid = 0 !< id of the unlimited dimension in the file
- LOGICAL :: l_def = .FALSE. !< define mode or not
- TYPE(TATT), DIMENSION(:), POINTER :: t_att => NULL() !< global attributes
- TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< dimension structure
+ INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in the file
+ INTEGER(i4) :: i_natt = 0 !< number of global attributes in the file
+ INTEGER(i4) :: i_uldid = 0 !< id of the unlimited dimension in the file
+ LOGICAL :: l_def = .FALSE. !< define mode or not
+ TYPE(TATT), DIMENSION(:), POINTER :: t_att => NULL() !< global attributes
+ TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< dimension structure
! dimg file
- INTEGER(i4) :: i_recl = 0 !< record length (binary file)
- INTEGER(i4) :: i_n0d = 0 !< number of scalar variable
- INTEGER(i4) :: i_n1d = 0 !< number of 1D variable
- INTEGER(i4) :: i_n2d = 0 !< number of 2D variable
- INTEGER(i4) :: i_n3d = 0 !< number of 3D variable
- INTEGER(i4) :: i_rhd = 0 !< record of the header infos (last record)
+ INTEGER(i4) :: i_recl = 0 !< record length (binary file)
+ INTEGER(i4) :: i_n0d = 0 !< number of scalar variable
+ INTEGER(i4) :: i_n1d = 0 !< number of 1D variable
+ INTEGER(i4) :: i_n2d = 0 !< number of 2D variable
+ INTEGER(i4) :: i_n3d = 0 !< number of 3D variable
+ INTEGER(i4) :: i_rhd = 0 !< record of the header infos (last record)
! mpp
! only use for massively parallel processing
- INTEGER(i4) :: i_pid = -1 !< processor id (start to 1)
- INTEGER(i4) :: i_impp = 0 !< i-indexes for mpp-subdomain left bottom
- INTEGER(i4) :: i_jmpp = 0 !< j-indexes for mpp-subdomain left bottom
- INTEGER(i4) :: i_lci = 0 !< i-dimensions of subdomain
- INTEGER(i4) :: i_lcj = 0 !< j-dimensions of subdomain
- INTEGER(i4) :: i_ldi = 0 !< first indoor i-indices
- INTEGER(i4) :: i_ldj = 0 !< first indoor j-indices
- INTEGER(i4) :: i_lei = 0 !< last indoor i-indices
- INTEGER(i4) :: i_lej = 0 !< last indoor j-indices
-
- LOGICAL :: l_ctr = .FALSE. !< domain is on border
- LOGICAL :: l_use = .FALSE. !< domain is used
-
- ! only use to draw domain decomposition when initialise with mpp_init
- INTEGER(i4) :: i_iind = 0 !< i-direction indices
- INTEGER(i4) :: i_jind = 0 !< j-direction indices
+ INTEGER(i4) :: i_pid = -1 !< processor id (start to 1)
+ INTEGER(i4) :: i_impp = 0 !< i-indexes for mpp-subdomain left bottom
+ INTEGER(i4) :: i_jmpp = 0 !< j-indexes for mpp-subdomain left bottom
+ INTEGER(i4) :: i_lci = 0 !< i-dimensions of subdomain
+ INTEGER(i4) :: i_lcj = 0 !< j-dimensions of subdomain
+ INTEGER(i4) :: i_ldi = 0 !< first indoor i-indices
+ INTEGER(i4) :: i_ldj = 0 !< first indoor j-indices
+ INTEGER(i4) :: i_lei = 0 !< last indoor i-indices
+ INTEGER(i4) :: i_lej = 0 !< last indoor j-indices
+
+ LOGICAL :: l_ctr = .FALSE. !< domain is on border
+ LOGICAL :: l_use = .FALSE. !< domain is used
+
+ ! only use to draw domain decomposition when initialize with mpp_init
+ INTEGER(i4) :: i_iind = 0 !< i-direction indices
+ INTEGER(i4) :: i_jind = 0 !< j-direction indices
END TYPE TFILE
+
+ INTERFACE file_clean
+ MODULE PROCEDURE file__clean_unit
+ MODULE PROCEDURE file__clean_arr
+ END INTERFACE file_clean
INTERFACE file_del_var
@@ -225,7 +265,7 @@
END INTERFACE file_rename
- INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE file__copy_unit ! copy file structure
- MODULE PROCEDURE file__copy_tab ! copy file structure
+ INTERFACE file_copy
+ MODULE PROCEDURE file__copy_unit
+ MODULE PROCEDURE file__copy_arr
END INTERFACE
@@ -233,8 +273,7 @@
!-------------------------------------------------------------------
!> @brief
- !> This function copy file structure in another file
- !> structure
+ !> This subroutine copy file structure in another one
!> @details
- !> file variable and attribute value are copied in a temporary table,
+ !> file variable and attribute value are copied in a temporary array,
!> so input and output file structure value do not point on the same
!> "memory cell", and so on are independant.
@@ -242,19 +281,29 @@
!> @note new file is assume to be closed.
!>
+ !> @warning do not use on the output of a function who create or read an
+ !> structure (ex: tl_file=file_copy(file_init()) is forbidden).
+ !> This will create memory leaks.
!> @warning to avoid infinite loop, do not use any function inside
!> this subroutine
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[out] td_file1 : file structure
- !> @param[in] td_file2 : file structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE file__copy_unit( td_file1, td_file2 )
+ !> - November, 2013- Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator
+ !> (to avoid memory leak)
+ !
+ !> @param[in] td_file file structure
+ !> @return copy of input file structure
+ !-------------------------------------------------------------------
+ FUNCTION file__copy_unit( td_file )
IMPLICIT NONE
! Argument
- TYPE(TFILE), INTENT( OUT) :: td_file1
- TYPE(TFILE), INTENT(IN ) :: td_file2
+ TYPE(TFILE), INTENT(IN) :: td_file
+ ! function
+ TYPE(TFILE) :: file__copy_unit
+
+ ! local variable
+ TYPE(TVAR) :: tl_var
+ TYPE(TATT) :: tl_att
! loop indices
@@ -262,78 +311,90 @@
!----------------------------------------------------------------
- CALL logger_trace("COPY: file "//TRIM(td_file2%c_name) )
+ CALL logger_trace("FILE COPY: file "//TRIM(td_file%c_name) )
! copy file variable
- td_file1%c_name = TRIM(td_file2%c_name)
- td_file1%c_type = TRIM(td_file2%c_type)
+ file__copy_unit%c_name = TRIM(td_file%c_name)
+ file__copy_unit%c_type = TRIM(td_file%c_type)
! file1 should be closed even if file2 is opened right now
- td_file1%i_id = 0
- td_file1%l_wrt = td_file2%l_wrt
- td_file1%i_nvar = td_file2%i_nvar
-
- td_file1%c_grid = td_file2%c_grid
-
- td_file1%i_ew = td_file2%i_ew
- td_file1%i_perio= td_file2%i_perio
- td_file1%i_pivot= td_file2%i_pivot
+ file__copy_unit%i_id = 0
+ file__copy_unit%l_wrt = td_file%l_wrt
+ file__copy_unit%i_nvar = td_file%i_nvar
+
+ file__copy_unit%c_grid = td_file%c_grid
+
+ file__copy_unit%i_ew = td_file%i_ew
+ file__copy_unit%i_perio= td_file%i_perio
+ file__copy_unit%i_pivot= td_file%i_pivot
+
+ file__copy_unit%i_depthid = td_file%i_depthid
+ file__copy_unit%i_timeid = td_file%i_timeid
! copy variable structure
- IF( ASSOCIATED(td_file1%t_var) ) DEALLOCATE(td_file1%t_var)
- IF( ASSOCIATED(td_file2%t_var) .AND. td_file1%i_nvar > 0 )THEN
- ALLOCATE( td_file1%t_var(td_file1%i_nvar) )
- DO ji=1,td_file1%i_nvar
- td_file1%t_var(ji) = td_file2%t_var(ji)
+ IF( ASSOCIATED(file__copy_unit%t_var) )THEN
+ CALL var_clean(file__copy_unit%t_var(:))
+ DEALLOCATE(file__copy_unit%t_var)
+ ENDIF
+ IF( ASSOCIATED(td_file%t_var) .AND. file__copy_unit%i_nvar > 0 )THEN
+ ALLOCATE( file__copy_unit%t_var(file__copy_unit%i_nvar) )
+ DO ji=1,file__copy_unit%i_nvar
+ tl_var = var_copy(td_file%t_var(ji))
+ file__copy_unit%t_var(ji) = var_copy(tl_var)
ENDDO
ENDIF
! copy netcdf variable
- td_file1%i_ndim = td_file2%i_ndim
- td_file1%i_natt = td_file2%i_natt
- td_file1%i_uldid = td_file2%i_uldid
- td_file1%l_def = td_file2%l_def
+ file__copy_unit%i_ndim = td_file%i_ndim
+ file__copy_unit%i_natt = td_file%i_natt
+ file__copy_unit%i_uldid = td_file%i_uldid
+ file__copy_unit%l_def = td_file%l_def
! copy dimension
- td_file1%t_dim(:) = td_file2%t_dim(:)
+ file__copy_unit%t_dim(:) = dim_copy(td_file%t_dim(:))
! copy attribute structure
- IF( ASSOCIATED(td_file1%t_att) ) DEALLOCATE(td_file1%t_att)
- IF( ASSOCIATED(td_file2%t_att) .AND. td_file1%i_natt > 0 )THEN
- ALLOCATE( td_file1%t_att(td_file1%i_natt) )
- DO ji=1,td_file1%i_natt
- td_file1%t_att(ji) = td_file2%t_att(ji)
+ IF( ASSOCIATED(file__copy_unit%t_att) )THEN
+ CALL att_clean(file__copy_unit%t_att(:))
+ DEALLOCATE(file__copy_unit%t_att)
+ ENDIF
+ IF( ASSOCIATED(td_file%t_att) .AND. file__copy_unit%i_natt > 0 )THEN
+ ALLOCATE( file__copy_unit%t_att(file__copy_unit%i_natt) )
+ DO ji=1,file__copy_unit%i_natt
+ tl_att = att_copy(td_file%t_att(ji))
+ file__copy_unit%t_att(ji) = att_copy(tl_att)
ENDDO
ENDIF
+ ! clean
+ CALL att_clean(tl_att)
+
! copy dimg variable
- td_file1%i_recl = td_file2%i_recl
- td_file1%i_n0d = td_file2%i_n0d
- td_file1%i_n1d = td_file2%i_n1d
- td_file1%i_n2d = td_file2%i_n2d
- td_file1%i_n3d = td_file2%i_n3d
- td_file1%i_rhd = td_file2%i_rhd
+ file__copy_unit%i_recl = td_file%i_recl
+ file__copy_unit%i_n0d = td_file%i_n0d
+ file__copy_unit%i_n1d = td_file%i_n1d
+ file__copy_unit%i_n2d = td_file%i_n2d
+ file__copy_unit%i_n3d = td_file%i_n3d
+ file__copy_unit%i_rhd = td_file%i_rhd
! copy mpp variable
- td_file1%i_pid = td_file2%i_pid
- td_file1%i_impp = td_file2%i_impp
- td_file1%i_jmpp = td_file2%i_jmpp
- td_file1%i_lci = td_file2%i_lci
- td_file1%i_lcj = td_file2%i_lcj
- td_file1%i_ldi = td_file2%i_ldi
- td_file1%i_ldj = td_file2%i_ldj
- td_file1%i_lei = td_file2%i_lei
- td_file1%i_lej = td_file2%i_lej
- td_file1%l_ctr = td_file2%l_ctr
- td_file1%l_use = td_file2%l_use
- td_file1%i_iind = td_file2%i_iind
- td_file1%i_jind = td_file2%i_jind
-
- END SUBROUTINE file__copy_unit
- !> @endcode
+ file__copy_unit%i_pid = td_file%i_pid
+ file__copy_unit%i_impp = td_file%i_impp
+ file__copy_unit%i_jmpp = td_file%i_jmpp
+ file__copy_unit%i_lci = td_file%i_lci
+ file__copy_unit%i_lcj = td_file%i_lcj
+ file__copy_unit%i_ldi = td_file%i_ldi
+ file__copy_unit%i_ldj = td_file%i_ldj
+ file__copy_unit%i_lei = td_file%i_lei
+ file__copy_unit%i_lej = td_file%i_lej
+ file__copy_unit%l_ctr = td_file%l_ctr
+ file__copy_unit%l_use = td_file%l_use
+ file__copy_unit%i_iind = td_file%i_iind
+ file__copy_unit%i_jind = td_file%i_jind
+
+ END FUNCTION file__copy_unit
!-------------------------------------------------------------------
!> @brief
- !> This function copy file structure in another file
- !> structure
+ !> This subroutine copy a array of file structure in another one
!> @details
- !> file variable and attribute value are copied in a temporary table,
+ !> file variable and attribute value are copied in a temporary array,
!> so input and output file structure value do not point on the same
!> "memory cell", and so on are independant.
@@ -341,19 +402,25 @@
!> @note new file is assume to be closed.
!>
+ !> @warning do not use on the output of a function who create or read an
+ !> structure (ex: tl_file=file_copy(file_init()) is forbidden).
+ !> This will create memory leaks.
!> @warning to avoid infinite loop, do not use any function inside
!> this subroutine
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[out] td_file1 : file structure
- !> @param[in] td_file2 : file structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE file__copy_tab( td_file1, td_file2 )
+ !> - November, 2013- Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator
+ !> (to avoid memory leak)
+ !
+ !> @param[in] td_file file structure
+ !> @return copy of input array of file structure
+ !-------------------------------------------------------------------
+ FUNCTION file__copy_arr( td_file )
IMPLICIT NONE
! Argument
- TYPE(TFILE), DIMENSION(:) , INTENT(IN ) :: td_file2
- TYPE(TFILE), DIMENSION(SIZE(td_file2(:))), INTENT( OUT) :: td_file1
+ TYPE(TFILE), DIMENSION(:) , INTENT(IN ) :: td_file
+ ! function
+ TYPE(TFILE), DIMENSION(SIZE(td_file(:))) :: file__copy_arr
! loop indices
@@ -361,26 +428,35 @@
!----------------------------------------------------------------
- DO ji=1,SIZE(td_file2(:))
- td_file1(ji)=td_file2(ji)
+ DO ji=1,SIZE(td_file(:))
+ file__copy_arr(ji)=file_copy(td_file(ji))
ENDDO
- END SUBROUTINE file__copy_tab
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initialise file structure.
+ END FUNCTION file__copy_arr
+ !-------------------------------------------------------------------
+ !> @brief This function initialize file structure.
+ !> @details
!> If cd_type is not specify, check if file name include '.nc' or
- !> .'dimg'
+ !> '.dimg'
+ !> Optionally, you could specify:
+ !> - write mode (default .FALSE., ld_wrt)
+ !% - East-West overlap (id_ew)
+ !% - NEMO periodicity index (id_perio)
+ !% - NEMO pivot point index F(0),T(1) (id_pivot)
+ !> - grid type (default: 'ARAKAWA-C')
!
!> @details
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_file : file name
- !> @param[in] cd_type : file type ('cdf', 'dimg')
- !> @param[in] ld_wrt : write mode (default .FALSE.)
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_file file name
+ !> @param[in] cd_type file type ('cdf', 'dimg')
+ !> @param[in] ld_wrt write mode (default .FALSE.)
+ !> @param[in] id_ew east-west overlap
+ !> @param[in] id_perio NEMO periodicity index
+ !> @param[in] id_pivot NEMO pivot point index F(0),T(1)
+ !> @param[in] cd_grid grid type (default 'ARAKAWA-C')
!> @return file structure
!-------------------------------------------------------------------
- !> @code
TYPE(TFILE) FUNCTION file_init( cd_file, cd_type, ld_wrt, &
& id_ew, id_perio, id_pivot,&
@@ -397,5 +473,5 @@
! local variable
- TYPE(TATT) :: tl_att
+ TYPE(TATT) :: tl_att
!----------------------------------------------------------------
@@ -404,12 +480,5 @@
file_init%c_name=TRIM(ADJUSTL(cd_file))
- CALL logger_trace("INIT: initialise file "//TRIM(file_init%c_name))
-
- ! create some global attribute
- tl_att=att_init("Conventions","CF-1.5")
- CALL file_add_att(file_init,tl_att)
-
- tl_att=att_init("Grid",TRIM(file_init%c_grid))
- CALL file_add_att(file_init,tl_att)
+ CALL logger_trace("FILE INIT: initialize file "//TRIM(file_init%c_name))
! check type
@@ -421,5 +490,5 @@
file_init%c_type='dimg'
CASE DEFAULT
- CALL logger_error( " INIT: can't initialise file "//&
+ CALL logger_error( " FILE INIT: can't initialize file "//&
& TRIM(file_init%c_name)//" : type unknown " )
END SELECT
@@ -427,4 +496,13 @@
file_init%c_type=TRIM(file_get_type(cd_file))
ENDIF
+
+ ! create some global attribute
+ IF( TRIM(file_init%c_type) == 'cdf' )THEN
+ tl_att=att_init("Conventions","CF-1.5")
+ CALL file_add_att(file_init,tl_att)
+ ENDIF
+
+ tl_att=att_init("Grid",TRIM(file_init%c_grid))
+ CALL file_add_att(file_init,tl_att)
IF( PRESENT(ld_wrt) )THEN
@@ -460,6 +538,8 @@
ENDIF
+ ! clean
+ CALL att_clean(tl_att)
+
END FUNCTION file_init
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -473,14 +553,14 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_file : file name
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_file file name
!> @return type of file
!-------------------------------------------------------------------
- !> @code
CHARACTER(LEN=lc) FUNCTION file_get_type(cd_file)
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_file
+
!local variable
CHARACTER(LEN=lc) :: cl_suffix
@@ -490,11 +570,11 @@
SELECT CASE( TRIM(fct_lower(cl_suffix)) )
CASE('.nc','.cdf')
- CALL logger_debug(" GET TYPE: file "//TRIM(cd_file)//" is cdf")
+ CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is cdf")
file_get_type='cdf'
CASE('.dimg')
- CALL logger_debug(" GET TYPE: file "//TRIM(cd_file)//" is dimg" )
+ CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is dimg" )
file_get_type='dimg'
CASE DEFAULT
- CALL logger_warn(" GET TYPE: type unknown, we assume file: "//&
+ CALL logger_warn(" FILE GET TYPE: type unknown, we assume file: "//&
& TRIM(cd_file)//" is dimg ")
file_get_type='dimg'
@@ -502,5 +582,4 @@
END FUNCTION file_get_type
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function check if variable dimension to be used
@@ -510,11 +589,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] td_var : variable structure
- !> @return dimension of variable and file structure agree (or not)
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] td_var variable structure
+ !> @return true if dimension of variable and file structure agree
+ !-------------------------------------------------------------------
LOGICAL FUNCTION file_check_var_dim(td_file, td_var)
IMPLICIT NONE
@@ -524,5 +602,8 @@
! local variable
- INTEGER(i4) :: il_ndim
+ CHARACTER(LEN=lc) :: cl_dim
+ LOGICAL :: ll_error
+
+ INTEGER(i4) :: il_ind
! loop indices
@@ -530,7 +611,21 @@
!----------------------------------------------------------------
file_check_var_dim=.TRUE.
+
! check used dimension
- IF( ANY( td_var%t_dim(:)%l_use .AND. &
- & td_var%t_dim(:)%i_len /= td_file%t_dim(:)%i_len) )THEN
+ ll_error=.FALSE.
+ DO ji=1,ip_maxdim
+ il_ind=dim_get_index( td_file%t_dim(:), &
+ & TRIM(td_var%t_dim(ji)%c_name), &
+ & TRIM(td_var%t_dim(ji)%c_sname))
+ IF( il_ind /= 0 )THEN
+ IF( td_var%t_dim(ji)%l_use .AND. &
+ & td_file%t_dim(il_ind)%l_use .AND. &
+ & td_var%t_dim(ji)%i_len /= td_file%t_dim(il_ind)%i_len )THEN
+ ll_error=.TRUE.
+ ENDIF
+ ENDIF
+ ENDDO
+
+ IF( ll_error )THEN
file_check_var_dim=.FALSE.
@@ -542,30 +637,37 @@
- CALL logger_debug( &
- & " file dimension: "//TRIM(fct_str(td_file%i_ndim))//&
- & " variable dimension: "//TRIM(fct_str(td_var%i_ndim)) )
- il_ndim=MIN(td_var%i_ndim, td_file%i_ndim )
- DO ji = 1, il_ndim
- CALL logger_debug( &
- & " FILE CHECK VAR DIM: for dimension "//&
- & TRIM(td_file%t_dim(ji)%c_name)//&
- & ", file length: "//&
- & TRIM(fct_str(td_file%t_dim(ji)%i_len))//&
- & ", variable length: "//&
- & TRIM(fct_str(td_var%t_dim(ji)%i_len))//&
- & ", variable used "//TRIM(fct_str(td_var%t_dim(ji)%l_use)))
+ cl_dim='(/'
+ DO ji = 1, td_file%i_ndim
+ IF( td_file%t_dim(ji)%l_use )THEN
+ cl_dim=TRIM(cl_dim)//&
+ & TRIM(fct_upper(td_file%t_dim(ji)%c_sname))//':'//&
+ & TRIM(fct_str(td_file%t_dim(ji)%i_len))//','
+ ENDIF
ENDDO
+ cl_dim=TRIM(cl_dim)//'/)'
+ CALL logger_debug( " file dimension: "//TRIM(cl_dim) )
+
+ cl_dim='(/'
+ DO ji = 1, td_var%i_ndim
+ IF( td_var%t_dim(ji)%l_use )THEN
+ cl_dim=TRIM(cl_dim)//&
+ & TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//&
+ & TRIM(fct_str(td_var%t_dim(ji)%i_len))//','
+ ENDIF
+ ENDDO
+ cl_dim=TRIM(cl_dim)//'/)'
+ CALL logger_debug( " variable dimension: "//TRIM(cl_dim) )
+
ELSE
- IF( ANY( td_var%t_dim(:)%l_use .AND. &
- & .NOT. td_file%t_dim(:)%l_use ) )THEN
-
- CALL logger_info("FILE CHECK VAR DIM: variable use more dimension "//&
- & " than file do until now. file dimension use will change.")
-
- ENDIF
+
+ IF( td_var%i_ndim > td_file%i_ndim )THEN
+ CALL logger_info("FILE CHECK VAR DIM: variable "//&
+ & TRIM(td_var%c_name)//" use more dimension than file "//&
+ & TRIM(td_file%c_name)//" do until now.")
+ ENDIF
+
ENDIF
END FUNCTION file_check_var_dim
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine add a variable structure in a file structure.
@@ -577,14 +679,12 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] td_var : variable structure
- !
- !> @todo
- !> - check dimension order
- !> - voir pour ajouter variable avec plus de dim que deja presente dans fichier
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - add dimension to file if need be
+ !> - do not reorder dimension from variable, before put in file
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE file_add_var(td_file, td_var)
IMPLICIT NONE
@@ -596,6 +696,5 @@
! local variable
INTEGER(i4) :: il_status
- INTEGER(i4) :: il_varid
- INTEGER(i4) :: il_rec
+ !INTEGER(i4) :: il_rec
INTEGER(i4) :: il_ind
@@ -606,9 +705,8 @@
!----------------------------------------------------------------
! check if file opened
- !IF( TRIM(td_file%c_name) == "unknown" )THEN
IF( TRIM(td_file%c_name) == '' )THEN
- CALL logger_error( " ADD VAR: structure file unknown" )
- CALL logger_debug( " ADD VAR: you should have used file_init before "//&
+ CALL logger_error( " FILE ADD VAR: structure file unknown" )
+ CALL logger_debug( " FILE ADD VAR: you should have used file_init before "//&
& "running file_add_var" )
@@ -617,17 +715,17 @@
IF( TRIM(td_var%c_name) == '' .AND. &
& TRIM(td_var%c_stdname) == '' )THEN
- CALL logger_error(" ADD VAR: variable not define ")
+ CALL logger_error(" FILE ADD VAR: variable without name ")
ELSE
! check if variable already in file structure
- il_varid=0
+ il_ind=0
IF( ASSOCIATED(td_file%t_var) )THEN
- il_varid=var_get_id( td_file%t_var(:), td_var%c_name, &
- & td_var%c_stdname )
+ il_ind=var_get_index( td_file%t_var(:), td_var%c_name, &
+ & td_var%c_stdname )
ENDIF
- IF( il_varid /= 0 )THEN
+ IF( il_ind /= 0 )THEN
CALL logger_error( &
- & " ADD VAR: variable "//TRIM(td_var%c_name)//&
+ & " FILE ADD VAR: variable "//TRIM(td_var%c_name)//&
& ", standard name "//TRIM(td_var%c_stdname)//&
& ", already in file "//TRIM(td_file%c_name) )
@@ -641,31 +739,37 @@
ELSE
- CALL logger_info( &
- & " ADD VAR: add variable "//TRIM(td_var%c_name)//&
+ CALL logger_trace( &
+ & " FILE ADD VAR: add variable "//TRIM(td_var%c_name)//&
& ", standard name "//TRIM(td_var%c_stdname)//&
& ", in file "//TRIM(td_file%c_name) )
- ! if none, force to use variable dimension
- IF( ALL( .NOT. td_file%t_dim(:)%l_use) )THEN
- td_file%t_dim(:)=td_var%t_dim(:)
- ENDIF
-
! check used dimension
IF( file_check_var_dim(td_file, td_var) )THEN
+ ! update dimension if need be
+ DO ji=1,ip_maxdim
+ IF( td_var%t_dim(ji)%l_use .AND. &
+ & .NOT. td_file%t_dim(ji)%l_use )THEN
+ CALL file_add_dim(td_file,td_var%t_dim(ji))
+ ENDIF
+ ENDDO
+
+ ! get index of new variable
SELECT CASE(td_var%i_ndim)
CASE(0)
il_ind=td_file%i_n0d+1
- il_rec=0
+ !il_rec=0
CASE(1)
il_ind=td_file%i_n0d+td_file%i_n1d+1
- il_rec=1
+ !il_rec=1
CASE(2)
il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+1
- il_rec=1
+ !il_rec=1
CASE(3,4)
il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+td_file%i_n3d+1
- il_rec=td_file%t_dim(3)%i_len
+ !il_rec=td_file%t_dim(3)%i_len
END SELECT
+ CALL logger_info( &
+ & " FILE ADD VAR: variable index "//TRIM(fct_str(il_ind)))
IF( td_file%i_nvar > 0 )THEN
@@ -675,5 +779,5 @@
CALL logger_error( &
- & " ADD VAR: not enough space to put variables "//&
+ & " FILE ADD VAR: not enough space to put variables "//&
& "from "//TRIM(td_file%c_name)//&
& " in variable structure")
@@ -682,7 +786,8 @@
! save temporary variable of file structure
- tl_var(:)=td_file%t_var(:)
-
- DEALLOCATE( td_file%t_var )
+ tl_var(:)=var_copy(td_file%t_var(:))
+
+ CALL var_clean( td_file%t_var(:) )
+ DEALLOCATE(td_file%t_var)
ALLOCATE( td_file%t_var(td_file%i_nvar+1), &
& stat=il_status)
@@ -690,5 +795,5 @@
CALL logger_error( &
- & " ADD VAR: not enough space to put variable "//&
+ & " FILE ADD VAR: not enough space to put variable "//&
& "in file structure "//TRIM(td_file%c_name) )
@@ -697,18 +802,16 @@
! copy variable in file before
! variable with less than or equal dimension that new variable
- td_file%t_var( 1:il_ind-1 ) = tl_var( 1:il_ind-1 )
-
- ! variable with greater dimension than new variable
- td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = &
- & tl_var( il_ind : td_file%i_nvar )
-
- ! update id
- td_file%t_var( il_ind+1 : td_file%i_nvar+1 )%i_id = &
- & tl_var( il_ind : td_file%i_nvar )%i_id + 1
-
- ! update record index
- td_file%t_var( il_ind+1 : td_file%i_nvar+1 )%i_rec = &
- & tl_var( il_ind : td_file%i_nvar )%i_rec + il_rec
-
+ IF( il_ind > 1 )THEN
+ td_file%t_var( 1:il_ind-1 ) = var_copy(tl_var(1:il_ind-1))
+ ENDIF
+
+ IF( il_ind < td_file%i_nvar )THEN
+ ! variable with more dimension than new variable
+ td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = &
+ & var_copy( tl_var(il_ind : td_file%i_nvar) )
+ ENDIF
+
+ ! clean
+ CALL var_clean(tl_var(:))
DEALLOCATE(tl_var)
ENDIF
@@ -717,4 +820,5 @@
! no variable in file structure
IF( ASSOCIATED(td_file%t_var) )THEN
+ CALL var_clean(td_file%t_var(:))
DEALLOCATE(td_file%t_var)
ENDIF
@@ -723,5 +827,5 @@
CALL logger_error( &
- & " ADD VAR: not enough space to put variable "//&
+ & " FILE ADD VAR: not enough space to put variable "//&
& "in file structure "//TRIM(td_file%c_name) )
@@ -730,13 +834,14 @@
ENDIF
+ ! add new variable in array of variable
ALLOCATE( tl_var(1), stat=il_status )
IF(il_status /= 0 )THEN
CALL logger_error( &
- & " ADD VAR: not enough space to put variables from "//&
+ & " FILE ADD VAR: not enough space to put variables from "//&
& TRIM(td_var%c_name)//" in variable structure")
ELSE
- tl_var(1)=td_var
+ tl_var(1)=var_copy(td_var)
! update dimension name in new variable
@@ -744,5 +849,5 @@
! add new variable
- td_file%t_var(il_ind)=tl_var(1)
+ td_file%t_var(il_ind)=var_copy(tl_var(1))
! update number of variable
@@ -755,21 +860,10 @@
CASE(2)
td_file%i_n2d=td_file%i_n2d+1
- CASE(3)
+ CASE(3,4)
td_file%i_n3d=td_file%i_n3d+1
END SELECT
! update variable id
- td_file%t_var(il_ind)%i_id=il_ind
-
- ! update record header index
- td_file%i_rhd=td_file%i_rhd+il_rec
-
- ! update record index
- IF( il_ind > 1 )THEN
- td_file%t_var(il_ind)%i_rec = &
- & td_file%t_var(il_ind-1)%i_rec+il_rec
- ELSE
- td_file%t_var(il_ind)%i_rec = il_rec
- ENDIF
+ td_file%t_var(il_ind)%i_id=var_get_unit(td_file%t_var(:))
! update dimension used
@@ -780,11 +874,12 @@
ENDIF
ENDDO
- CALL dim_reorder(td_file%t_dim(:))
+
! update number of dimension
td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
- DEALLOCATE( tl_var )
+ ! clean
+ CALL var_clean( tl_var(:) )
+ DEALLOCATE(tl_var)
ENDIF
-
ENDIF
ENDIF
@@ -793,18 +888,14 @@
END SUBROUTINE file_add_var
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine delete a variable structure
- !> in file structure.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] cd_name : variable name or standard name
- !-------------------------------------------------------------------
- !> @code
+ !> in file structure, given variable name or standard name.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] cd_name variable name or standard name
+ !-------------------------------------------------------------------
SUBROUTINE file__del_var_name(td_file, cd_name )
IMPLICIT NONE
@@ -815,5 +906,5 @@
! local variable
- INTEGER(i4) :: il_varid
+ INTEGER(i4) :: il_ind
!----------------------------------------------------------------
@@ -821,6 +912,6 @@
IF( TRIM(td_file%c_name) == '' )THEN
- CALL logger_error( " DEL VAR NAME: file structure unknown ")
- CALL logger_debug( " DEL VAR NAME: you should have used file_init before "//&
+ CALL logger_error( " FILE DEL VAR NAME: file structure unknown ")
+ CALL logger_debug( " FILE DEL VAR NAME: you should have used file_init before "//&
& "running file_del_var" )
@@ -829,17 +920,18 @@
IF( td_file%i_nvar /= 0 )THEN
- ! get the variable id, in file variable structure
- il_varid=0
+ ! get the variable index, in file variable structure
+ il_ind=0
IF( ASSOCIATED(td_file%t_var) )THEN
- il_varid=var_get_id(td_file%t_var(:), cd_name )
+ il_ind=var_get_index(td_file%t_var(:), cd_name )
ENDIF
- IF( il_varid /= 0 )THEN
+
+ IF( il_ind /= 0 )THEN
- CALL file_del_var(td_file, td_file%t_var(il_varid))
+ CALL file_del_var(td_file, td_file%t_var(il_ind))
ELSE
CALL logger_warn( &
- & " DEL VAR NAME: there is no variable with name or "//&
+ & " FILE DEL VAR NAME: there is no variable with name or "//&
& "standard name "//TRIM(cd_name)//" in file "//&
& TRIM(td_file%c_name))
@@ -848,6 +940,7 @@
ELSE
- CALL logger_debug( " DEL VAR NAME: no variable associated to file "//&
- & TRIM(td_file%c_name) )
+ CALL logger_debug( " FILE DEL VAR NAME: "//&
+ & "no variable associated to file "//&
+ & TRIM(td_file%c_name) )
ENDIF
@@ -855,20 +948,14 @@
END SUBROUTINE file__del_var_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine delete a variable structure
!> in file structure, given variable structure.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] td_var : variable structure
- !> @todo
- !> - verifier pose pas de souci de ne pas modifier id
- !-------------------------------------------------------------------
- !> @code
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_file file structure
+ !> @param[in] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE file__del_var_str(td_file, td_var)
IMPLICIT NONE
@@ -880,5 +967,5 @@
! local variable
INTEGER(i4) :: il_status
- INTEGER(i4) :: il_varid
+ INTEGER(i4) :: il_ind
INTEGER(i4) :: il_rec
TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var
@@ -889,25 +976,204 @@
! check if file opened
- !IF( TRIM(td_file%c_name) == "unknown" )THEN
IF( TRIM(td_file%c_name) == '' )THEN
- CALL logger_error( " DEL VAR: file structure unknown ")
- CALL logger_debug( " DEL VAR: you should have used file_init before "//&
- & "running file_del_var" )
+ CALL logger_error( " FILE DEL VAR: file structure unknown ")
+ CALL logger_debug( " FILE DEL VAR: you should have used "//&
+ & "file_init before running file_del_var" )
ELSE
- ! check if variable already in file structure
- il_varid=var_get_id(td_file%t_var(:), td_var%c_name, td_var%c_stdname )
- IF( il_varid == 0 )THEN
-
+ ! check if variable is member of a file
+ IF( td_var%l_file )THEN
+ CALL logger_warn( &
+ & " FILE DEL VAR: variable "//TRIM(td_var%c_name)//&
+ & ", belong to file "//TRIM(td_file%c_name)//&
+ & " and can not be removed.")
+ ELSE
+ ! check if variable already in file structure
+ il_ind=0
+ IF( ASSOCIATED(td_file%t_var) )THEN
+ il_ind=var_get_index( td_file%t_var(:), td_var%c_name, &
+ & td_var%c_stdname )
+ ENDIF
+
+ IF( il_ind == 0 )THEN
+
+ CALL logger_warn( "FILE DEL VAR: no variable "//&
+ & TRIM(td_var%c_name)//", in file "//TRIM(td_file%c_name) )
+
+ DO ji=1,td_file%i_nvar
+ CALL logger_debug( "FILE DEL VAR: in file "//&
+ & TRIM(td_file%t_var(ji)%c_name)//", standard name "//&
+ & TRIM(td_file%t_var(ji)%c_stdname) )
+ ENDDO
+
+ ELSE
+
+ CALL logger_trace( "FILE DEL VAR: delete variable "//&
+ & TRIM(td_var%c_name)//", from file "//TRIM(td_file%c_name) )
+
+ ALLOCATE( tl_var(td_file%i_nvar-1), stat=il_status )
+ IF(il_status /= 0 )THEN
+
+ CALL logger_error( &
+ & " FILE DEL VAR: not enough space to put variables from "//&
+ & TRIM(td_file%c_name)//" in temporary variable structure")
+
+ ELSE
+
+ ! save temporary variable's file structure
+ IF( il_ind > 1 )THEN
+ tl_var(1:il_ind-1)=var_copy(td_file%t_var(1:il_ind-1))
+ ENDIF
+
+ IF( il_ind < td_file%i_nvar )THEN
+ tl_var(il_ind:)=var_copy(td_file%t_var(il_ind+1:))
+ ENDIF
+
+ ! new number of variable in file
+ td_file%i_nvar=td_file%i_nvar-1
+
+ SELECT CASE(td_var%i_ndim)
+ CASE(0)
+ td_file%i_n0d=td_file%i_n0d-1
+ il_rec=0
+ CASE(1)
+ td_file%i_n1d=td_file%i_n1d-1
+ il_rec=1
+ CASE(2)
+ td_file%i_n2d=td_file%i_n2d-1
+ il_rec=1
+ CASE(3,4)
+ td_file%i_n3d=td_file%i_n3d-1
+ il_rec=td_file%t_dim(3)%i_len
+ END SELECT
+
+ CALL var_clean( td_file%t_var(:) )
+ DEALLOCATE(td_file%t_var)
+
+ IF( td_file%i_nvar > 0 )THEN
+ ALLOCATE( td_file%t_var(td_file%i_nvar), stat=il_status )
+ IF(il_status /= 0 )THEN
+
+ CALL logger_error( " FILE DEL VAR: not enough space"//&
+ & "to put variables in file structure "//&
+ & TRIM(td_file%c_name) )
+
+ ENDIF
+
+ ! copy attribute in file before
+ td_file%t_var(:)=var_copy(tl_var(:))
+
+ ! update dimension used
+ td_file%t_dim(:)%l_use=.FALSE.
+ DO ji=1,ip_maxdim
+ IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN
+ td_file%t_dim(ji)%l_use=.TRUE.
+ ENDIF
+ ENDDO
+
+ ! update number of dimension
+ td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
+
+ ENDIF
+
+ ! clean
+ CALL var_clean(tl_var(:))
+ DEALLOCATE(tl_var)
+
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE file__del_var_str
+ !-------------------------------------------------------------------
+ !> @brief This subroutine overwrite variable structure
+ !> in file structure.
+ !
+ !> @warning change variable id in file structure.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] td_var variable structure
+ !-------------------------------------------------------------------
+ SUBROUTINE file_move_var(td_file, td_var)
+ IMPLICIT NONE
+
+ ! Argument
+ TYPE(TFILE), INTENT(INOUT) :: td_file
+ TYPE(TVAR), INTENT(IN) :: td_var
+
+ ! local variable
+ TYPE(TVAR) :: tl_var
+ !----------------------------------------------------------------
+
+ ! copy variable
+ tl_var=var_copy(td_var)
+
+ ! remove variable with same name or standard name
+ CALL file_del_var(td_file, tl_var)
+
+ ! add new variable
+ CALL file_add_var(td_file, tl_var)
+
+ ! clean
+ CALL var_clean(tl_var)
+
+ END SUBROUTINE file_move_var
+ !-------------------------------------------------------------------
+ !> @brief This subroutine add a global attribute
+ !> in a file structure.
+ !> Do not overwrite, if attribute already in file structure.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] td_att attribute structure
+ !-------------------------------------------------------------------
+ SUBROUTINE file_add_att(td_file, td_att)
+ IMPLICIT NONE
+
+ ! Argument
+ TYPE(TFILE), INTENT(INOUT) :: td_file
+ TYPE(TATT), INTENT(IN) :: td_att
+
+ ! local variable
+ INTEGER(i4) :: il_status
+ INTEGER(i4) :: il_ind
+ TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ ! check if file opened
+ IF( TRIM(td_file%c_name) == '' )THEN
+
+ CALL logger_error( " FILE ADD ATT: file structure unknown ")
+ CALL logger_debug( " FILE ADD ATT: you should have used file_init before "//&
+ & "running file_add_att" )
+
+ ELSE
+
+ ! check if attribute already in file structure
+ il_ind=0
+ IF( ASSOCIATED(td_file%t_att) )THEN
+ il_ind=att_get_index( td_file%t_att(:), td_att%c_name )
+ ENDIF
+
+ IF( il_ind /= 0 )THEN
+
CALL logger_error( &
- & " DEL VAR: no variable "//TRIM(td_var%c_name)//&
- & ", in file "//TRIM(td_file%c_name) )
-
- DO ji=1,td_file%i_nvar
+ & " FILE ADD ATT: attribute "//TRIM(td_att%c_name)//&
+ & ", already in file "//TRIM(td_file%c_name) )
+
+ DO ji=1,td_file%i_natt
CALL logger_debug( &
- & " DEL VAR: in file "//TRIM(td_file%t_var(ji)%c_name)//&
- & ", standard name "//TRIM(td_file%t_var(ji)%c_stdname) )
+ & " FILE ADD ATT: in file "//TRIM(td_file%t_att(ji)%c_name) )
ENDDO
@@ -915,189 +1181,5 @@
CALL logger_trace( &
- & " DEL VAR: delete variable "//TRIM(td_var%c_name)//&
- & ", from file "//TRIM(td_file%c_name) )
-
- ALLOCATE( tl_var(td_file%i_nvar-1), stat=il_status )
- IF(il_status /= 0 )THEN
-
- CALL logger_error( &
- & " DEL VAR: not enough space to put variables from "//&
- & TRIM(td_file%c_name)//" in temporary variable structure")
-
- ELSE
-
- ! save temporary variable's file structure
- tl_var(1:il_varid-1)=td_file%t_var(1:il_varid-1)
- tl_var(il_varid:)=td_file%t_var(il_varid+1:)
-
- ! new number of variable in file
- td_file%i_nvar=td_file%i_nvar-1
-
- SELECT CASE(td_var%i_ndim)
- CASE(0)
- td_file%i_n0d=td_file%i_n0d-1
- il_rec=0
- CASE(1)
- td_file%i_n1d=td_file%i_n1d-1
- il_rec=1
- CASE(2)
- td_file%i_n2d=td_file%i_n2d-1
- il_rec=1
- CASE(3,4)
- td_file%i_n3d=td_file%i_n3d-1
- il_rec=td_file%t_dim(3)%i_len
- END SELECT
-
- DEALLOCATE( td_file%t_var )
-
- IF( td_file%i_nvar > 0 )THEN
- ALLOCATE( td_file%t_var(td_file%i_nvar), stat=il_status )
- IF(il_status /= 0 )THEN
-
- CALL logger_error( &
- & " DEL VAR: not enough space to put variables "//&
- & "in file structure "//TRIM(td_file%c_name) )
-
- ENDIF
-
- ! copy attribute in file before
- td_file%t_var(:)=tl_var(:)
-
- ! update record header index
- td_file%i_rhd = td_file%i_rhd - il_rec
-
-! ! update id
-! td_file%t_var( il_varid : td_file%i_nvar )%i_id = &
-! & td_file%t_var( il_varid : td_file%i_nvar )%i_id - 1
-
- ! update record index
- td_file%t_var( il_varid : td_file%i_nvar )%i_rec = &
- & td_file%t_var( il_varid : td_file%i_nvar )%i_rec - il_rec
-
- ! update dimension used
- td_file%t_dim(:)%l_use=.FALSE.
- DO ji=1,ip_maxdim
- IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN
- td_file%t_dim(ji)%l_use=.TRUE.
- ENDIF
- ENDDO
- CALL dim_reorder(td_file%t_dim(:))
- ! update number of dimension
- td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
-
- ENDIF
- DEALLOCATE(tl_var)
-
- ENDIF
- ENDIF
- ENDIF
-
- END SUBROUTINE file__del_var_str
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine overwrite variable structure
- !> in file structure.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] td_var : variable structure
- !> @todo
- !> - check independance td_var (cf move dim variable)
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE file_move_var(td_file, td_var)
- IMPLICIT NONE
-
- ! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- TYPE(TVAR), INTENT(IN) :: td_var
-
- ! local variable
- TYPE(TVAR) :: tl_var
- INTEGER(i4):: il_varid
- !----------------------------------------------------------------
-
- ! copy variable
- tl_var=td_var
-
- IF( ASSOCIATED(td_file%t_var) )THEN
- il_varid=var_get_id(td_file%t_var(:),TRIM(tl_var%c_name))
- IF( il_varid /= 0 )THEN
- ! remove variable with same name or standard name
- CALL file_del_var(td_file, tl_var)
- ENDIF
- ENDIF
-
- ! add new variable
- CALL file_add_var(td_file, tl_var)
-
- END SUBROUTINE file_move_var
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a global attribute
- !> in a file structure.
- !> Do not overwrite, if attribute already in file structure.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] td_att : attribute structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE file_add_att(td_file, td_att)
- IMPLICIT NONE
-
- ! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- TYPE(TATT), INTENT(IN) :: td_att
-
- ! local variable
- INTEGER(i4) :: il_status
- INTEGER(i4) :: il_attid
- TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
-
- ! loop indices
- INTEGER(i4) :: ji
- !----------------------------------------------------------------
-
- ! check if file opened
- !IF( TRIM(td_file%c_name) == "unknown" )THEN
- IF( TRIM(td_file%c_name) == '' )THEN
-
- CALL logger_error( " ADD ATT: file structure unknown ")
- CALL logger_debug( " ADD ATT: you should have used file_init before "//&
- & "running file_add_att" )
-
- ELSE
-
- ! check if attribute already in file structure
- il_attid=0
- IF( ASSOCIATED(td_file%t_att) )THEN
- il_attid=att_get_id( td_file%t_att(:), td_att%c_name )
- ENDIF
-
- IF( il_attid /= 0 )THEN
-
- CALL logger_error( &
- & " ADD ATT: attribute "//TRIM(td_att%c_name)//&
- & ", already in file "//TRIM(td_file%c_name) )
- CALL logger_flush()
-
- DO ji=1,td_file%i_natt
- CALL logger_debug( &
- & " ADD ATT: in file "//TRIM(td_file%t_att(ji)%c_name) )
- ENDDO
-
- ELSE
-
- CALL logger_debug( &
- & " ADD ATT: add attribute "//TRIM(td_att%c_name)//&
+ & " FILE ADD ATT: add attribute "//TRIM(td_att%c_name)//&
& ", in file "//TRIM(td_file%c_name) )
@@ -1108,5 +1190,5 @@
CALL logger_error( &
- & " ADD ATT: not enough space to put attributes from "//&
+ & " FILE ADD ATT: not enough space to put attributes from "//&
& TRIM(td_file%c_name)//" in temporary attribute structure")
@@ -1114,12 +1196,13 @@
! save temporary global attribute's file structure
- tl_att(:)=td_file%t_att(:)
-
- DEALLOCATE( td_file%t_att )
+ tl_att(:)=att_copy(td_file%t_att(:))
+
+ CALL att_clean( td_file%t_att(:) )
+ DEALLOCATE(td_file%t_att)
ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status )
IF(il_status /= 0 )THEN
CALL logger_error( &
- & " ADD ATT: not enough space to put attributes "//&
+ & " FILE ADD ATT: not enough space to put attributes "//&
& "in file structure "//TRIM(td_file%c_name) )
@@ -1127,28 +1210,29 @@
! copy attribute in file before
- td_file%t_att(1:td_file%i_natt)=tl_att(:)
-
+ td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:))
+
+ ! clean
+ CALL att_clean(tl_att(:))
DEALLOCATE(tl_att)
+
ENDIF
ELSE
! no attribute in file structure
IF( ASSOCIATED(td_file%t_att) )THEN
+ CALL att_clean(td_file%t_att(:))
DEALLOCATE(td_file%t_att)
ENDIF
- CALL logger_debug(" natt "//TRIM(fct_str(td_file%i_natt)) )
+
ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status )
IF(il_status /= 0 )THEN
CALL logger_error( &
- & " ADD ATT: not enough space to put attributes "//&
+ & " FILE ADD ATT: not enough space to put attributes "//&
& "in file structure "//TRIM(td_file%c_name) )
ENDIF
ENDIF
- ! add new attributes
- td_file%t_att(td_file%i_natt+1)=td_att
-
- ! update attributes id
- td_file%t_att(td_file%i_natt+1)%i_id=td_file%i_natt+1
+ ! add new attribute
+ td_file%t_att(td_file%i_natt+1)=att_copy(td_att)
! update number of attribute
@@ -1158,18 +1242,14 @@
END SUBROUTINE file_add_att
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine delete a variable structure
- !> in file structure.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] cd_name : variable name or standard name
- !-------------------------------------------------------------------
- !> @code
+ !-------------------------------------------------------------------
+ !> @brief This subroutine delete a global attribute structure
+ !> in file structure, given attribute name.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] cd_name attribute name
+ !-------------------------------------------------------------------
SUBROUTINE file__del_att_name(td_file, cd_name )
IMPLICIT NONE
@@ -1180,5 +1260,5 @@
! local variable
- INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_ind
!----------------------------------------------------------------
@@ -1186,7 +1266,7 @@
IF( TRIM(td_file%c_name) == '' )THEN
- CALL logger_error( " DEL ATT NAME: file structure unknown ")
- CALL logger_debug( " DEL ATT NAME: you should have used file_init before "//&
- & "running file_del_var" )
+ CALL logger_error( " FILE DEL ATT NAME: file structure unknown ")
+ CALL logger_debug( " FILE DEL ATT NAME: you should have "//&
+ & "used file_init before running file_del_att" )
ELSE
@@ -1195,16 +1275,17 @@
! get the variable id, in file variable structure
- il_attid=0
+ il_ind=0
IF( ASSOCIATED(td_file%t_att) )THEN
- il_attid=att_get_id(td_file%t_att(:), cd_name )
+ il_ind=att_get_index(td_file%t_att(:), cd_name )
ENDIF
- IF( il_attid /= 0 )THEN
+
+ IF( il_ind /= 0 )THEN
- CALL file_del_att(td_file, td_file%t_att(il_attid))
+ CALL file_del_att(td_file, td_file%t_att(il_ind))
ELSE
CALL logger_warn( &
- & " DEL ATT NAME: there is no attribute with name "//&
+ & " FILE DEL ATT NAME: there is no attribute with name "//&
& TRIM(cd_name)//" in file "//TRIM(td_file%c_name))
@@ -1212,6 +1293,6 @@
ELSE
- CALL logger_debug( " DEL ATT NAME: no attribute associated to file "//&
- & TRIM(td_file%c_name) )
+ CALL logger_debug( " FILE DEL ATT NAME: no attribute "//&
+ & "associated to file "//TRIM(td_file%c_name) )
ENDIF
@@ -1219,18 +1300,14 @@
END SUBROUTINE file__del_att_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine delete a global attribute structure
- !> from file structure.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] td_att : attribute structure
- !-------------------------------------------------------------------
- !> @code
+ !> from file structure, given attribute structure.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] td_att attribute structure
+ !-------------------------------------------------------------------
SUBROUTINE file__del_att_str(td_file, td_att)
IMPLICIT NONE
@@ -1242,37 +1319,35 @@
! local variable
INTEGER(i4) :: il_status
- INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_ind
TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
! loop indices
- INTEGER(i4) :: ji
!----------------------------------------------------------------
! check if file opened
- !IF( TRIM(td_file%c_name) == "unknown" )THEN
IF( TRIM(td_file%c_name) == '' )THEN
- CALL logger_error( " DEL ATT: file structure unknown ")
- CALL logger_debug( " DEL ATT: you should have used file_init before "//&
- & "running file_del_att" )
+ CALL logger_error( " FILE DEL ATT: file structure unknown ")
+ CALL logger_debug( " FILE DEL ATT: you should have used "//&
+ & "file_init before running file_del_att" )
ELSE
! check if attribute already in file structure
- il_attid=0
+ il_ind=0
IF( ASSOCIATED(td_file%t_att) )THEN
- il_attid=att_get_id( td_file%t_att(:), td_att%c_name )
- ENDIF
-
- IF( il_attid == 0 )THEN
+ il_ind=att_get_index( td_file%t_att(:), td_att%c_name )
+ ENDIF
+
+ IF( il_ind == 0 )THEN
CALL logger_error( &
- & " DEL ATT: no attribute "//TRIM(td_att%c_name)//&
+ & " FILE DEL ATT: no attribute "//TRIM(td_att%c_name)//&
& ", in file "//TRIM(td_file%c_name) )
ELSE
- CALL logger_debug( &
- & " DEL ATT: del attribute "//TRIM(td_att%c_name)//&
+ CALL logger_trace( &
+ & " FILE DEL ATT: del attribute "//TRIM(td_att%c_name)//&
& ", in file "//TRIM(td_file%c_name) )
@@ -1281,5 +1356,5 @@
CALL logger_error( &
- & " ADD ATT: not enough space to put attributes from "//&
+ & " FILE ADD ATT: not enough space to put attributes from "//&
& TRIM(td_file%c_name)//" in temporary attribute structure")
@@ -1287,8 +1362,14 @@
! save temporary global attribute's file structure
- tl_att(1:il_attid-1)=td_file%t_att(1:il_attid-1)
- tl_att(il_attid:)=td_file%t_att(il_attid+1:)
-
- DEALLOCATE( td_file%t_att )
+ IF( il_ind > 1 )THEN
+ tl_att(1:il_ind-1)=att_copy(td_file%t_att(1:il_ind-1))
+ ENDIF
+
+ IF( il_ind < td_file%i_natt )THEN
+ tl_att(il_ind:)=att_copy(td_file%t_att(il_ind+1:))
+ ENDIF
+
+ CALL att_clean( td_file%t_att(:) )
+ DEALLOCATE(td_file%t_att)
! new number of attribute in file
@@ -1299,5 +1380,5 @@
CALL logger_error( &
- & " ADD ATT: not enough space to put attributes "//&
+ & " FILE ADD ATT: not enough space to put attributes "//&
& "in file structure "//TRIM(td_file%c_name) )
@@ -1305,12 +1386,10 @@
! copy attribute in file before
- td_file%t_att(1:td_file%i_natt)=tl_att(:)
-
- ! update attribute id
- DO ji=1,td_file%i_natt
- td_file%t_att(ji)%i_id=ji
- ENDDO
-
+ td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:))
+
+ ! clean
+ CALL att_clean(tl_att(:))
DEALLOCATE(tl_att)
+
ENDIF
ENDIF
@@ -1318,20 +1397,15 @@
END SUBROUTINE file__del_att_str
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine move a global attribute structure
!> from file structure.
- !> @note attribute id could be change
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] td_att : attribute structure
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> @warning change attribute id in file structure.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] td_att attribute structure
+ !-------------------------------------------------------------------
SUBROUTINE file_move_att(td_file, td_att)
IMPLICIT NONE
@@ -1343,13 +1417,13 @@
! local variable
TYPE(TATT) :: tl_att
- INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_ind
!----------------------------------------------------------------
! copy attribute
- tl_att=td_att
+ tl_att=att_copy(td_att)
IF( ASSOCIATED(td_file%t_att) )THEN
- il_attid=att_get_id(td_file%t_att(:),TRIM(tl_att%c_name))
- IF( il_attid /= 0 )THEN
+ il_ind=att_get_index(td_file%t_att(:),TRIM(tl_att%c_name))
+ IF( il_ind /= 0 )THEN
! remove attribute with same name
CALL file_del_att(td_file, tl_att)
@@ -1360,6 +1434,8 @@
CALL file_add_att(td_file, tl_att)
+ ! clean
+ CALL att_clean(tl_att)
+
END SUBROUTINE file_move_att
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine add a dimension structure in file
@@ -1367,85 +1443,79 @@
!> Do not overwrite, if dimension already in file structure.
!
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] td_dim : dimension structure
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - do not reorder dimension, before put in file
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
SUBROUTINE file_add_dim(td_file, td_dim)
IMPLICIT NONE
! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- TYPE(TDIM), INTENT(IN) :: td_dim
-
- ! local variable
- INTEGER(i4) :: il_dimid
+ TYPE(TFILE) , INTENT(INOUT) :: td_file
+ TYPE(TDIM) , INTENT(IN ) :: td_dim
+
+ ! local variable
+ INTEGER(i4) :: il_ind
+
+ ! loop indices
+ INTEGER(i4) :: ji
!----------------------------------------------------------------
! check if file opened
- !IF( TRIM(td_file%c_name) == "unknown" )THEN
IF( TRIM(td_file%c_name) == '' )THEN
- CALL logger_error( " ADD DIM: file structure unknown ")
- CALL logger_debug( " ADD DIM: you should have used file_init before "//&
- & "running file_add_dim" )
+ CALL logger_error( " FILE ADD DIM: file structure unknown ")
+ CALL logger_debug( " FILE ADD DIM: you should have used "//&
+ & "file_init before running file_add_dim" )
ELSE
- IF( td_file%i_ndim <= 4 )THEN
+ IF( td_file%i_ndim <= ip_maxdim )THEN
! check if dimension already in file structure
- il_dimid=dim_get_id(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname)
- IF( il_dimid /= 0 )THEN
-
- CALL logger_warn("ADD DIM: dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", already in file "//TRIM(td_file%c_name) )
-
- IF( td_file%t_dim(il_dimid)%i_len /= td_dim%i_len )THEN
+ il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname)
+ IF( il_ind /= 0 )THEN
+ IF( td_file%t_dim(il_ind)%l_use )THEN
CALL logger_error( &
- & "ADD DIM: dimension "//TRIM(td_dim%c_name)//&
- & " already in file "//TRIM(td_file%c_name)//&
- & " differ from added dimension ")
+ & "FILE ADD DIM: dimension "//TRIM(td_dim%c_name)//&
+ & ", short name "//TRIM(td_dim%c_sname)//&
+ & ", already used in file "//TRIM(td_file%c_name) )
+ ELSE
+ ! replace dimension
+ td_file%t_dim(il_ind)=dim_copy(td_dim)
+ td_file%t_dim(il_ind)%i_id=il_ind
+ td_file%t_dim(il_ind)%l_use=.TRUE.
ENDIF
-
ELSE
-
- CALL logger_debug( &
- & " ADD DIM: add dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", in file "//TRIM(td_file%c_name) )
-
- IF( td_file%i_ndim == 4 )THEN
+ IF( td_file%i_ndim == ip_maxdim )THEN
+ CALL logger_error( &
+ & "FILE ADD DIM: can not add dimension "//TRIM(td_dim%c_name)//&
+ & ", short name "//TRIM(td_dim%c_sname)//&
+ & ", in file "//TRIM(td_file%c_name)//". Already "//&
+ & TRIM(fct_str(ip_maxdim))//" dimensions." )
+ ELSE
! search empty dimension
- il_dimid=dim_get_void_id(td_file%t_dim(:),TRIM(td_dim%c_name), &
- & TRIM(td_dim%c_sname))
- ! replace empty dimension
- td_file%t_dim(il_dimid)=td_dim
- td_file%t_dim(il_dimid)%i_id=il_dimid
- td_file%t_dim(il_dimid)%l_use=.TRUE.
- ELSE
- ! add new dimension
- il_dimid=dim_get_void_id(td_file%t_dim(:),TRIM(td_dim%c_name), &
- & TRIM(td_dim%c_sname))
- td_file%t_dim(il_dimid)=td_dim
- td_file%t_dim(il_dimid)%i_id=td_file%i_ndim+1
- td_file%t_dim(il_dimid)%l_use=.TRUE.
+ DO ji=1,ip_maxdim
+ IF( td_file%t_dim(ji)%i_id == 0 )THEN
+ il_ind=ji
+ EXIT
+ ENDIF
+ ENDDO
+
+ ! add new dimension
+ td_file%t_dim(il_ind)=dim_copy(td_dim)
! update number of attribute
td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
- ENDIF
-
- ! reorder dimension to ('x','y','z','t')
- CALL dim_reorder(td_file%t_dim)
-
+
+ td_file%t_dim(il_ind)%i_id=td_file%i_ndim
+ td_file%t_dim(il_ind)%l_use=.TRUE.
+ ENDIF
ENDIF
+
ELSE
CALL logger_error( &
- & " ADD DIM: too much dimension in file "//&
+ & " FILE ADD DIM: too much dimension in file "//&
& TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")")
ENDIF
@@ -1454,172 +1524,136 @@
END SUBROUTINE file_add_dim
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine delete a dimension structure in file
- !> structure.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] td_dim : dimension structure
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> structure.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
SUBROUTINE file_del_dim(td_file, td_dim)
IMPLICIT NONE
! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- TYPE(TDIM), INTENT(IN) :: td_dim
+ TYPE(TFILE) , INTENT(INOUT) :: td_file
+ TYPE(TDIM) , INTENT(IN ) :: td_dim
! local variable
INTEGER(i4) :: il_status
- INTEGER(i4) :: il_dimid
+ INTEGER(i4) :: il_ind
+
TYPE(TDIM), DIMENSION(:), ALLOCATABLE :: tl_dim
+
+ ! loop indices
+ INTEGER(i4) :: ji
!----------------------------------------------------------------
! check if file opened
- !IF( TRIM(td_file%c_name) == "unknown" )THEN
IF( TRIM(td_file%c_name) == '' )THEN
- CALL logger_error( " DEL DIM: file structure unknown ")
- CALL logger_debug( " DEL DIM: you should have used file_init before "//&
- & "running file_del_dim" )
+ CALL logger_error( " FILE DEL DIM: file structure unknown ")
+ CALL logger_debug( " FILE DEL DIM: you should have used "//&
+ & "file_init before running file_del_dim" )
ELSE
- IF( td_file%i_ndim <= 4 )THEN
-
- ! check if dimension already in file structure
- il_dimid=dim_get_id(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname)
- IF( il_dimid == 0 )THEN
+ ! check if dimension already in file structure
+ il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname)
+ IF( il_ind == 0 )THEN
+
+ CALL logger_error( &
+ & "FILE DEL DIM: no dimension "//TRIM(td_dim%c_name)//&
+ & ", short name "//TRIM(td_dim%c_sname)//&
+ & ", in file "//TRIM(td_file%c_name) )
+
+ ELSE
+ ALLOCATE( tl_dim(td_file%i_ndim-1), stat=il_status )
+ IF(il_status /= 0 )THEN
CALL logger_error( &
- & " DEL DIM: no dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", in file "//TRIM(td_file%c_name) )
-
- ELSE
-
- CALL logger_debug( &
- & " DEL DIM: delete dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", in file "//TRIM(td_file%c_name) )
-
- IF( td_file%i_ndim == 4 )THEN
- ALLOCATE( tl_dim(1), stat=il_status )
- IF(il_status /= 0 )THEN
- CALL logger_error( &
- & " DEL DIM: not enough space to put dimensions from "//&
- & TRIM(td_file%c_name)//" in temporary dimension structure")
- ELSE
- ! replace dimension by empty one
- td_file%t_dim(il_dimid)=tl_dim(1)
- ENDIF
- DEALLOCATE(tl_dim)
- ELSE
- !
- !ALLOCATE( tl_dim(td_file%i_ndim), stat=il_status )
- ALLOCATE( tl_dim(ip_maxdim), stat=il_status )
- IF(il_status /= 0 )THEN
-
- CALL logger_error( &
- & " DEL DIM: not enough space to put dimensions from "//&
- & TRIM(td_file%c_name)//" in temporary dimension structure")
-
- ELSE
-
- print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
- print *,'il_dimid '//TRIM(fct_str(il_dimid))
- CALL dim_print(td_file%t_dim(:))
- ! save temporary dimension's file structure
- tl_dim( 1 : il_dimid-1 ) = td_file%t_dim( 1 : il_dimid-1 )
- !tl_dim( il_dimid : td_file%i_ndim-1 ) = &
- !& td_file%t_dim( il_dimid+1 : td_file%i_ndim )
- tl_dim( il_dimid : ip_maxdim-1 ) = &
- & td_file%t_dim( il_dimid+1 : ip_maxdim )
- print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
- CALL dim_print(tl_dim(:))
-
- ! copy dimension in file, except one
- !td_file%t_dim(1:td_file%i_ndim)=tl_dim(:)
- td_file%t_dim(:)=tl_dim(:)
- print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
- CALL dim_print(td_file%t_dim(:))
-
- ! update number of dimension
- td_file%i_ndim=td_file%i_ndim-1
-
- ENDIF
- ENDIF
-
- ! reorder dimension to ('x','y','z','t')
- CALL dim_reorder(td_file%t_dim)
-
+ & "FILE DEL DIM: not enough space to put dimensions from "//&
+ & TRIM(td_file%c_name)//" in temporary dimension structure")
+
+ ELSE
+ ! save temporary dimension's mpp structure
+ tl_dim( 1 : il_ind-1 ) = dim_copy(td_file%t_dim(1 : il_ind-1))
+ tl_dim( il_ind : td_file%i_ndim-1 ) = &
+ & dim_copy(td_file%t_dim(il_ind+1 : td_file%i_ndim))
+
+ ! remove dimension from file
+ CALL dim_clean(td_file%t_dim(:))
+ ! copy dimension in file, except one
+ td_file%t_dim(1:td_file%i_ndim)=dim_copy(tl_dim(:))
+
+ ! update number of dimension
+ td_file%i_ndim=td_file%i_ndim-1
+
+ ! update dimension id
+ DO ji=1,td_file%i_ndim
+ td_file%t_dim(ji)%i_id=ji
+ ENDDO
+
+ ! clean
+ CALL dim_clean(tl_dim(:))
+ DEALLOCATE(tl_dim)
ENDIF
- ELSE
- CALL logger_error( &
- & " DEL DIM: too much dimension in file "//&
- & TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")")
- ENDIF
-
+ ENDIF
ENDIF
END SUBROUTINE file_del_dim
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine move a dimension structure
!> in file structure.
- !> @warning dimension order Nov have changed
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] td_dim : dimension structure
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> @warning change dimension order in file structure.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
SUBROUTINE file_move_dim(td_file, td_dim)
IMPLICIT NONE
! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- TYPE(TDIM), INTENT(IN) :: td_dim
-
- ! local variable
- TYPE(TDIM) :: tl_dim
+ TYPE(TFILE) , INTENT(INOUT) :: td_file
+ TYPE(TDIM) , INTENT(IN ) :: td_dim
+
+ ! local variable
+ INTEGER(i4) :: il_ind
INTEGER(i4) :: il_dimid
!----------------------------------------------------------------
-
- ! copy dimension
- tl_dim=td_dim
-
- il_dimid=dim_get_id(td_file%t_dim(:), TRIM(td_dim%c_name), &
- & TRIM(td_dim%c_sname))
- IF( il_dimid /= 0 )THEN
- ! remove dimension with same name
- CALL file_del_dim(td_file, tl_dim)
- ENDIF
-
- ! add new dimension
- CALL file_add_dim(td_file, tl_dim)
+ IF( td_file%i_ndim <= ip_maxdim )THEN
+
+ ! check if dimension already in mpp structure
+ il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname)
+ IF( il_ind /= 0 )THEN
+
+ il_dimid=td_file%t_dim(il_ind)%i_id
+ ! replace dimension
+ td_file%t_dim(il_ind)=dim_copy(td_dim)
+ td_file%t_dim(il_ind)%i_id=il_dimid
+ td_file%t_dim(il_ind)%l_use=.TRUE.
+
+ ELSE
+ CALL file_add_dim(td_file, td_dim)
+ ENDIF
+
+ ELSE
+ CALL logger_error( &
+ & "FILE MOVE DIM: too much dimension in mpp "//&
+ & TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")")
+ ENDIF
END SUBROUTINE file_move_dim
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine print some information about file strucutre.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE file_print(td_file)
IMPLICIT NONE
@@ -1688,19 +1722,17 @@
END SUBROUTINE file_print
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function get suffix of file name.
!> @details
!> we assume suffix is define as alphanumeric character following the
- !> last '.' in file name
+ !> last '.' in file name.
!> If no suffix is found, return empty character.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_file : file structure
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_file file structure
!> @return suffix
!-------------------------------------------------------------------
- !> @code
CHARACTER(LEN=lc) FUNCTION file__get_suffix(cd_file)
IMPLICIT NONE
@@ -1713,5 +1745,5 @@
!----------------------------------------------------------------
- CALL logger_trace( "GET SUFFIX: look for suffix in file name "//&
+ CALL logger_trace( "FILE GET SUFFIX: look for suffix in file name "//&
& TRIM(cd_file) )
@@ -1721,5 +1753,5 @@
READ( cd_file(il_ind:),'(a)' ) file__get_suffix
- IF( fct_is_num(file__get_suffix) )THEN
+ IF( fct_is_num(file__get_suffix(2:)) )THEN
file__get_suffix=''
ENDIF
@@ -1730,18 +1762,16 @@
END FUNCTION file__get_suffix
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function get number in file name without suffix.
!> @details
!> Actually it get the number following the last separator.
- !> separator could be '.' or '_'
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_file : file name (without suffix)
- !> @return file structure
- !-------------------------------------------------------------------
- !> @code
+ !> separator could be '.' or '_'.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_file file name (without suffix)
+ !> @return character file number.
+ !-------------------------------------------------------------------
CHARACTER(LEN=lc) FUNCTION file__get_number(cd_file)
IMPLICIT NONE
@@ -1760,6 +1790,6 @@
! get number position in file name
il_indmax=0
- DO ji=1,ig_nsep
- il_ind=INDEX(TRIM(cd_file),TRIM(cg_sep(ji)),BACK=.TRUE.)
+ DO ji=1,ip_nsep
+ il_ind=INDEX(TRIM(cd_file),TRIM(cp_sep(ji)),BACK=.TRUE.)
IF( il_ind > il_indmax )THEN
il_indmax=il_ind
@@ -1779,7 +1809,6 @@
END FUNCTION file__get_number
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function rename file name.
+ !-------------------------------------------------------------------
+ !> @brief This function rename file name, given processor number.
!> @details
!> If no processor number is given, return file name without number
@@ -1787,11 +1816,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_num : processor number (start to 1)
- !> @return file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_num processor number (start to 1)
+ !> @return file name
+ !-------------------------------------------------------------------
CHARACTER(LEN=lc) FUNCTION file__rename_char(cd_file, id_num)
IMPLICIT NONE
@@ -1841,8 +1869,7 @@
WRITE(file__rename_char,'(a,a)') TRIM(cl_base),TRIM(cl_suffix)
ENDIF
- CALL logger_trace(" RENAME : "//TRIM(file__rename_char))
+ CALL logger_trace(" FILE RENAME : "//TRIM(file__rename_char))
END FUNCTION file__rename_char
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function rename file name, given file structure.
@@ -1852,11 +1879,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_num : processor number (start to 1)
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_num processor number (start to 1)
!> @return file structure
!-------------------------------------------------------------------
- !> @code
TYPE(TFILE) FUNCTION file__rename_str(td_file, id_num)
IMPLICIT NONE
@@ -1876,15 +1902,13 @@
END FUNCTION file__rename_str
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function add suffix to file name.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @return file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @return file name
+ !-------------------------------------------------------------------
CHARACTER(LEN=lc) FUNCTION file_add_suffix(cd_file, cd_type)
IMPLICIT NONE
@@ -1918,20 +1942,18 @@
ENDIF
CASE DEFAULT
- CALL logger_error( " ADD SUFFIX: type unknown "//TRIM(cd_type) )
+ CALL logger_error(" FILE ADD SUFFIX: type unknown "//TRIM(cd_type))
END SELECT
END FUNCTION file_add_suffix
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine clean mpp strcuture.
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE file_clean( td_file )
+ !> This subroutine clean file strcuture.
+ !
+ !> @author J.Paul
+ !> @date November, 2013 - Inital version
+ !
+ !> @param[inout] td_file file strcuture
+ !-------------------------------------------------------------------
+ SUBROUTINE file__clean_unit( td_file )
IMPLICIT NONE
! Argument
@@ -1942,50 +1964,65 @@
! loop indices
- INTEGER(i4) :: ji
- !----------------------------------------------------------------
-
- CALL logger_info( &
- & " CLEAN: reset file "//TRIM(td_file%c_name) )
+ !----------------------------------------------------------------
+
+ CALL logger_trace( &
+ & " FILE CLEAN: reset file "//TRIM(td_file%c_name) )
! del attribute
IF( ASSOCIATED( td_file%t_att ) )THEN
- DO ji=td_file%i_natt,1,-1
- CALL att_clean( td_file%t_att(ji) )
- ENDDO
- DEALLOCATE( td_file%t_att )
+ CALL att_clean( td_file%t_att(:) )
+ DEALLOCATE(td_file%t_att)
ENDIF
! del dimension
IF( td_file%i_ndim /= 0 )THEN
- DO ji=td_file%i_ndim,1,-1
- CALL dim_clean( td_file%t_dim(ji) )
- ENDDO
+ CALL dim_clean( td_file%t_dim(:) )
ENDIF
! del variable
IF( ASSOCIATED( td_file%t_var ) )THEN
- DO ji=td_file%i_nvar,1,-1
- CALL var_clean( td_file%t_var(ji) )
- ENDDO
- DEALLOCATE( td_file%t_var )
+ CALL var_clean( td_file%t_var(:) )
+ DEALLOCATE(td_file%t_var)
ENDIF
! replace by empty structure
- td_file=tl_file
-
- END SUBROUTINE file_clean
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function return the file id, in a table of file
- !> structure, given file name
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : table of file structure
- !> @param[in] cd_name : file name
- !> @return file id in table of file structure (0 if not found)
- !-------------------------------------------------------------------
- !> @code
+ td_file=file_copy(tl_file)
+
+ END SUBROUTINE file__clean_unit
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine clean file array of file strcuture.
+ !
+ !> @author J.Paul
+ !> @date Marsh, 2014 - Inital version
+ !
+ !> @param[inout] td_file array file strcuture
+ !-------------------------------------------------------------------
+ SUBROUTINE file__clean_arr( td_file )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TFILE), DIMENSION(:), INTENT(INOUT) :: td_file
+
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ DO ji=SIZE(td_file(:)),1,-1
+ CALL file_clean(td_file(ji))
+ ENDDO
+
+ END SUBROUTINE file__clean_arr
+ !-------------------------------------------------------------------
+ !> @brief This function return the file id, in a array of file
+ !> structure, given file name.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file array of file structure
+ !> @param[in] cd_name file name
+ !> @return file id in array of file structure (0 if not found)
+ !-------------------------------------------------------------------
INTEGER(i4) FUNCTION file_get_id(td_file, cd_name)
IMPLICIT NONE
@@ -2003,11 +2040,10 @@
il_size=SIZE(td_file(:))
- ! check if file is in table of file structure
+ ! check if file is in array of file structure
DO ji=1,il_size
! look for file name
- CALL logger_debug(" cd_name "//TRIM(fct_lower(cd_name)) )
IF( fct_lower(td_file(ji)%c_name) == fct_lower(cd_name) )THEN
- file_get_id=ji
+ file_get_id=td_file(ji)%i_id
EXIT
@@ -2016,5 +2052,28 @@
END FUNCTION file_get_id
- !> @endcode
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This function get the next unused unit in array of file structure.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !
+ !> @param[in] td_file array of file
+ !-------------------------------------------------------------------
+ FUNCTION file_get_unit(td_file)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_file
+
+ ! function
+ INTEGER(i4) :: file_get_unit
+
+ ! local variable
+ ! loop indices
+ !----------------------------------------------------------------
+
+ file_get_unit=MAXVAL(td_file(:)%i_id)+1
+
+ END FUNCTION file_get_unit
END MODULE file
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/filter.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/filter.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/filter.f90 (revision 5214)
@@ -6,20 +6,57 @@
!
! DESCRIPTION:
-!> @brief filter manager
+!> @brief This module is filter manager.
!>
-!> @details
+!> @details Filtering method to be used is specify inside variable strcuture,
+!> as array of string character.
+!> td_var\%c_filter(1) string character is the filter name choose between:
+!> - 'hann'
+!> - rad < cutoff : @f$ filter=0.5+0.5*COS(\pi*\frac{rad}{cutoff}) @f$
+!> - rad > cutoff : @f$ filter=0 @f$
+!> - 'hamming'
+!> - rad < cutoff : @f$ filter=0.54+0.46*COS(\pi*\frac{rad}{cutoff}) @f$
+!> - rad > cutoff : @f$ filter=0 @f$
+!> - 'blackman'
+!> - rad < cutoff : @f$ filter=0.42 + 0.5*COS(\pi*\frac{rad}{cutoff}) + 0.08*COS(2\pi*\frac{rad}{cutoff}) @f$
+!> - rad > cutoff : @f$ filter=0 @f$
+!> - 'gauss'
+!> - @f$filter=exp(-(\alpha * rad^2) / (2*cutoff^2))@f$
+!> - 'butterworth'
+!> - @f$ filer=1 / (1+(rad^2 / cutoff^2)^{\alpha}) @f$
+!> .
+!>
+!> with @f$ rad= \sqrt{(dist-radius)^2} @f$
+!>
+!> td_var\%c_filter(2) string character is the number of turn to be done
+!> td_var\%c_filter(3) string character is the cut-off frequency (count in number of mesh grid)
+!> td_var\%c_filter(4) string character is the halo radius (count in number of mesh grid)
+!> td_var\%c_filter(5) string character is the alpha parameter (for gauss and butterworth method)
+!>
+!> @note Filter method could be specify for each variable in namelist _namvar_,
+!> defining string character _cn\_varinfo_. None by default.
+!> Filter method parameters are informed inside bracket.
+!> - @f$\alpha@f$ parameter is added for _gauss_ and _butterworth_ methods
!>
+!> The number of turn is specify using '*' separator.
+!> Example:
+!> - cn_varinfo='varname1:2*hamming(@f$cutoff@f$,@f$radius@f$)', 'varname2:gauss(@f$cutoff@f$,@f$radius@f$,@f$\alpha@f$)'
+!>
+!> to filter variable value:
+!> @code
+!> CALL filter_fill_value( td_var )
+!> @endcode
+!> - td_var is variable structure
+!>
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
+!> @date November, 2013 - Initial Version
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!> @todo
!----------------------------------------------------------------------
MODULE filter
USE kind ! F90 kind parameter
USE phycst ! physical constant
- USE logger ! log file manager
+ USE logger ! log file manager
USE fct ! basic usefull function
use att ! attribute manager
@@ -27,5 +64,4 @@
USE extrap ! extrapolation manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
@@ -34,17 +70,25 @@
! function and subroutine
- PUBLIC :: filter_fill_value
-
- PRIVATE :: filter__fill_value_wrapper
- PRIVATE :: filter__fill_value
- PRIVATE :: filter__3D_fill_value
- PRIVATE :: filter__2D_fill_value
- PRIVATE :: filter__2D
- PRIVATE :: filter__2D_coef
- PRIVATE :: filter__2D_hann
- PRIVATE :: filter__2D_hamming
- PRIVATE :: filter__2D_blackman
- PRIVATE :: filter__2D_gauss
- PRIVATE :: filter__2D_butterworth
+ PUBLIC :: filter_fill_value !< filter variable value
+
+ PRIVATE :: filter__fill_value_wrapper !
+ PRIVATE :: filter__fill_value !
+ PRIVATE :: filter__3D_fill_value !
+ PRIVATE :: filter__2D_fill_value !
+ PRIVATE :: filter__2D !
+ PRIVATE :: filter__2D_coef !
+ PRIVATE :: filter__2D_hann !
+ PRIVATE :: filter__2D_hamming !
+ PRIVATE :: filter__2D_blackman !
+ PRIVATE :: filter__2D_gauss !
+ PRIVATE :: filter__2D_butterworth !
+ PRIVATE :: filter__1D_fill_value !
+ PRIVATE :: filter__1D !
+ PRIVATE :: filter__1D_coef !
+ PRIVATE :: filter__1D_hann !
+ PRIVATE :: filter__1D_hamming !
+ PRIVATE :: filter__1D_blackman !
+ PRIVATE :: filter__1D_gauss !
+ PRIVATE :: filter__1D_butterworth !
INTERFACE filter_fill_value
@@ -55,14 +99,15 @@
!-------------------------------------------------------------------
!> @brief
- !> This subroutine filtering variable value.
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable
- !-------------------------------------------------------------------
- !> @code
+ !> This subroutine filter variable value.
+ !>
+ !> @details
+ !> it checks if filtering method is available,
+ !> gets parameter value, and launch filter__fill_value
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE filter__fill_value_wrapper( td_var )
IMPLICIT NONE
@@ -85,5 +130,5 @@
IF( .NOT. ASSOCIATED(td_var%d_value) )THEN
- CALL logger_error("FILTER FILL VALUE: no table of value "//&
+ CALL logger_error("FILTER FILL VALUE: no array of value "//&
& "associted to variable "//TRIM(td_var%c_name) )
ELSE
@@ -93,5 +138,5 @@
CASE DEFAULT
- CALL logger_info("FILTER FILL VALUE: no filter selected "//&
+ CALL logger_trace("FILTER FILL VALUE: no filter selected "//&
& "for variable "//TRIM(td_var%c_name))
@@ -181,5 +226,7 @@
tl_att=att_init('filter',cl_filter)
CALL var_move_att(td_var,tl_att)
-
+ ! clean
+ CALL att_clean(tl_att)
+
DO jl=1,il_nturn
CALL filter__fill_value( td_var, TRIM(cl_method), &
@@ -192,21 +239,23 @@
ENDIF
END SUBROUTINE filter__fill_value_wrapper
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine filtering variable value.
+ !> This subroutine filtering variable value, given cut-off frequency
+ !> halo radius and alpha parameter.
!>
!> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable
- !> @param[in] cd_name : filter name
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @param[in] dd_alpha : filter parameter
- !-------------------------------------------------------------------
- !> @code
+ !> First extrabands are added to array of variable value.
+ !> Then values are extrapolated, before apply filter.
+ !> Finally extrabands are removed.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable
+ !> @param[in] cd_name filter name
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @param[in] dd_alpha filter parameter
+ !-------------------------------------------------------------------
SUBROUTINE filter__fill_value( td_var, cd_name, &
& dd_cutoff, id_radius, dd_alpha )
@@ -274,28 +323,31 @@
END WHERE
+ ! clean
+ CALL var_clean(tl_mask)
+
!6-remove extraband
CALL extrap_del_extrabands(td_var, id_radius, id_radius)
END SUBROUTINE filter__fill_value
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine compute filtered value of 3D table.
- !>
- !> @details
- !>
- !> @warning table of value should have been already extrapolated before
+ !-------------------------------------------------------------------
+ !> @brief This subroutine compute filtered value of 3D array.
+ !>
+ !> @details
+ !> First compute filter coefficient.
+ !> Then apply it on each level of variable value.
+ !>
+ !> @warning array of value should have been already extrapolated before
!> running this subroutine.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] dd_value : table of value to be filtered
- !> @param[in] dd_fill : fill value
- !> @param[in] cd_name : filter name
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @param[in] dd_alpha : filter parameter
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] dd_value array of value to be filtered
+ !> @param[in] dd_fill fill value
+ !> @param[in] cd_name filter name
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @param[in] dd_alpha filter parameter
+ !-------------------------------------------------------------------
SUBROUTINE filter__3D_fill_value( dd_value, dd_fill, cd_name, &
& dd_cutoff, id_radius, dd_alpha)
@@ -330,24 +382,24 @@
END SUBROUTINE filter__3D_fill_value
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine compute filtered value of 2D table.
- !
- !> @details
- !
- !> @warning table of value should have been already extrapolated before
+ !-------------------------------------------------------------------
+ !> @brief This subroutine compute filtered value of 2D array.
+ !
+ !> @details
+ !> First compute filter coefficient.
+ !> Then apply it on variable value.
+ !>
+ !> @warning array of value should have been already extrapolated before
!> running this subroutine.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] dd_value : table of value to be filtered
- !> @param[in] dd_fill : fill value
- !> @param[in] cd_name : filter name
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @param[in] dd_alpha : filter parameter
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] dd_value array of value to be filtered
+ !> @param[in] dd_fill fill value
+ !> @param[in] cd_name filter name
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @param[in] dd_alpha filter parameter
+ !-------------------------------------------------------------------
SUBROUTINE filter__2D_fill_value( dd_value, dd_fill, cd_name, &
& dd_cutoff, id_radius, dd_alpha)
@@ -376,24 +428,24 @@
END SUBROUTINE filter__2D_fill_value
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine compute filtered value of 1D table.
- !
- !> @details
- !
- !> @warning table of value should have been already extrapolated before
+ !-------------------------------------------------------------------
+ !> @brief This subroutine compute filtered value of 1D array.
+ !
+ !> @details
+ !> First compute filter coefficient.
+ !> Then apply it on variable value.
+ !>
+ !> @warning array of value should have been already extrapolated before
!> running this subroutine.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] dd_value : table of value to be filtered
- !> @param[in] dd_fill : fill value
- !> @param[in] cd_name : filter name
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @param[in] dd_alpha : filter parameter
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] dd_value array of value to be filtered
+ !> @param[in] dd_fill fill value
+ !> @param[in] cd_name filter name
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @param[in] dd_alpha filter parameter
+ !-------------------------------------------------------------------
SUBROUTINE filter__1D_fill_value( dd_value, dd_fill, cd_name, &
& dd_cutoff, id_radius, dd_alpha)
@@ -422,23 +474,19 @@
END SUBROUTINE filter__1D_fill_value
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine
- !
- !> @details
- !
- !> @note
- !> if fill value are detected in the computing area,
- !> no filtering is done.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] dd_value : table of value to be filtered
- !> @param[in] dd_fill : fill value
- !> @param[in] dd_coef : filter coefficent table
- !> @param[in] id_radius : filter halo radius
- !-------------------------------------------------------------------
- !> @code
+ !-------------------------------------------------------------------
+ !> @brief This subroutine filtered 2D array of value
+ !>
+ !> @details
+ !> loop on first and second dimension,
+ !> and apply coefficient 2D array on each point
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] dd_value array of value to be filtered
+ !> @param[in] dd_fill fill value
+ !> @param[in] dd_coef filter coefficent array
+ !> @param[in] id_radius filter halo radius
+ !-------------------------------------------------------------------
SUBROUTINE filter__2D(dd_value, dd_fill, dd_coef, id_radius)
IMPLICIT NONE
@@ -452,5 +500,5 @@
INTEGER(i4), DIMENSION(2) :: il_shape
REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_value
- REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_area
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_halo
! loop indices
@@ -463,39 +511,37 @@
dl_value(:,:)=dd_value(:,:)
- ALLOCATE(dl_area(2*id_radius+1,2*id_radius+1))
+ ALLOCATE(dl_halo(2*id_radius+1,2*id_radius+1))
DO jj=1+id_radius,il_shape(2)-id_radius
DO ji=1+id_radius,il_shape(1)-id_radius
- dl_area(:,:)=dd_fill
- dl_area(:,:)=dl_value(ji-id_radius:ji+id_radius, &
+ dl_halo(:,:)=dd_fill
+ dl_halo(:,:)=dl_value(ji-id_radius:ji+id_radius, &
& jj-id_radius:jj+id_radius)
- IF( ALL(dl_area(:,:)/=dd_fill) )THEN
- dd_value(ji,jj)=SUM(dl_area(:,:)*dd_coef(:,:))
- ENDIF
+ dd_value(ji,jj)=SUM(dl_halo(:,:)*dd_coef(:,:))
ENDDO
ENDDO
- DEALLOCATE(dl_area)
+ DEALLOCATE(dl_halo)
DEALLOCATE(dl_value)
END SUBROUTINE filter__2D
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine
- !
- !> @details
- !
+ !-------------------------------------------------------------------
+ !> @brief This subroutine filtered 1D array of value
+ !
+ !> @details
+ !> loop on first dimension,
+ !> and apply coefficient 1D array on each point
+ !>
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
- !> @param[inout] dd_value : table of value to be filtered
- !> @param[in] dd_fill : fill value
- !> @param[in] dd_coef : filter coefficent table
- !> @param[in] id_radius : filter halo radius
- !-------------------------------------------------------------------
- !> @code
+ !> @param[inout] dd_value array of value to be filtered
+ !> @param[in] dd_fill fill value
+ !> @param[in] dd_coef filter coefficent array
+ !> @param[in] id_radius filter halo radius
+ !-------------------------------------------------------------------
SUBROUTINE filter__1D(dd_value, dd_fill, dd_coef, id_radius)
IMPLICIT NONE
@@ -507,5 +553,5 @@
! local variable
- INTEGER(i4), DIMENSION(1) :: il_shape
+ INTEGER(i4), DIMENSION(1) :: il_shape
REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value
@@ -519,14 +565,8 @@
DO ji=1+id_radius,il_shape(1)-id_radius
+ dl_value(:)=dd_fill
dl_value(:)=dd_value(ji-id_radius:ji+id_radius)
- IF( ANY(dl_value(:)==dd_fill) )THEN
- CALL logger_error("FILTER FILL VALUE: fill value detected. "//&
- & " can't compute filtered value. "//&
- & "you should have extrapolate table before running "//&
- & " filter_fill_value")
- ELSE
- dd_value(ji)=SUM(dl_value(:)*dd_coef(:))
- ENDIF
+ dd_value(ji)=SUM(dl_value(:)*dd_coef(:))
ENDDO
@@ -535,5 +575,4 @@
END SUBROUTINE filter__1D
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute filter coefficient.
@@ -548,16 +587,15 @@
!> - butterworth
!> Cut-off frequency could be specify.
- !> As well as a filter parameter for gauss an butterworth filter
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : filter name
- !> @param[in] dd_cutoff : cut-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @param[in] dd_alpha : filter parameter
- !> @return table of filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !> As well as a filter parameter for gauss and butterworth filter
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name filter name
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @param[in] dd_alpha filter parameter
+ !> @return array of filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__2D_coef(cd_name, dd_cutoff, id_radius, dd_alpha)
IMPLICIT NONE
@@ -596,5 +634,4 @@
END FUNCTION filter__2D_coef
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute filter coefficient.
@@ -612,13 +649,12 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : filter name
- !> @param[in] dd_cutoff : cut-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @param[in] dd_alpha : filter parameter
- !> @return table of filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name filter name
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @param[in] dd_alpha filter parameter
+ !> @return array of filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__1D_coef(cd_name, dd_cutoff, id_radius, dd_alpha)
IMPLICIT NONE
@@ -653,5 +689,4 @@
END FUNCTION filter__1D_coef
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute coefficient for HANN filter.
@@ -660,11 +695,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @return table of hann filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @return array of hann filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__1D_hann(dd_cutoff, id_radius)
IMPLICIT NONE
@@ -695,5 +729,5 @@
IF( dl_rad < dd_cutoff )THEN
- filter__1D_hann(ji)=0.5 + 0.5*COS(dg_pi*dl_rad/dd_cutoff)
+ filter__1D_hann(ji)=0.5 + 0.5*COS(dp_pi*dl_rad/dd_cutoff)
ELSE
filter__1D_hann(ji)=0
@@ -709,5 +743,4 @@
END FUNCTION filter__1D_hann
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute coefficient for HANN filter.
@@ -716,11 +749,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @return table of hann filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @return array of hann filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__2D_hann(dd_cutoff, id_radius)
IMPLICIT NONE
@@ -755,5 +787,5 @@
IF( dl_rad < dd_cutoff )THEN
- filter__2D_hann(ji,jj)=0.5 + 0.5*COS(dg_pi*dl_rad/dd_cutoff)
+ filter__2D_hann(ji,jj)=0.5 + 0.5*COS(dp_pi*dl_rad/dd_cutoff)
ELSE
filter__2D_hann(ji,jj)=0
@@ -770,5 +802,4 @@
END FUNCTION filter__2D_hann
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute coefficient for HAMMING filter.
@@ -777,11 +808,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @return table of hamming filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @return array of hamming filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__1D_hamming(dd_cutoff, id_radius)
IMPLICIT NONE
@@ -813,5 +843,5 @@
IF( dl_rad < dd_cutoff )THEN
filter__1D_hamming(ji)= 0.54 &
- & + 0.46*COS(dg_pi*dl_rad/dd_cutoff)
+ & + 0.46*COS(dp_pi*dl_rad/dd_cutoff)
ELSE
filter__1D_hamming(ji)=0
@@ -827,5 +857,4 @@
END FUNCTION filter__1D_hamming
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute coefficient for HAMMING filter.
@@ -834,11 +863,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @return table of hamming filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @return array of hamming filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__2D_hamming(dd_cutoff, id_radius)
IMPLICIT NONE
@@ -873,5 +901,5 @@
IF( dl_rad < dd_cutoff )THEN
filter__2D_hamming(ji,jj)= 0.54 &
- & + 0.46*COS(dg_pi*dl_rad/dd_cutoff)
+ & + 0.46*COS(dp_pi*dl_rad/dd_cutoff)
ELSE
filter__2D_hamming(ji,jj)=0
@@ -888,5 +916,4 @@
END FUNCTION filter__2D_hamming
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute coefficient for BLACKMAN filter.
@@ -895,11 +922,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @return table of blackman filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @return array of blackman filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__1D_blackman(dd_cutoff, id_radius)
IMPLICIT NONE
@@ -931,6 +957,6 @@
IF( dl_rad < dd_cutoff )THEN
filter__1D_blackman(ji)= 0.42 &
- & + 0.5 *COS( dg_pi*dl_rad/dd_cutoff) &
- & + 0.08*COS(2*dg_pi*dl_rad/dd_cutoff)
+ & + 0.5 *COS( dp_pi*dl_rad/dd_cutoff) &
+ & + 0.08*COS(2*dp_pi*dl_rad/dd_cutoff)
ELSE
filter__1D_blackman(ji)=0
@@ -946,18 +972,16 @@
END FUNCTION filter__1D_blackman
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute coefficient for BLACKMAN filter.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @return table of blackman filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @return array of blackman filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__2D_blackman(dd_cutoff, id_radius)
IMPLICIT NONE
@@ -992,6 +1016,6 @@
IF( dl_rad < dd_cutoff )THEN
filter__2D_blackman(ji,jj)= 0.42 &
- & + 0.5 *COS( dg_pi*dl_rad/dd_cutoff) &
- & + 0.08*COS(2*dg_pi*dl_rad/dd_cutoff)
+ & + 0.5 *COS( dp_pi*dl_rad/dd_cutoff) &
+ & + 0.08*COS(2*dp_pi*dl_rad/dd_cutoff)
ELSE
filter__2D_blackman(ji,jj)=0
@@ -1008,19 +1032,17 @@
END FUNCTION filter__2D_blackman
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute coefficient for GAUSS filter.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @param[in] dd_alpha : filter parameter
- !> @return table of gauss filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @param[in] dd_alpha filter parameter
+ !> @return array of gauss filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__1D_gauss(dd_cutoff, id_radius, dd_alpha)
IMPLICIT NONE
@@ -1062,19 +1084,17 @@
END FUNCTION filter__1D_gauss
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute coefficient for GAUSS filter.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @param[in] dd_alpha : filter parameter
- !> @return table of gauss filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @param[in] dd_alpha filter parameter
+ !> @return array of gauss filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__2D_gauss(dd_cutoff, id_radius, dd_alpha)
IMPLICIT NONE
@@ -1120,19 +1140,17 @@
END FUNCTION filter__2D_gauss
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute coefficient for BUTTERWORTH filter.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @param[in] dd_alpha : filter parameter
- !> @return table of butterworth filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @param[in] dd_alpha filter parameter
+ !> @return array of butterworth filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__1D_butterworth(dd_cutoff, id_radius, dd_alpha)
IMPLICIT NONE
@@ -1174,19 +1192,17 @@
END FUNCTION filter__1D_butterworth
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function compute coefficient for BUTTERWORTH filter.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_cutoff : cuto-off frequency
- !> @param[in] id_radius : filter halo radius
- !> @param[in] dd_alpha : filter parameter
- !> @return table of butterworth filter coefficient
- !-------------------------------------------------------------------
- !> @code
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] dd_cutoff cut-off frequency
+ !> @param[in] id_radius filter halo radius
+ !> @param[in] dd_alpha filter parameter
+ !> @return array of butterworth filter coefficient
+ !-------------------------------------------------------------------
FUNCTION filter__2D_butterworth(dd_cutoff, id_radius, dd_alpha)
IMPLICIT NONE
@@ -1232,46 +1248,4 @@
END FUNCTION filter__2D_butterworth
- !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This function
-! !
-! !> @details
-! !
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !-------------------------------------------------------------------
-! !> @code
-! FUNCTION filter_()
-! IMPLICIT NONE
-! ! Argument
-! ! function
-! ! local variable
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END FUNCTION filter_
-! !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This subroutine
-! !
-! !> @details
-! !
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !-------------------------------------------------------------------
-! !> @code
-! SUBROUTINE filter_()
-! IMPLICIT NONE
-! ! Argument
-! ! local variable
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END SUBROUTINE filter_
-! !> @endcode
END MODULE filter
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/function.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/function.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/function.f90 (revision 5214)
@@ -7,14 +7,87 @@
! DESCRIPTION:
!> @brief
-!> This module group some basic useful function
-!
+!> This module groups some basic useful function.
+!>
+!> @details
+!> to get free I/O unit number:
+!> @code
+!> il_id=fct_getunit()
+!> @endcode
+!>
+!> to convert "numeric" to string character:
+!> @code
+!> cl_string=fct_str(numeric)
+!> @endcode
+!> - "numeric" could be integer, real, or logical
+!>
+!> to concatenate "numeric" to a string character:
+!> @code
+!> cl_str=cd_char//num
+!> @endcode
+!> - cd_char is the string character
+!> - num is the numeric value (integer, real or logical)
+!>
+!> to concatenate all the element of a character array:
+!> @code
+!> cl_string=fct_concat(cd_arr [,cd_sep])
+!> @endcode
+!> - cd_arr is a 1D array of character
+!> - cd_sep is a separator character to add between each element of cd_arr
+!> [optional]
+!>
+!> to convert character from lower to upper case:
+!> @code
+!> cl_upper=fct_upper(cd_var)
+!> @endcode
+!>
+!> to convert character from upper to lower case:
+!> @code
+!> cl_lower=fct_lower(cd_var)
+!> @endcode
+!>
+!> to check if character is numeric
+!> @code
+!> ll_is_num=fct_is_num(cd_var)
+!> @endcode
+!>
+!> to split string into substring and return one of the element:
+!> @code
+!> cl_str=fct_split(cd_string ,id_ind [,cd_sep])
+!> @endcode
+!> - cd_string is a string of character
+!> - id_ind is the indice of the lement to extract
+!> - cd_sep is the separator use to split cd_string (default '|')
+!>
+!> to get basename (name without path):
+!> @code
+!> cl_str=fct_basename(cd_string [,cd_sep])
+!> @endcode
+!> - cd_string is the string filename
+!> - cd_sep is the separator ti be used (default '/')
+!>
+!> to get dirname (path of the filename):
+!> @code
+!> cl_str=fct_dirname(cd_string [,cd_sep])
+!> @endcode
+!> - cd_string is the string filename
+!> - cd_sep is the separator ti be used (default '/')
+!>
+!> to create a pause statement:
+!> @code
+!> CALL fct_pause(cd_msg)
+!> @endcode
+!> - cd_msg : message to be added [optional]
+!>
+!> to handle frotran error:
+!> @code
+!> CALL fct_err(id_status)
+!> @endcode
+!>
+!>
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
-!> @todo
-!> - TODO_describe_appropriate_changes - TODO_name
-!> @param MyModule_type : brief_description
+!> @date November, 2013 - Initial Version
+!> @date September, 2014 - add header
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
@@ -23,19 +96,19 @@
USE kind ! F90 kind parameter
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! function and subroutine
- PUBLIC :: OPERATOR(//)
- PUBLIC :: fct_getunit! returns free unit number
- PUBLIC :: fct_err ! handle fortran error status
- PUBLIC :: fct_str ! convert numeric to string character
- PUBLIC :: fct_concat ! concatenate all the element of a character table
- PUBLIC :: fct_upper ! convert lower character to upper case
- PUBLIC :: fct_lower ! convert upper character to lower case
- PUBLIC :: fct_is_num ! check if character is numeric
- PUBLIC :: fct_split ! split string into substring
- PUBLIC :: fct_basename ! return basename (name without path)
- PUBLIC :: fct_dirname ! return dirname (path without name)
+ PUBLIC :: fct_getunit !< returns free unit number
+ PUBLIC :: fct_str !< convert numeric to string character
+ PUBLIC :: OPERATOR(//) !< concatenate operator
+ PUBLIC :: fct_concat !< concatenate all the element of a character array
+ PUBLIC :: fct_upper !< convert character from lower to upper case
+ PUBLIC :: fct_lower !< convert character from upper to lower case
+ PUBLIC :: fct_is_num !< check if character is numeric
+ PUBLIC :: fct_split !< split string into substring
+ PUBLIC :: fct_basename !< return basename (name without path)
+ PUBLIC :: fct_dirname !< return dirname (path without filename)
+ PUBLIC :: fct_pause !< pause statement
+ PUBLIC :: fct_err !< handle fortran error status
PRIVATE :: fct__i1_str ! convert integer(1) to string character
@@ -46,5 +119,12 @@
PRIVATE :: fct__r8_str ! convert real(8) to string character
PRIVATE :: fct__l_str ! convert logical to string character
-
+ PRIVATE :: fct__i1_cat ! concatenate integer(1) to string character
+ PRIVATE :: fct__i2_cat ! concatenate integer(2) to string character
+ PRIVATE :: fct__i4_cat ! concatenate integer(4) to string character
+ PRIVATE :: fct__i8_cat ! concatenate integer(8) to string character
+ PRIVATE :: fct__r4_cat ! concatenate real(4) to string character
+ PRIVATE :: fct__r8_cat ! concatenate real(8) to string character
+ PRIVATE :: fct__l_cat ! concatenate logical to string character
+ PRIVATE :: fct__split_space ! split string into substring using space as separator
INTERFACE fct_str
@@ -59,4 +139,6 @@
INTERFACE OPERATOR(//)
+ MODULE PROCEDURE fct__i1_cat ! concatenate integer(1) to string character
+ MODULE PROCEDURE fct__i2_cat ! concatenate integer(2) to string character
MODULE PROCEDURE fct__i4_cat ! concatenate integer(4) to string character
MODULE PROCEDURE fct__i8_cat ! concatenate integer(8) to string character
@@ -68,12 +150,61 @@
CONTAINS
!-------------------------------------------------------------------
- !> @brief This routine concatenate character and integer(4) (as character).
+ !> @brief This function concatenate character and integer(1) (as character).
+ !
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !
+ !> @param[in] cd_char string character
+ !> @param[in] bd_val integer(1) variable value
+ !> @return string character
+ !-------------------------------------------------------------------
+ PURE CHARACTER(LEN=lc) FUNCTION fct__i1_cat(cd_char, bd_val)
+
+ ! arguments
+ CHARACTER(LEN=lc), INTENT(IN) :: cd_char
+ INTEGER(i1), INTENT(IN) :: bd_val
+
+ ! local variable
+ CHARACTER(LEN=lc) :: cl_val
+ !----------------------------------------------------------------
+
+ cl_val = fct_str(bd_val)
+ fct__i1_cat=TRIM(cd_char)//TRIM(cl_val)
+
+ END FUNCTION fct__i1_cat
+ !-------------------------------------------------------------------
+ !> @brief This function concatenate character and integer(2) (as character).
+ !
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !
+ !> @param[in] cd_char string character
+ !> @param[in] sd_val integer(2) variable value
+ !> @return string character
+ !-------------------------------------------------------------------
+ PURE CHARACTER(LEN=lc) FUNCTION fct__i2_cat(cd_char, sd_val)
+
+ ! arguments
+ CHARACTER(LEN=lc), INTENT(IN) :: cd_char
+ INTEGER(i2), INTENT(IN) :: sd_val
+
+ ! local variable
+ CHARACTER(LEN=lc) :: cl_val
+ !----------------------------------------------------------------
+
+ cl_val = fct_str(sd_val)
+ fct__i2_cat=TRIM(cd_char)//TRIM(cl_val)
+
+ END FUNCTION fct__i2_cat
+ !-------------------------------------------------------------------
+ !> @brief This function concatenate character and integer(4) (as character).
!
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
+ !> @param[in] cd_char string character
+ !> @param[in] id_val integer(4) variable value
!> @return string character
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct__i4_cat(cd_char, id_val)
@@ -90,14 +221,14 @@
END FUNCTION fct__i4_cat
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This routine concatenate character and integer(8) (as character).
+ !-------------------------------------------------------------------
+ !> @brief This function concatenate character and integer(8) (as character).
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
+ !> @param[in] cd_char string character
+ !> @param[in] kd_val integer(8) variable value
!> @return string character
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct__i8_cat(cd_char, kd_val)
@@ -114,14 +245,14 @@
END FUNCTION fct__i8_cat
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This routine concatenate character and real(4) (as character).
+ !-------------------------------------------------------------------
+ !> @brief This function concatenate character and real(4) (as character).
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
+ !> @param[in] cd_char string character
+ !> @param[in] rd_val real(4) variable value
!> @return string character
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct__r4_cat(cd_char, rd_val)
@@ -138,14 +269,14 @@
END FUNCTION fct__r4_cat
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This routine concatenate character and real(8) (as character).
- !
+ !-------------------------------------------------------------------
+ !> @brief This function concatenate character and real(8) (as character).
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] cd_char string character
+ !> @param[in] dd_val real(8) variable value
!> @return string character
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct__r8_cat(cd_char, dd_val)
@@ -162,14 +293,14 @@
END FUNCTION fct__r8_cat
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This routine concatenate character and logical (as character).
- !
+ !-------------------------------------------------------------------
+ !> @brief This function concatenate character and logical (as character).
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] cd_char string character
+ !> @param[in] ld_val logical variable value
!> @return string character
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct__l_cat(cd_char, ld_val)
@@ -186,14 +317,12 @@
END FUNCTION fct__l_cat
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This routine returns the next available I/O unit number.
- !
+ !-------------------------------------------------------------------
+ !> @brief This function returns the next available I/O unit number.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
+ !> - November, 2013- Initial Version
+ !>
!> @return file id
!-------------------------------------------------------------------
- ! @code
INTEGER(i4) FUNCTION fct_getunit()
@@ -211,12 +340,12 @@
END FUNCTION fct_getunit
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This routine handle Fortran status.
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !-------------------------------------------------------------------
- ! @code
+ !-------------------------------------------------------------------
+ !> @brief This subroutine handle Fortran status.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] id_status
+ !-------------------------------------------------------------------
SUBROUTINE fct_err(id_status)
@@ -232,15 +361,35 @@
END SUBROUTINE fct_err
- ! @endcode
+ !-------------------------------------------------------------------
+ !> @brief This subroutine create a pause statement
+ !
+ !> @author J.Paul
+ !> - November, 2014- Initial Version
+ !>
+ !> @param[in] cd_msg optional message to be added
+ !-------------------------------------------------------------------
+ SUBROUTINE fct_pause(cd_msg)
+
+ ! Argument
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_msg
+ !----------------------------------------------------------------
+
+ IF( PRESENT(cd_msg) )THEN
+ WRITE( *, * ) 'Press Enter to continue '//TRIM(cd_msg)
+ ELSE
+ WRITE( *, * ) 'Press Enter to continue'
+ ENDIF
+ READ( *, * )
+
+ END SUBROUTINE fct_pause
!-------------------------------------------------------------------
!> @brief This function convert logical to string character.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] ld_var : logical variable
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] ld_var logical variable
!> @return character of this integer variable
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct__l_str(ld_var)
IMPLICIT NONE
@@ -256,15 +405,13 @@
END FUNCTION fct__l_str
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function convert integer(1) to string character.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] bd_var : integer(1) variable
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] bd_var integer(1) variable
!> @return character of this integer variable
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct__i1_str(bd_var)
IMPLICIT NONE
@@ -280,15 +427,13 @@
END FUNCTION fct__i1_str
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function convert integer(2) to string character.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] sd_var : integer(2) variable
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] sd_var integer(2) variable
!> @return character of this integer variable
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct__i2_str(sd_var)
IMPLICIT NONE
@@ -304,15 +449,13 @@
END FUNCTION fct__i2_str
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function convert integer(4) to string character.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] id_var : integer(4) variable
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] id_var integer(4) variable
!> @return character of this integer variable
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct__i4_str(id_var)
IMPLICIT NONE
@@ -328,15 +471,13 @@
END FUNCTION fct__i4_str
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function convert integer(8) to string character.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] kd_var : integer(8) variable
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] kd_var integer(8) variable
!> @return character of this integer variable
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct__i8_str(kd_var)
IMPLICIT NONE
@@ -352,15 +493,13 @@
END FUNCTION fct__i8_str
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function convert real(4) to string character.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] rd_var : real(4) variable
- !> @return character of this integer variable
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] rd_var real(4) variable
+ !> @return character of this real variable
+ !-------------------------------------------------------------------
PURE CHARACTER(LEN=lc) FUNCTION fct__r4_str(rd_var)
IMPLICIT NONE
@@ -376,15 +515,13 @@
END FUNCTION fct__r4_str
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function convert real(8) to string character.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_var : real(8) variable
- !> @return character of this integer variable
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] dd_var real(8) variable
+ !> @return character of this real variable
+ !-------------------------------------------------------------------
PURE CHARACTER(LEN=lc) FUNCTION fct__r8_str(dd_var)
IMPLICIT NONE
@@ -400,22 +537,21 @@
END FUNCTION fct__r8_str
- ! @endcode
- !-------------------------------------------------------------------
- !> @brief This function concatenate all the element of a character table
- !> except unknown one, in a character string.
- !>
- !> optionnally a separator could be added between each element
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_tab : table of character
+ !-------------------------------------------------------------------
+ !> @brief This function concatenate all the element of a character array
+ !> in a character string.
+ !> @details
+ !> optionnally a separator could be added between each element.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_arr array of character
+ !> @param[in] cd_sep separator character
!> @return character
!-------------------------------------------------------------------
- ! @code
- PURE CHARACTER(LEN=lc) FUNCTION fct_concat(cd_tab,cd_sep)
- IMPLICIT NONE
- ! Argument
- CHARACTER(*), DIMENSION(:), INTENT(IN) :: cd_tab
+ PURE CHARACTER(LEN=lc) FUNCTION fct_concat(cd_arr,cd_sep)
+ IMPLICIT NONE
+ ! Argument
+ CHARACTER(*), DIMENSION(:), INTENT(IN) :: cd_arr
CHARACTER(*), INTENT(IN), OPTIONAL :: cd_sep
@@ -432,13 +568,10 @@
IF(PRESENT(cd_sep)) cl_sep=cd_sep
- il_size=SIZE(cd_tab)
+ il_size=SIZE(cd_arr)
fct_concat=''
cl_tmp=''
DO ji=1,il_size
- !IF( TRIM(ADJUSTL(cd_tab(ji))) /= 'unknown' )THEN
- WRITE(cl_tmp,*) TRIM(fct_concat)//TRIM(ADJUSTL(cd_tab(ji)))//TRIM(cl_sep)
- !ENDIF
-
+ WRITE(cl_tmp,*) TRIM(fct_concat)//TRIM(ADJUSTL(cd_arr(ji)))//TRIM(cl_sep)
fct_concat=TRIM(ADJUSTL(cl_tmp))
@@ -446,5 +579,4 @@
END FUNCTION fct_concat
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function convert string character upper case to lower case.
@@ -458,10 +590,9 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_var : character
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_var character
!> @return lower case character
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct_lower(cd_var)
IMPLICIT NONE
@@ -505,5 +636,4 @@
END FUNCTION fct_lower
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function convert string character lower case to upper case.
@@ -517,10 +647,9 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_var : character
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_var character
!> @return upper case character
!-------------------------------------------------------------------
- ! @code
PURE CHARACTER(LEN=lc) FUNCTION fct_upper(cd_var)
IMPLICIT NONE
@@ -564,17 +693,13 @@
END FUNCTION fct_upper
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function check if character is numeric.
!
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_var : character
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_var character
!> @return character is numeric
!-------------------------------------------------------------------
- ! @code
PURE LOGICAL FUNCTION fct_is_num(cd_var)
IMPLICIT NONE
@@ -597,21 +722,17 @@
END FUNCTION fct_is_num
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function split string of character
!> using separator character, by default '|',
- !> and return the element on index ind
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_string : string of character
- !> @param[in] id_ind : indice
- !> @param[in] cd_sep separator character
+ !> and return the element on index ind.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_string string of character
+ !> @param[in] id_ind indice
+ !> @param[in] cd_sep separator character
!> @return return the element on index id_ind
!-------------------------------------------------------------------
- ! @code
PURE FUNCTION fct_split(cd_string, id_ind, cd_sep)
IMPLICIT NONE
@@ -629,4 +750,5 @@
INTEGER(i4) :: il_sep
+ INTEGER(i4) :: il_lsep
! loop indices
@@ -639,13 +761,87 @@
! get separator
cl_sep='|'
- IF( PRESENT(cd_sep) ) cl_sep=TRIM(ADJUSTL(cd_sep))
+ IF( PRESENT(cd_sep) )THEN
+ IF( cd_sep==' ')THEN
+ cl_sep=' '
+ ELSE
+ cl_sep=TRIM(ADJUSTL(cd_sep))
+ ENDIF
+ ENDIF
+ IF( cl_sep /= ' ' )THEN
+ ! get separator index
+ il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep) )
+ il_lsep=LEN(TRIM(cl_sep))
+
+ IF( il_sep /= 0 )THEN
+ fct_split=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
+ ELSE
+ fct_split=TRIM(ADJUSTL(cl_string))
+ ENDIF
+
+ ji=1
+ DO WHILE( il_sep /= 0 .AND. ji /= id_ind )
+
+ ji=ji+1
+
+ cl_string=TRIM(cl_string(il_sep+il_lsep:))
+ il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep) )
+
+ IF( il_sep /= 0 )THEN
+ fct_split=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
+ ELSE
+ fct_split=TRIM(ADJUSTL(cl_string))
+ ENDIF
+
+ ENDDO
+
+ IF( ji /= id_ind ) fct_split=''
+ ELSE
+ fct_split=fct__split_space(TRIM(cl_string), id_ind)
+ ENDIF
+
+ END FUNCTION fct_split
+ !-------------------------------------------------------------------
+ !> @brief This function split string of character
+ !> using space as separator,
+ !> and return the element on index ind.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_string string of character
+ !> @param[in] id_ind indice
+ !> @return return the element on index id_ind
+ !-------------------------------------------------------------------
+ PURE FUNCTION fct__split_space(cd_string, id_ind)
+ IMPLICIT NONE
+ ! Argument
+ CHARACTER(LEN=*), INTENT(IN) :: cd_string
+ INTEGER(i4) , INTENT(IN) :: id_ind
+
+ ! function
+ CHARACTER(LEN=lc) :: fct__split_space
+
+ ! local variable
+ CHARACTER(LEN=lc) :: cl_string
+
+ INTEGER(i4) :: il_sep
+ INTEGER(i4) :: il_lsep
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ ! initialize
+ fct__split_space=''
+ cl_string=ADJUSTL(cd_string)
+
! get separator index
- il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep) )
-
+ il_sep=INDEX( TRIM(cl_string), ' ' )
+ il_lsep=LEN(' ')
+
IF( il_sep /= 0 )THEN
- fct_split=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
+ fct__split_space=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
ELSE
- fct_split=TRIM(ADJUSTL(cl_string))
+ fct__split_space=TRIM(ADJUSTL(cl_string))
ENDIF
@@ -655,33 +851,32 @@
ji=ji+1
- cl_string=TRIM(cl_string(il_sep+1:))
- il_sep=INDEX( TRIM(cl_string), TRIM(cl_sep) )
+ cl_string=TRIM(cl_string(il_sep+il_lsep:))
+ il_sep=INDEX( TRIM(cl_string), ' ' )
IF( il_sep /= 0 )THEN
- fct_split=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
+ fct__split_space=TRIM(ADJUSTL(cl_string(1:il_sep-1)))
ELSE
- fct_split=TRIM(ADJUSTL(cl_string))
+ fct__split_space=TRIM(ADJUSTL(cl_string))
ENDIF
ENDDO
- IF( ji /= id_ind ) fct_split=''
-
- END FUNCTION fct_split
- ! @endcode
+ IF( ji /= id_ind ) fct__split_space=''
+
+ END FUNCTION fct__split_space
!-------------------------------------------------------------------
!> @brief This function return basename of a filename.
!
!> @details
- !> actually it splits filename using sperarator '/'
- !> and return last string character
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_string : filename
+ !> Actually it splits filename using sperarator '/'
+ !> and return last string character.
+ !> Optionally you could specify another separator.
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_string filename
+ !> @param[in] cd_sep separator character
!> @return basename (filename without path)
!-------------------------------------------------------------------
- ! @code
PURE FUNCTION fct_basename(cd_string, cd_sep)
IMPLICIT NONE
@@ -711,19 +906,18 @@
END FUNCTION fct_basename
- ! @endcode
!-------------------------------------------------------------------
!> @brief This function return dirname of a filename.
!
!> @details
- !> actually it splits filename using sperarator '/'
- !> and return all exept last string character
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_string : filename
+ !> Actually it splits filename using sperarator '/'
+ !> and return all except last string character.
+ !> Optionally you could specify another separator.
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_string filename
+ !> @param[in] cd_sep separator character
!> @return dirname (path of the filename)
!-------------------------------------------------------------------
- ! @code
PURE FUNCTION fct_dirname(cd_string, cd_sep)
IMPLICIT NONE
@@ -757,5 +951,4 @@
END FUNCTION fct_dirname
- ! @endcode
END MODULE fct
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/global.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/global.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/global.f90 (revision 5214)
@@ -6,11 +6,10 @@
!
! DESCRIPTION:
-!> @brief This module defines global variables, and parameters that can't
-!> be associated with a module
+!> @brief This module defines global variables and parameters.
!
!> @author
!> J.paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
+!> @date November, 2013 - Initial Version
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
@@ -22,64 +21,72 @@
IMPLICIT NONE
- PUBLIC :: dg_fill !< default fill value
- PUBLIC :: ig_nsep !< number of separator listed
- PUBLIC :: ig_ncom !< number of comment character listed
- PUBLIC :: cg_sep !< list of separator
- PUBLIC :: cg_com !< list of comment character
+ PUBLIC :: dp_fill !< default fill value
+ PUBLIC :: ip_nsep !< number of separator listed
+ PUBLIC :: ip_ncom !< number of comment character listed
+ PUBLIC :: cp_sep !< list of separator
+ PUBLIC :: cp_com !< list of comment character
- PUBLIC :: ig_npoint
- PUBLIC :: jp_T
- PUBLIC :: jp_U
- PUBLIC :: jp_V
- PUBLIC :: jp_F
+ PUBLIC :: ip_npoint !< number of point on ARAKAWA C-grid
+ PUBLIC :: jp_T !< indice for T-point on ARAKAWA C-grid
+ PUBLIC :: jp_U !< indice for U-point on ARAKAWA C-grid
+ PUBLIC :: jp_V !< indice for V-point on ARAKAWA C-grid
+ PUBLIC :: jp_F !< indice for F-point on ARAKAWA C-grid
+ PUBLIC :: cp_grid_point !< list of grid_point character
- PUBLIC :: ig_ndim
- PUBLIC :: jp_I
- PUBLIC :: jp_J
- PUBLIC :: jp_K
- PUBLIC :: jp_L
+ PUBLIC :: ip_maxdim !< maximum number of dimension to be used
+ PUBLIC :: jp_I !< indice for I-direction
+ PUBLIC :: jp_J !< indice for J-direction
+ PUBLIC :: jp_K !< indice for K-direction
+ PUBLIC :: jp_L !< indice for L-direction
+ PUBLIC :: cp_dimorder !< dimension order
- PUBLIC :: ig_maxvar !< maximum number of variable
- PUBLIC :: ig_maxmtx !< matrix variable maximum dimension
- PUBLIC :: ig_maxseg !< maximum number of segment
- PUBLIC :: ig_ghost !< number of ghost cell
+ PUBLIC :: ip_maxvar !< maximum number of variable
+ PUBLIC :: ip_maxmtx !< matrix variable maximum dimension
+ PUBLIC :: ip_maxseg !< maximum number of segment
+ PUBLIC :: ip_ghost !< number of ghost cell
- PUBLIC :: ig_ninterp !< number of available interpolation method
- PUBLIC :: cg_interp_list !< list of interpolation name
+ PUBLIC :: ip_ninterp !< number of available interpolation method
+ PUBLIC :: cp_interp_list !< list of interpolation name
- PUBLIC :: ig_nextrap !< number of available extrapolation method
- PUBLIC :: cg_extrap_list !< list of extrapolation name
+ PUBLIC :: ip_nextrap !< number of available extrapolation method
+ PUBLIC :: cp_extrap_list !< list of extrapolation name
- PUBLIC :: ig_nfilter !< number of available filter
- PUBLIC :: cg_filter_list !< list of filter name
+ PUBLIC :: ip_nfilter !< number of available filter
+ PUBLIC :: cp_filter_list !< list of filter name
- PRIVATE
+ PUBLIC :: ip_ncard !< number of cardinal point
+ PUBLIC :: cp_card !< array of cardinal point
+ PUBLIC :: jp_north !< indice for north boundary
+ PUBLIC :: jp_south !< indice for south boundary
+ PUBLIC :: jp_east !< indice for east boundary
+ PUBLIC :: jp_west !< indice for west boundary
+
! NOTE_avoid_public_variables_if_possible
- INTEGER(i4) , PARAMETER :: ig_maxvar =200 !< maximum number of variable
- INTEGER(i4) , PARAMETER :: ig_maxmtx =100 !< matrix variable maximum dimension (cf create_bathy)
- INTEGER(i4) , PARAMETER :: ig_maxseg =50 !< maximum number of segment for each boundary
+ INTEGER(i4) , PARAMETER :: ip_maxvar =200 !< maximum number of variable
+ INTEGER(i4) , PARAMETER :: ip_maxmtx =100 !< matrix variable maximum dimension (cf create_bathy)
+ INTEGER(i4) , PARAMETER :: ip_maxseg =50 !< maximum number of segment for each boundary
- INTEGER(i4) , PARAMETER :: ig_nsep=2 !< number of separator listed
- CHARACTER(1) , DIMENSION(ig_nsep) , PARAMETER :: cg_sep = (/'.','_'/) !< list of separator
+ INTEGER(i4) , PARAMETER :: ip_nsep=2 !< number of separator listed
+ CHARACTER(1) , DIMENSION(ip_nsep) , PARAMETER :: cp_sep = (/'.','_'/) !< list of separator
- INTEGER(i4) , PARAMETER :: ig_ncom=2 !< number of comment character listed
- CHARACTER(1) , DIMENSION(ig_ncom) , PARAMETER :: cg_com = (/'#','!'/) !< list of comment character
+ INTEGER(i4) , PARAMETER :: ip_ncom=2 !< number of comment character listed
+ CHARACTER(1) , DIMENSION(ip_ncom) , PARAMETER :: cp_com = (/'#','!'/) !< list of comment character
- INTEGER(i4) , PARAMETER :: ig_ghost=1 !< number of ghost cell
+ INTEGER(i4) , PARAMETER :: ip_ghost=1 !< number of ghost cell
- INTEGER(i4) , PARAMETER :: ig_ninterp=3
- CHARACTER(LEN=lc), DIMENSION(ig_ninterp), PARAMETER :: cg_interp_list = &
+ INTEGER(i4) , PARAMETER :: ip_ninterp=3
+ CHARACTER(LEN=lc), DIMENSION(ip_ninterp), PARAMETER :: cp_interp_list = &
& (/ 'nearest', &
& 'cubic ', &
& 'linear ' /)
- INTEGER(i4) , PARAMETER :: ig_nextrap=2
- CHARACTER(LEN=lc), DIMENSION(ig_nextrap), PARAMETER :: cg_extrap_list = &
+ INTEGER(i4) , PARAMETER :: ip_nextrap=2
+ CHARACTER(LEN=lc), DIMENSION(ip_nextrap), PARAMETER :: cp_extrap_list = &
& (/ 'dist_weight', &
& 'min_error ' /)
- INTEGER(i4) , PARAMETER :: ig_nfilter=5
- CHARACTER(LEN=lc), DIMENSION(ig_nfilter), PARAMETER :: cg_filter_list = &
+ INTEGER(i4) , PARAMETER :: ip_nfilter=5
+ CHARACTER(LEN=lc), DIMENSION(ip_nfilter), PARAMETER :: cp_filter_list = &
& (/ 'butterworth', &
& 'blackman ', &
@@ -88,18 +95,35 @@
& 'gauss '/)
- REAL(dp) , PARAMETER :: dg_fill=NF90_FILL_DOUBLE !< default fill value
- INTEGER(i4) , PARAMETER :: ig_fill=NF90_FILL_INT !< default fill value
+ REAL(dp) , PARAMETER :: dp_fill=NF90_FILL_DOUBLE !< default fill value
- INTEGER(i4) , PARAMETER :: ig_npoint=4
+ INTEGER(i4) , PARAMETER :: ip_npoint=4
INTEGER(i4) , PARAMETER :: jp_T=1
INTEGER(i4) , PARAMETER :: jp_U=2
INTEGER(i4) , PARAMETER :: jp_V=3
INTEGER(i4) , PARAMETER :: jp_F=4
+ CHARACTER(LEN=1), DIMENSION(ip_npoint) , PARAMETER :: cp_grid_point = &
+ & (/ 'T', 'U', 'V', 'F' /)
- INTEGER(i4) , PARAMETER :: ig_ndim=2
+
+ INTEGER(i4) , PARAMETER :: ip_maxdim=4
INTEGER(i4) , PARAMETER :: jp_I=1
INTEGER(i4) , PARAMETER :: jp_J=2
INTEGER(i4) , PARAMETER :: jp_K=3
INTEGER(i4) , PARAMETER :: jp_L=4
+ CHARACTER(LEN=ip_maxdim) , PARAMETER :: cp_dimorder = 'xyzt' !< dimension order to output
+
+ INTEGER(i4), PARAMETER :: ip_ncard=4
+ CHARACTER(LEN=lc), DIMENSION(ip_ncard), PARAMETER :: cp_card = &
+ & (/ 'north', &
+ & 'south', &
+ & 'east ', &
+ & 'west ' /)
+
+ INTEGER(i4), PARAMETER :: jp_north=1
+ INTEGER(i4), PARAMETER :: jp_south=2
+ INTEGER(i4), PARAMETER :: jp_east =3
+ INTEGER(i4), PARAMETER :: jp_west =4
+
+
END MODULE global
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/grid.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/grid.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/grid.f90 (revision 5214)
@@ -6,15 +6,213 @@
!
! DESCRIPTION:
-!> @brief grid manager
+!> @brief This module is grid manager.
!>
!> @details
-!>
+!> to get NEMO pivot point index:
+!> @code
+!> il_pivot=grid_get_pivot(td_file)
+!> @endcode
+!> - il_pivot is NEMO pivot point index F(0), T(1)
+!> - td_file is mpp structure
+!>
+!> to get NEMO periodicity index:
+!> @code
+!> il_perio=grid_get_perio(td_file)
+!> @endcode
+!> - il_perio is NEMO periodicity index (0,1,2,3,4,5,6)
+!> - td_file is mpp structure
+!>
+!> to check domain validity:
+!> @code
+!> CALL grid_check_dom(td_coord, id_imin, id_imax, id_jmin, id_jmax)
+!> @endcode
+!> - td_coord is coordinates mpp structure
+!> - id_imin is i-direction lower left point indice
+!> - id_imax is i-direction upper right point indice
+!> - id_jmin is j-direction lower left point indice
+!> - id_jmax is j-direction upper right point indice
+!>
+!> to get closest coarse grid indices of fine grid domain:
+!> @code
+!> il_index(:,:)=grid_get_coarse_index(td_coord0, td_coord1,
+!> [id_rho,] [cd_point])
+!> @endcode
+!> or
+!> @code
+!> il_index(:,:)=grid_get_coarse_index(td_lon0, td_lat0, td_coord1,
+!> [id_rho,] [cd_point])
+!> @endcode
+!> or
+!> @code
+!> il_index(:,:)=grid_get_coarse_index(td_coord0, td_lon1, td_lat1,
+!> [id_rho,] [cd_point])
+!> @endcode
+!> or
+!> @code
+!> il_index(:,:)=grid_get_coarse_index(td_lon0, td_lat0, td_lon1, td_lat1,
+!> [id_rho,] [cd_point])
+!> @endcode
+!> - il_index(:,:) is coarse grid indices (/ (/ imin0, imax0 /),
+!> (/ jmin0, jmax0 /) /)
+!> - td_coord0 is coarse grid coordinate mpp structure
+!> - td_coord1 is fine grid coordinate mpp structure
+!> - td_lon0 is coarse grid longitude variable structure
+!> - td_lat0 is coarse grid latitude variable structure
+!> - td_lon1 is fine grid longitude variable structure
+!> - td_lat1 is fine grid latitude variable structure
+!> - id_rho is array of refinment factor (default 1)
+!> - cd_point is Arakawa grid point (default 'T')
+!>
+!> to know if grid is global:
+!> @code
+!> ll_global=grid_is_global(td_lon, td_lat)
+!> @endcode
+!> - td_lon is longitude variable structure
+!> - td_lat is latitude variable structure
+!>
+!> to know if grid contains north fold:
+!> @code
+!> ll_north=grid_is_north_fold(td_lat)
+!> @endcode
+!> - td_lat is latitude variable structure
+!>
+!> to get coarse grid indices of the closest point from one fine grid
+!> point:
+!> @code
+!> il_index(:)=grid_get_closest(dd_lon0(:,:), dd_lat0(:,:), dd_lon1, dd_lat1)
+!> @endcode
+!> - il_index(:) is coarse grid indices (/ i0, j0 /)
+!> - dd_lon0 is coarse grid array of longitude value (real(8))
+!> - dd_lat0 is coarse grid array of latitude value (real(8))
+!> - dd_lon1 is fine grid longitude value (real(8))
+!> - dd_lat1 is fine grid latitude value (real(8))
+!>
+!> to compute distance between a point A and grid points:
+!> @code
+!> il_dist(:,:)=grid_distance(dd_lon, dd_lat, dd_lonA, dd_latA)
+!> @endcode
+!> - il_dist(:,:) is array of distance between point A and grid points
+!> - dd_lon is array of longitude value (real(8))
+!> - dd_lat is array of longitude value (real(8))
+!> - dd_lonA is longitude of point A (real(8))
+!> - dd_latA is latitude of point A (real(8))
+!>
+!> to get offset between fine grid and coarse grid:
+!> @code
+!> il_offset(:,:)=grid_get_fine_offset(td_coord0,
+!> id_imin0, id_jmin0, id_imax0, id_jmax0,
+!> td_coord1
+!> [,id_rho] [,cd_point])
+!> @endcode
+!> or
+!> @code
+!> il_offset(:,:)=grid_get_fine_offset(dd_lon0, dd_lat0,
+!> id_imin0, id_jmin0,id_imax0, id_jmax0,
+!> td_coord1
+!> [,id_rho] [,cd_point])
+!> @endcode
+!> or
+!> @code
+!> il_offset(:,:)=grid_get_fine_offset(td_coord0,
+!> id_imin0, id_jmin0, id_imax0, id_jmax0,
+!> dd_lon1, dd_lat1
+!> [,id_rho] [,cd_point])
+!> @endcode
+!> or
+!> @code
+!> il_offset(:,:)=grid_get_fine_offset(dd_lon0, dd_lat0,
+!> id_imin0, id_jmin0, id_imax0, id_jmax0,
+!> dd_lon1, dd_lat1
+!> [,id_rho] [,cd_point])
+!> @endcode
+!> - il_offset(:,:) is offset array
+!> (/ (/ i_offset_left, i_offset_right /), (/ j_offset_lower, j_offset_upper /) /)
+!> - td_coord0 is coarse grid coordinate mpp structure
+!> - dd_lon0 is coarse grid longitude array (real(8))
+!> - dd_lat0 is coarse grid latitude array (real(8))
+!> - id_imin0 is coarse grid lower left corner i-indice of fine grid
+!> domain
+!> - id_jmin0 is coarse grid lower left corner j-indice of fine grid
+!> domain
+!> - id_imax0 is coarse grid upper right corner i-indice of fine grid
+!> domain
+!> - id_jmax0 is coarse grid upper right corner j-indice of fine grid
+!> domain
+!> - td_coord1 is fine grid coordinate mpp structure
+!> - dd_lon1 is fine grid longitude array (real(8))
+!> - dd_lat1 is fine grid latitude array (real(8))
+!> - id_rho is array of refinment factor (default 1)
+!> - cd_point is Arakawa grid point (default 'T')
+!>
+!> to check fine and coarse grid coincidence:
+!> @code
+!> CALL grid_check_coincidence(td_coord0, td_coord1,
+!> id_imin0, id_imax0, id_jmin0, id_jmax0
+!> [,id_rho])
+!> @endcode
+!> - td_coord0 is coarse grid coordinate mpp structure
+!> - td_coord1 is fine grid coordinate mpp structure
+!> - id_imin0 is coarse grid lower left corner i-indice of fine grid
+!> domain
+!> - id_imax0 is coarse grid upper right corner i-indice of fine grid
+!> domain
+!> - id_jmin0 is coarse grid lower left corner j-indice of fine grid
+!> domain
+!> - id_jmax0 is coarse grid upper right corner j-indice of fine grid
+!> domain
+!> - id_rho is array of refinement factor (default 1)
+!>
+!> to add ghost cell at boundaries:
+!> @code
+!> CALL grid_add_ghost(td_var, id_ghost)
+!> @endcode
+!> - td_var is array of variable structure
+!> - id_ghost is 2D array of ghost cell factor
+!>
+!> to delete ghost cell at boundaries:
+!> @code
+!> CALL grid_del_ghost(td_var, id_ghost)
+!> @endcode
+!> - td_var is array of variable structure
+!> - id_ghost is 2D array of ghost cell factor
+!>
+!> to get ghost cell factor (use or not):
+!> @code
+!> il_factor(:)= grid_get_ghost( td_var )
+!> @endcode
+!> or
+!> @code
+!> il_factor(:)= grid_get_ghost( td_mpp )
+!> @endcode
+!> - il_factor(:) is array of ghost cell factor (0 or 1)
+!> - td_var is variable structure
+!> - td_mpp is mpp sturcture
+!>
+!> to compute closed sea domain:
+!> @code
+!> il_mask(:,:)=grid_split_domain(td_var, [id_level])
+!> @endcode
+!> - il_mask(:,:) is domain mask
+!> - td_var is variable strucutre
+!> - id_level is level to be used [optional]
+!>
+!> to fill small closed sea with _FillValue:
+!> @code
+!> CALL grid_fill_small_dom(td_var, id_mask, [id_minsize])
+!> @endcode
+!> - td_var is variable structure
+!> - id_mask is domain mask (from grid_split_domain)
+!> - id_minsize is minimum size of sea to be kept [optional]
+!>
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
+!> @date November, 2013 - Initial Version
+!> @date September, 2014
+!> - add header
+!> @date October, 2014
+!> - use mpp file structure instead of file
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!> @todo
!----------------------------------------------------------------------
MODULE grid
@@ -24,14 +222,15 @@
USE global ! global parameter
USE phycst ! physical constant
- USE logger ! log file manager
+ USE logger ! log file manager
USE file ! file manager
+ USE att ! attribute manager
USE var ! variable manager
USE dim ! dimension manager
- USE dom ! domain manager
USE iom ! I/O manager
USE mpp ! MPP manager
+ USE dom ! domain manager
USE iom_mpp ! MPP I/O manager
+ USE iom_dom ! DOM I/O manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
@@ -39,86 +238,1256 @@
! function and subroutine
- PUBLIC :: grid_check_dom !< check domain validity
- PUBLIC :: grid_get_coarse_index !< get closest coarse grid indices of fine grid domain.
- PUBLIC :: grid_is_global !< check if grid is global or not
- PUBLIC :: grid_get_closest !< return closest coarse grid point from another point
- PUBLIC :: grid_distance !< compute grid distance to a point
- PUBLIC :: grid_get_fine_offset !< get fine grid offset
- PUBLIC :: grid_check_coincidence !< check fine and coarse grid coincidence
- PUBLIC :: grid_get_perio !< return NEMO periodicity index
- PUBLIC :: grid_get_pivot !< return NEMO pivot point index
- PUBLIC :: grid_add_ghost !< add ghost cell at boundaries.
- PUBLIC :: grid_del_ghost !< delete ghost cell at boundaries.
- PUBLIC :: grid_get_ghost !< return ghost cell factor
- PUBLIC :: grid_split_domain !<
- PUBLIC :: grid_fill_small_dom !<
-
- PRIVATE :: grid_get_coarse_index_ff
- PRIVATE :: grid_get_coarse_index_cf
- PRIVATE :: grid_get_coarse_index_fc
- PRIVATE :: grid_get_coarse_index_cc
- PRIVATE :: grid__get_ghost_f
- PRIVATE :: grid__get_ghost_ll
- PRIVATE :: grid__check_corner
+ PUBLIC :: grid_get_info !< get information about mpp global domain (pivot, perio, ew)
+ PUBLIC :: grid_get_pivot !< get NEMO pivot point index
+ PUBLIC :: grid_get_perio !< get NEMO periodicity index
+ PUBLIC :: grid_get_ew_overlap !< get East West overlap
+ PUBLIC :: grid_check_dom !< check domain validity
+ PUBLIC :: grid_get_coarse_index !< get closest coarse grid indices of fine grid domain.
+ PUBLIC :: grid_is_global !< check if grid is global or not
+ PUBLIC :: grid_is_north_fold
+ PUBLIC :: grid_get_closest !< return closest coarse grid point from another point
+ PUBLIC :: grid_distance !< compute grid distance to a point
+ PUBLIC :: grid_get_fine_offset !< get fine grid offset
+ PUBLIC :: grid_check_coincidence !< check fine and coarse grid coincidence
+ PUBLIC :: grid_add_ghost !< add ghost cell at boundaries.
+ PUBLIC :: grid_del_ghost !< delete ghost cell at boundaries.
+ PUBLIC :: grid_get_ghost !< return ghost cell factor
+ PUBLIC :: grid_split_domain !< compute closed sea domain
+ PUBLIC :: grid_fill_small_dom !< fill small closed sea with fill value
+
+ ! get closest coarse grid indices of fine grid domain
+ PRIVATE :: grid__get_coarse_index_ff ! - using coarse and fine grid coordinates files
+ PRIVATE :: grid__get_coarse_index_cf ! - using coarse grid array of lon,lat and fine grid coordinates files
+ PRIVATE :: grid__get_coarse_index_fc ! - using coarse grid coordinates files, and fine grid array of lon,lat
+ PRIVATE :: grid__get_coarse_index_cc ! - using coarse and fine grid array of lon,lat
+
+ ! get offset between fine and coarse grid
+ PRIVATE :: grid__get_fine_offset_ff ! - using coarse and fine grid coordinates files
+ PRIVATE :: grid__get_fine_offset_cf ! - using coarse grid array of lon,lat and fine grid coordinates files
+ PRIVATE :: grid__get_fine_offset_fc ! - using coarse grid coordinates files, and fine grid array of lon,lat
+ PRIVATE :: grid__get_fine_offset_cc ! - using coarse and fine grid array of lon,lat
+
+ ! get information about global domain (pivot, perio, ew)
+ PRIVATE :: grid__get_info_mpp ! - using mpp files structure
+ PRIVATE :: grid__get_info_file ! - using files structure
+
+ ! get NEMO pivot point index
+ PRIVATE :: grid__get_pivot_mpp ! - using mpp files structure
+ PRIVATE :: grid__get_pivot_file ! - using files structure
+ PRIVATE :: grid__get_pivot_var ! - using variable structure
+ PRIVATE :: grid__get_pivot_varT ! compute NEMO pivot point index for variable on grid T
+ PRIVATE :: grid__get_pivot_varU ! compute NEMO pivot point index for variable on grid U
+ PRIVATE :: grid__get_pivot_varV ! compute NEMO pivot point index for variable on grid V
+ PRIVATE :: grid__get_pivot_varF ! compute NEMO pivot point index for variable on grid F
+
+ ! get NEMO periodicity index
+ PRIVATE :: grid__get_perio_mpp ! - using mpp files structure
+ PRIVATE :: grid__get_perio_file ! - using files structure
+ PRIVATE :: grid__get_perio_var ! - using variable structure
+
+ ! get East West overlap
+ PRIVATE :: grid__get_ew_overlap_mpp ! - using mpp files structure
+ PRIVATE :: grid__get_ew_overlap_file ! - using files structure
+ PRIVATE :: grid__get_ew_overlap_var ! - using longitude variable structure
+
+ ! return ghost cell factor
+ PRIVATE :: grid__get_ghost_mpp ! - using mpp files structure
+ PRIVATE :: grid__get_ghost_var ! - using array of lon,lat
+ PRIVATE :: grid__check_corner ! check that fine grid is inside coarse grid
+ PRIVATE :: grid__check_lat ! check that fine grid latitude are inside coarse grid latitude
+ INTERFACE grid_get_info
+ MODULE PROCEDURE grid__get_info_mpp
+ MODULE PROCEDURE grid__get_info_file
+ END INTERFACE grid_get_info
+
+ INTERFACE grid_get_pivot
+ MODULE PROCEDURE grid__get_pivot_mpp
+ MODULE PROCEDURE grid__get_pivot_file
+ MODULE PROCEDURE grid__get_pivot_var
+ END INTERFACE grid_get_pivot
+
+ INTERFACE grid_get_perio
+ MODULE PROCEDURE grid__get_perio_mpp
+ MODULE PROCEDURE grid__get_perio_file
+ MODULE PROCEDURE grid__get_perio_var
+ END INTERFACE grid_get_perio
+
+ INTERFACE grid_get_ew_overlap
+ MODULE PROCEDURE grid__get_ew_overlap_mpp
+ MODULE PROCEDURE grid__get_ew_overlap_file
+ MODULE PROCEDURE grid__get_ew_overlap_var
+ END INTERFACE grid_get_ew_overlap
+
INTERFACE grid_get_ghost
- MODULE PROCEDURE grid__get_ghost_ll
- MODULE PROCEDURE grid__get_ghost_f
+ MODULE PROCEDURE grid__get_ghost_var
+ MODULE PROCEDURE grid__get_ghost_mpp
END INTERFACE grid_get_ghost
INTERFACE grid_get_coarse_index
- MODULE PROCEDURE grid_get_coarse_index_ff
- MODULE PROCEDURE grid_get_coarse_index_cf
- MODULE PROCEDURE grid_get_coarse_index_fc
- MODULE PROCEDURE grid_get_coarse_index_cc
+ MODULE PROCEDURE grid__get_coarse_index_ff
+ MODULE PROCEDURE grid__get_coarse_index_cf
+ MODULE PROCEDURE grid__get_coarse_index_fc
+ MODULE PROCEDURE grid__get_coarse_index_cc
END INTERFACE grid_get_coarse_index
+ INTERFACE grid_get_fine_offset
+ MODULE PROCEDURE grid__get_fine_offset_ff
+ MODULE PROCEDURE grid__get_fine_offset_fc
+ MODULE PROCEDURE grid__get_fine_offset_cf
+ MODULE PROCEDURE grid__get_fine_offset_cc
+ END INTERFACE grid_get_fine_offset
+
CONTAINS
!-------------------------------------------------------------------
+ !> @brief This subroutine get information about global domain, given file
+ !> strucutre.
+ !>
+ !> @details
+ !> open edge files then:
+ !> - compute NEMO pivot point
+ !> - compute NEMO periodicity
+ !> - compute East West overlap
+ !>
+ !> @note need all processor files to be there
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !>
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
+ SUBROUTINE grid__get_info_file(td_file)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TFILE), INTENT(INOUT) :: td_file
+
+ ! local variable
+ INTEGER(i4) :: il_ew
+ INTEGER(i4) :: il_pivot
+ INTEGER(i4) :: il_perio
+ INTEGER(i4) :: il_attid
+
+ TYPE(TATT) :: tl_att
+
+ TYPE(TFILE) :: tl_file
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ ! intialise
+ il_pivot=-1
+ il_perio=-1
+ il_ew =-1
+
+ ! copy structure
+ tl_file=file_copy(td_file)
+
+ ! open file to be used
+ CALL iom_open(tl_file)
+
+ IF( td_file%i_perio >= 0 .AND. td_file%i_perio <= 6 )THEN
+ il_perio=td_file%i_perio
+ ELSE
+ ! look for attribute in file
+ il_attid=att_get_index(tl_file%t_att(:),'periodicity')
+ IF( il_attid /= 0 )THEN
+ il_perio=INT(tl_file%t_att(il_attid)%d_value(1),i4)
+ ENDIF
+ ENDIF
+
+ IF( td_file%i_ew >= 0 )THEN
+ il_ew=td_file%i_ew
+ ELSE
+ ! look for attribute in file
+ il_attid=att_get_index(tl_file%t_att(:),'ew_overlap')
+ IF( il_attid /= 0 )THEN
+ il_ew=INT(tl_file%t_att(il_attid)%d_value(1),i4)
+ ENDIF
+ ENDIF
+
+ SELECT CASE(il_perio)
+ CASE(3,4)
+ il_pivot=0
+ CASE(5,6)
+ il_pivot=1
+ CASE(0,1,2)
+ il_pivot=1
+ END SELECT
+
+ IF( il_pivot < 0 .OR. il_pivot > 1 )THEN
+ ! get pivot
+ il_pivot=grid_get_pivot(tl_file)
+ ENDIF
+
+ IF( il_perio < 0 .OR. il_perio > 6 )THEN
+ ! get periodicity
+ il_perio=grid_get_perio(tl_file, il_pivot)
+ ENDIF
+
+ IF( il_ew < 0 )THEN
+ ! get periodicity
+ il_ew=grid_get_ew_overlap(tl_file)
+ ENDIF
+
+ ! close
+ CALL iom_close(tl_file)
+
+ !save in file structure
+ td_file%i_ew=il_ew
+ td_file%i_pivot=il_pivot
+ td_file%i_perio=il_perio
+
+ ! save in variable of file structure
+ tl_att=att_init("ew_overlap",il_ew)
+ DO ji=1,td_file%i_nvar
+ IF( td_file%t_var(ji)%t_dim(jp_I)%l_use )THEN
+ CALL var_move_att(td_file%t_var(ji),tl_att)
+ ENDIF
+ ENDDO
+
+ ! clean
+ CALL file_clean(tl_file)
+ CALL att_clean(tl_att)
+
+ IF( td_file%i_perio == -1 )THEN
+ CALL logger_fatal("GRID GET INFO: can not read or compute "//&
+ & "domain periodicity from file "//TRIM(td_file%c_name)//"."//&
+ & " you have to inform periodicity in namelist.")
+ ENDIF
+
+ END SUBROUTINE grid__get_info_file
+ !-------------------------------------------------------------------
+ !> @brief This subroutine get information about global domain, given mpp
+ !> strucutre.
+ !>
+ !> @details
+ !> open edge files then:
+ !> - compute NEMO pivot point
+ !> - compute NEMO periodicity
+ !> - compute East West overlap
+ !>
+ !> @note need all processor files to be there
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !>
+ !> @param[in] td_mpp mpp structure
+ !-------------------------------------------------------------------
+ SUBROUTINE grid__get_info_mpp(td_mpp)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP) , INTENT(INOUT) :: td_mpp
+
+ ! local variable
+ INTEGER(i4) :: il_ew
+ INTEGER(i4) :: il_pivot
+ INTEGER(i4) :: il_perio
+ INTEGER(i4) :: il_attid
+
+ TYPE(TATT) :: tl_att
+
+ TYPE(TMPP) :: tl_mpp
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ !----------------------------------------------------------------
+ ! intialise
+ il_pivot=-1
+ il_perio=-1
+ il_ew =-1
+
+ ! copy structure
+ tl_mpp=mpp_copy(td_mpp)
+ ! select edge files
+ CALL mpp_get_contour(tl_mpp)
+ ! open mpp file to be used
+ CALL iom_mpp_open(tl_mpp)
+
+ IF( td_mpp%i_perio >= 0 .AND. td_mpp%i_perio <= 6 )THEN
+ il_perio=td_mpp%i_perio
+ ELSE
+ ! look for attribute in mpp files
+ il_attid=att_get_index(tl_mpp%t_proc(1)%t_att(:),'periodicity')
+ IF( il_attid /= 0 )THEN
+ il_perio=INT(tl_mpp%t_proc(1)%t_att(il_attid)%d_value(1),i4)
+ ENDIF
+ ENDIF
+
+ IF( td_mpp%i_ew >= 0 )THEN
+ il_ew=td_mpp%i_ew
+ ELSE
+ ! look for attribute in mpp files
+ il_attid=att_get_index(tl_mpp%t_proc(1)%t_att(:),'ew_overlap')
+ IF( il_attid /= 0 )THEN
+ il_ew=INT(tl_mpp%t_proc(1)%t_att(il_attid)%d_value(1),i4)
+ ENDIF
+ ENDIF
+
+ SELECT CASE(il_perio)
+ CASE(3,4)
+ il_pivot=0
+ CASE(5,6)
+ il_pivot=1
+ CASE(0,1,2)
+ il_pivot=1
+ END SELECT
+
+ IF( il_pivot < 0 .OR. il_pivot > 1 )THEN
+ ! get pivot
+ il_pivot=grid_get_pivot(tl_mpp)
+ ENDIF
+
+ IF( il_perio < 0 .OR. il_perio > 6 )THEN
+ ! get periodicity
+ il_perio=grid_get_perio(tl_mpp, il_pivot)
+ ENDIF
+
+ IF( il_ew < 0 )THEN
+ ! get periodicity
+ il_ew=grid_get_ew_overlap(tl_mpp)
+ ENDIF
+
+ ! close
+ CALL iom_mpp_close(tl_mpp)
+
+ !save in mpp structure
+ td_mpp%i_ew=il_ew
+ td_mpp%i_pivot=il_pivot
+ td_mpp%i_perio=il_perio
+
+ ! save in variable of mpp structure
+ IF( ASSOCIATED(td_mpp%t_proc) )THEN
+ tl_att=att_init("ew_overlap",il_ew)
+ DO jj=1,td_mpp%i_nproc
+ DO ji=1,td_mpp%t_proc(jj)%i_nvar
+ IF( td_mpp%t_proc(jj)%t_var(ji)%t_dim(jp_I)%l_use )THEN
+ CALL var_move_att(td_mpp%t_proc(jj)%t_var(ji),tl_att)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+
+ ! clean
+ CALL mpp_clean(tl_mpp)
+ CALL att_clean(tl_att)
+
+ IF( td_mpp%i_perio == -1 )THEN
+ CALL logger_fatal("GRID GET INFO: can not read or compute "//&
+ & "domain periodicity from mpp "//TRIM(td_mpp%c_name)//"."//&
+ & " you have to inform periodicity in namelist.")
+ ENDIF
+
+ END SUBROUTINE grid__get_info_mpp
+ !-------------------------------------------------------------------
!> @brief
- !> This funtion return NEMO pivot point index of the input variable.
+ !> This function compute NEMO pivot point index of the input variable.
!> - F-point : 0
!> - T-point : 1
!>
+ !> @details
+ !> check north points of latitude grid (indices jpj to jpj-3) depending on which grid point
+ !> (T,F,U,V) variable is defined
+ !>
+ !> @note variable must be at least 2D variable, and should not be coordinate
+ !> variable (i.e lon, lat)
+ !>
!> @warning
- !> - variable must be nav_lon or nav_lat
!> - do not work with ORCA2 grid (T-point)
!>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @todo
- !> - improve check between T or F pivot.
- !
- !> @param[in] td_file : file structure
- !> @param[in] cd_varname : variable name
- !> @return NEMO pivot point index
- !-------------------------------------------------------------------
- !> @code
- INTEGER(i4) FUNCTION grid_get_pivot(td_file)
+ !> - November, 2013- Subroutine written
+ !> @date September, 2014
+ !> - add dummy loop in case variable not over right point.
+ !> @date October, 2014
+ !> - work on variable structure instead of file structure
+ !
+ !> @param[in] td_lat latitude variable structure
+ !> @param[in] td_var variable structure
+ !> @return pivot point index
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_pivot_var(td_var)
IMPLICIT NONE
! Argument
- TYPE(TFILE), INTENT(IN) :: td_file
+ TYPE(TVAR), INTENT(IN) :: td_var
+
+ ! function
+ INTEGER(i4) :: grid__get_pivot_var
! local variable
- TYPE(TVAR) :: tl_var
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
+
+ REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
+
+ ! loop indices
+ INTEGER(i4) :: jj
+ !----------------------------------------------------------------
+ ! intitalise
+ grid__get_pivot_var=-1
+
+ IF( .NOT. ASSOCIATED(td_var%d_value) .OR. &
+ & .NOT. ALL(td_var%t_dim(1:2)%l_use) )THEN
+ CALL logger_error("GRID GET PIVOT: can not compute pivot point"//&
+ & " with variable "//TRIM(td_var%c_name)//"."//&
+ & " no value associated or missing dimension.")
+ ELSE
+ il_dim(:)=td_var%t_dim(:)%i_len
+
+ ALLOCATE(dl_value(il_dim(1),4,1,1))
+ ! extract value
+ dl_value(:,:,:,:)=td_var%d_value( 1:il_dim(1), &
+ & il_dim(2)-3:il_dim(2),&
+ & 1:1, &
+ & 1:1 )
+
+ SELECT CASE(TRIM(td_var%c_point))
+ CASE('T')
+ grid__get_pivot_var=grid__get_pivot_varT(dl_value)
+ CASE('U')
+ grid__get_pivot_var=grid__get_pivot_varU(dl_value)
+ CASE('V')
+ grid__get_pivot_var=grid__get_pivot_varV(dl_value)
+ CASE('F')
+ grid__get_pivot_var=grid__get_pivot_varF(dl_value)
+ END SELECT
+
+ ! dummy loop in case variable not over right point
+ ! (ex: nav_lon over U-point)
+ IF( grid__get_pivot_var == -1 )THEN
+
+ ! no pivot point found
+ CALL logger_error("GRID GET PIVOT: something wrong "//&
+ & "when computing pivot point with variable "//&
+ & TRIM(td_var%c_name))
+
+ DO jj=1,ip_npoint
+ SELECT CASE(TRIM(cp_grid_point(jj)))
+ CASE('T')
+ CALL logger_debug("GRID GET PIVOT: check variable on point T")
+ grid__get_pivot_var=grid__get_pivot_varT(dl_value)
+ CASE('U')
+ CALL logger_debug("GRID GET PIVOT: check variable on point U")
+ grid__get_pivot_var=grid__get_pivot_varU(dl_value)
+ CASE('V')
+ CALL logger_debug("GRID GET PIVOT: check variable on point V")
+ grid__get_pivot_var=grid__get_pivot_varV(dl_value)
+ CASE('F')
+ CALL logger_debug("GRID GET PIVOT: check variable on point F")
+ grid__get_pivot_var=grid__get_pivot_varF(dl_value)
+ END SELECT
+
+ IF( grid__get_pivot_var /= -1 )THEN
+ CALL logger_warn("GRID GET PIVOT: variable "//&
+ & TRIM(td_var%c_name)//" seems to be on grid point "//&
+ & TRIM(cp_grid_point(jj)) )
+ EXIT
+ ENDIF
+
+ ENDDO
+ ENDIF
+
+ IF( grid__get_pivot_var == -1 )THEN
+ CALL logger_warn("GRID GET PIVOT: not able to found pivot point. "//&
+ & "Force to use pivot point T.")
+ grid__get_pivot_var = 1
+ ENDIF
+
+ ! clean
+ DEALLOCATE(dl_value)
+
+ ENDIF
+
+ END FUNCTION grid__get_pivot_var
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This function compute NEMO pivot point index for variable on grid T.
+ !>
+ !> @details
+ !> - F-point : 0
+ !> - T-point : 1
+ !>
+ !> @note array of value must be only the top border of the domain.
+ !>
+ !> @author J.Paul
+ !> - October, 2014 - Initial version
+ !
+ !> @param[in] dd_value array of value
+ !> @return pivot point index
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_pivot_varT(dd_value)
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value
+
+ ! function
+ INTEGER(i4) :: grid__get_pivot_varT
+
+ ! local variable
+ INTEGER(i4) :: il_midT
+ INTEGER(i4) :: il_midF
+
+ INTEGER(i4) :: it1
+ INTEGER(i4) :: it2
+ INTEGER(i4) :: jt1
+ INTEGER(i4) :: jt2
+
+ INTEGER(i4) :: if1
+ INTEGER(i4) :: if2
+ INTEGER(i4) :: jf1
+ INTEGER(i4) :: jf2
+
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
+
+ LOGICAL :: ll_check
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ ! intitalise
+ grid__get_pivot_varT=-1
+
+ il_dim(:)=SHAPE(dd_value(:,:,:,:))
+
+ ! T-point pivot !case of ORCA2, ORCA025, ORCA12 grid
+ jt1=4 ; jt2=2
+ il_midT=il_dim(1)/2+1
+
+ ! F-point pivot !case of ORCA05 grid
+ jf1=4 ; jf2=3
+ il_midF=il_dim(1)/2
+
+ ! check T-point pivot
+ DO ji=2,il_midT
+ ll_check=.TRUE.
+ it1=ji
+ it2=il_dim(1)-(ji-2)
+ IF( dd_value(it1,jt1,1,1) /= dd_value(it2,jt2,1,1) )THEN
+ ll_check=.FALSE.
+ EXIT
+ ENDIF
+ ENDDO
+
+ IF( ll_check )THEN
+ CALL logger_info("GRID GET PIVOT: T-pivot")
+ grid__get_pivot_varT=1
+ ELSE
+
+ ! check F-point pivot
+ DO ji=1,il_midF
+ ll_check=.TRUE.
+ if1=ji
+ if2=il_dim(1)-(ji-1)
+ IF( dd_value(if1,jf1,1,1) /= dd_value(if2,jf2,1,1) )THEN
+ ll_check=.FALSE.
+ EXIT
+ ENDIF
+ ENDDO
+
+ IF( ll_check )THEN
+ CALL logger_info("GRID GET PIVOT: T-pivot")
+ grid__get_pivot_varT=0
+ ENDIF
+
+ ENDIF
+
+ END FUNCTION grid__get_pivot_varT
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This function compute NEMO pivot point index for variable on grid U.
+ !>
+ !> @details
+ !> - F-point : 0
+ !> - T-point : 1
+ !>
+ !> @note array of value must be only the top border of the domain.
+ !>
+ !> @author J.Paul
+ !> - October, 2014 - Initial version
+ !
+ !> @param[in] dd_value array of value
+ !> @return pivot point index
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_pivot_varU(dd_value)
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value
+
+ ! function
+ INTEGER(i4) :: grid__get_pivot_varU
+
+ ! local variable
+ INTEGER(i4) :: il_midT
+ INTEGER(i4) :: il_midF
+
+ INTEGER(i4) :: it1
+ INTEGER(i4) :: it2
+ INTEGER(i4) :: jt1
+ INTEGER(i4) :: jt2
+
+ INTEGER(i4) :: if1
+ INTEGER(i4) :: if2
+ INTEGER(i4) :: jf1
+ INTEGER(i4) :: jf2
+
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
+
+ LOGICAL :: ll_check
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ ! intitalise
+ grid__get_pivot_varU=-1
+
+ il_dim(:)=SHAPE(dd_value(:,:,:,:))
+
+ ! T-point pivot !case of ORCA2, ORCA025, ORCA12 grid
+ jt1=4 ; jt2=2
+ il_midT=il_dim(1)/2+1
+
+ ! F-point pivot !case of ORCA05 grid
+ jf1=4 ; jf2=3
+ il_midF=il_dim(1)/2
+
+ ! check T-point pivot
+ DO ji=1,il_midT
+ ll_check=.TRUE.
+ it1=ji
+ it2=il_dim(1)-(ji-2)
+ IF( dd_value(it1,jt1,1,1) /= dd_value(it2-1,jt2,1,1) )THEN
+ ll_check=.FALSE.
+ EXIT
+ ENDIF
+ ENDDO
+
+ IF( ll_check )THEN
+ CALL logger_info("GRID GET PIVOT: T-pivot")
+ grid__get_pivot_varU=1
+ ELSE
+
+ ! check F-point pivot
+ DO ji=1,il_midF
+ ll_check=.TRUE.
+ if1=ji
+ if2=il_dim(1)-(ji-1)
+ IF( dd_value(if1,jf1,1,1) /= dd_value(if2-1,jf2,1,1) )THEN
+ ll_check=.FALSE.
+ EXIT
+ ENDIF
+ ENDDO
+
+ IF( ll_check )THEN
+ CALL logger_info("GRID GET PIVOT: T-pivot")
+ grid__get_pivot_varU=0
+ ENDIF
+
+ ENDIF
+
+ END FUNCTION grid__get_pivot_varU
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This function compute NEMO pivot point index for variable on grid V.
+ !>
+ !> @details
+ !> - F-point : 0
+ !> - T-point : 1
+ !>
+ !> @note array of value must be only the top border of the domain.
+ !>
+ !> @author J.Paul
+ !> - October, 2014 - Initial version
+ !
+ !> @param[in] dd_value array of value
+ !> @return pivot point index
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_pivot_varV(dd_value)
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value
+
+ ! function
+ INTEGER(i4) :: grid__get_pivot_varV
+
+ ! local variable
+ INTEGER(i4) :: il_midT
+ INTEGER(i4) :: il_midF
+
+ INTEGER(i4) :: it1
+ INTEGER(i4) :: it2
+ INTEGER(i4) :: jt1
+ INTEGER(i4) :: jt2
+
+ INTEGER(i4) :: if1
+ INTEGER(i4) :: if2
+ INTEGER(i4) :: jf1
+ INTEGER(i4) :: jf2
+
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
+
+ LOGICAL :: ll_check
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ ! intitalise
+ grid__get_pivot_varV=-1
+
+ il_dim(:)=SHAPE(dd_value(:,:,:,:))
+
+ ! T-point pivot !case of ORCA2, ORCA025, ORCA12 grid
+ jt1=4 ; jt2=2
+ il_midT=il_dim(1)/2+1
+
+ ! F-point pivot !case of ORCA05 grid
+ jf1=4 ; jf2=3
+ il_midF=il_dim(1)/2
+
+ ! check T-point pivot
+ DO ji=2,il_midT
+ ll_check=.TRUE.
+ it1=ji
+ it2=il_dim(1)-(ji-2)
+ IF( dd_value(it1,jt1,1,1) /= dd_value(it2,jt2-1,1,1) )THEN
+ ll_check=.FALSE.
+ EXIT
+ ENDIF
+ ENDDO
+
+ IF( ll_check )THEN
+ CALL logger_info("GRID GET PIVOT: T-pivot")
+ grid__get_pivot_varV=1
+ ELSE
+
+ ! check F-point pivot
+ DO ji=1,il_midF
+ ll_check=.TRUE.
+ if1=ji
+ if2=il_dim(1)-(ji-1)
+ IF( dd_value(if1,jf1,1,1) /= dd_value(if2,jf2-1,1,1) )THEN
+ ll_check=.FALSE.
+ EXIT
+ ENDIF
+ ENDDO
+
+ IF( ll_check )THEN
+ CALL logger_info("GRID GET PIVOT: T-pivot")
+ grid__get_pivot_varV=0
+ ENDIF
+
+ ENDIF
+
+ END FUNCTION grid__get_pivot_varV
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This function compute NEMO pivot point index for variable on grid F.
+ !>
+ !> @details
+ !> - F-point : 0
+ !> - T-point : 1
+ !>
+ !> @note array of value must be only the top border of the domain.
+ !>
+ !> @author J.Paul
+ !> - October, 2014 - Initial version
+ !
+ !> @param[in] dd_value array of value
+ !> @return pivot point index
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_pivot_varF(dd_value)
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value
+
+ ! function
+ INTEGER(i4) :: grid__get_pivot_varF
+
+ ! local variable
+ INTEGER(i4) :: il_midT
+ INTEGER(i4) :: il_midF
+
+ INTEGER(i4) :: it1
+ INTEGER(i4) :: it2
+ INTEGER(i4) :: jt1
+ INTEGER(i4) :: jt2
+
+ INTEGER(i4) :: if1
+ INTEGER(i4) :: if2
+ INTEGER(i4) :: jf1
+ INTEGER(i4) :: jf2
+
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
+
+ LOGICAL :: ll_check
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ ! intitalise
+ grid__get_pivot_varF=-1
+
+ il_dim(:)=SHAPE(dd_value(:,:,:,:))
+
+ ! T-point pivot !case of ORCA2, ORCA025, ORCA12 grid
+ jt1=4 ; jt2=2
+ il_midT=il_dim(1)/2+1
+
+ ! F-point pivot !case of ORCA05 grid
+ jf1=4 ; jf2=3
+ il_midF=il_dim(1)/2
+
+ ! check T-point pivot
+ DO ji=1,il_midT
+ ll_check=.TRUE.
+ it1=ji
+ it2=il_dim(1)-(ji-2)
+ IF( dd_value(it1,jt1,1,1) /= dd_value(it2-1,jt2-1,1,1) )THEN
+ ll_check=.FALSE.
+ EXIT
+ ENDIF
+ ENDDO
+
+ IF( ll_check )THEN
+ CALL logger_info("GRID GET PIVOT: T-pivot")
+ grid__get_pivot_varF=1
+ ELSE
+
+ ! check F-point pivot
+ DO ji=1,il_midF
+ ll_check=.TRUE.
+ if1=ji
+ if2=il_dim(1)-(ji-1)
+ IF( dd_value(if1,jf1,1,1) /= dd_value(if2-1,jf2-1,1,1) )THEN
+ ll_check=.FALSE.
+ EXIT
+ ENDIF
+ ENDDO
+
+ IF( ll_check )THEN
+ CALL logger_info("GRID GET PIVOT: T-pivot")
+ grid__get_pivot_varF=0
+ ENDIF
+
+ ENDIF
+
+ END FUNCTION grid__get_pivot_varF
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This function compute NEMO pivot point index from input file variable.
+ !> - F-point : 0
+ !> - T-point : 1
+ !>
+ !> @details
+ !> check north points of latitude grid (indices jpj to jpj-3) depending on which grid point
+ !> (T,F,U,V) variable is defined
+ !>
+ !> @warning
+ !> - do not work with ORCA2 grid (T-point)
+ !>
+ !> @author J.Paul
+ !> - Ocotber, 2014- Initial version
+ !
+ !> @param[in] td_file file structure
+ !> @return pivot point index
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_pivot_file(td_file)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TFILE), INTENT(IN) :: td_file
+
+ ! function
+ INTEGER(i4) :: grid__get_pivot_file
+
+ ! local variable
INTEGER(i4) :: il_varid
INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
+ LOGICAL :: ll_north
+
+ TYPE(TVAR) :: tl_var
+ TYPE(TVAR) :: tl_lat
+
! loop indices
INTEGER(i4) :: ji
-
- INTEGER(i4) :: it1
- INTEGER(i4) :: it2
- INTEGER(i4) :: jt1
- INTEGER(i4) :: jt2
-
- INTEGER(i4) :: if1
- INTEGER(i4) :: if2
- INTEGER(i4) :: jf1
- INTEGER(i4) :: jf2
!----------------------------------------------------------------
- ! initialise
- grid_get_pivot=-1
+ ! intitalise
+ grid__get_pivot_file=-1
+
+ ! look for north fold
+ il_varid=var_get_index(td_file%t_var(:), 'latitude')
+ IF( il_varid == 0 )THEN
+ CALL logger_error("GRID GET PIVOT: no variable with name "//&
+ & "or standard name latitude in file structure "//&
+ & TRIM(td_file%c_name))
+ ENDIF
+ IF( ASSOCIATED(td_file%t_var(il_varid)%d_value) )THEN
+ tl_lat=var_copy(td_file%t_var(il_varid))
+ ELSE
+ tl_lat=iom_read_var(td_file, 'latitude')
+ ENDIF
+
+ ll_north=grid_is_north_fold(tl_lat)
+ ! clean
+ CALL var_clean(tl_lat)
+
+ IF( ll_north )THEN
+ ! look for suitable variable
+ DO ji=1,td_file%i_nvar
+ IF( .NOT. ALL(td_file%t_var(ji)%t_dim(1:2)%l_use) ) CYCLE
+
+ IF( ASSOCIATED(td_file%t_var(ji)%d_value) )THEN
+ tl_var=var_copy(td_file%t_var(ji))
+ ELSE
+ il_dim(:)=td_file%t_var(ji)%t_dim(:)%i_len
+ tl_var=iom_read_var(td_file, &
+ & td_file%t_var(ji)%c_name, &
+ & id_start=(/1,il_dim(2)-3,1,1/), &
+ & id_count=(/il_dim(1),4,1,1/) )
+ ENDIF
+ ENDDO
+
+ IF( ASSOCIATED(tl_var%d_value) )THEN
+
+ grid__get_pivot_file=grid_get_pivot(tl_var)
+
+ ENDIF
+
+ ! clean
+ CALL var_clean(tl_var)
+ ELSE
+ CALL logger_warn("GRID GET PIVOT: no north fold. force to use T-PIVOT")
+ grid__get_pivot_file=1
+ ENDIF
+
+ END FUNCTION grid__get_pivot_file
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This function compute NEMO pivot point index from input mpp variable.
+ !> - F-point : 0
+ !> - T-point : 1
+ !>
+ !> @details
+ !> check north points of latitude grid (indices jpj to jpj-3) depending on which grid point
+ !> (T,F,U,V) variable is defined
+ !>
+ !> @warning
+ !> - do not work with ORCA2 grid (T-point)
+ !>
+ !> @author J.Paul
+ !> - October, 2014 - Initial version
+ !
+ !> @param[in] td_mpp mpp file structure
+ !> @return pivot point index
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_pivot_mpp(td_mpp)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), INTENT(IN) :: td_mpp
+
+ ! function
+ INTEGER(i4) :: grid__get_pivot_mpp
+
+ ! local variable
+ INTEGER(i4) :: il_varid
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
+
+ LOGICAL :: ll_north
+
+ TYPE(TVAR) :: tl_var
+ TYPE(TVAR) :: tl_lat
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ ! intitalise
+ grid__get_pivot_mpp=-1
+
+ ! look for north fold
+ il_varid=var_get_index(td_mpp%t_proc(1)%t_var(:), 'latitude')
+ IF( il_varid == 0 )THEN
+ CALL logger_error("GRID GET PIVOT: no variable with name "//&
+ & "or standard name latitude in mpp structure "//&
+ & TRIM(td_mpp%c_name)//". Assume there is north fold and "//&
+ & "try to get pivot point")
+
+ ll_north=.TRUE.
+ ELSE
+ IF( ASSOCIATED(td_mpp%t_proc(1)%t_var(il_varid)%d_value) )THEN
+ !
+ tl_lat=mpp_recombine_var(td_mpp, 'latitude')
+ ELSE
+ tl_lat=iom_mpp_read_var(td_mpp, 'latitude')
+ ENDIF
+
+ ll_north=grid_is_north_fold(tl_lat)
+ ENDIF
+
+ IF( ll_north )THEN
+
+ IF( ASSOCIATED(tl_lat%d_value) )THEN
+ grid__get_pivot_mpp=grid_get_pivot(tl_lat)
+ ELSE
+ ! look for suitable variable
+ DO ji=1,td_mpp%t_proc(1)%i_nvar
+ IF(.NOT. ALL(td_mpp%t_proc(1)%t_var(ji)%t_dim(1:2)%l_use)) CYCLE
+
+ IF( ASSOCIATED(td_mpp%t_proc(1)%t_var(ji)%d_value) )THEN
+ CALL logger_debug("GRID GET PIVOT: mpp_recombine_var"//&
+ & TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name))
+ tl_var=mpp_recombine_var(td_mpp, &
+ & TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name))
+ ELSE
+ CALL logger_debug("GRID GET PIVOT: iom_mpp_read_var "//&
+ & TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name))
+ il_dim(:)=td_mpp%t_dim(:)%i_len
+
+ ! read variable
+ tl_var=iom_mpp_read_var(td_mpp, &
+ & td_mpp%t_proc(1)%t_var(ji)%c_name, &
+ & id_start=(/1,il_dim(2)-3,1,1/), &
+ & id_count=(/il_dim(1),4,1,1/) )
+ ENDIF
+ EXIT
+ ENDDO
+
+ IF( ASSOCIATED(tl_var%d_value) )THEN
+
+ grid__get_pivot_mpp=grid_get_pivot(tl_var)
+
+ ELSE
+ CALL logger_warn("GRID GET PIVOT: force to use T-PIVOT")
+ grid__get_pivot_mpp=1
+ ENDIF
+
+ ! clean
+ CALL var_clean(tl_var)
+ ENDIF
+ ELSE
+ CALL logger_warn("GRID GET PIVOT: no north fold. force to use T-PIVOT")
+ grid__get_pivot_mpp=1
+ ENDIF
+
+ CALL var_clean(tl_lat)
+ END FUNCTION grid__get_pivot_mpp
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine search NEMO periodicity index given variable structure and
+ !> pivot point index.
+ !> @details
+ !> The variable must be on T point.
+ !>
+ !> 0: closed boundaries
+ !> 1: cyclic east-west boundary
+ !> 2: symmetric boundary condition across the equator
+ !> 3: North fold boundary (with a F-point pivot)
+ !> 4: North fold boundary (with a F-point pivot) and cyclic east-west boundary
+ !> 5: North fold boundary (with a T-point pivot)
+ !> 6: North fold boundary (with a T-point pivot) and cyclic east-west boundary
+ !>
+ !> @warning pivot point should have been computed before run this script. see grid_get_pivot.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Subroutine written
+ !> @date October, 2014
+ !> - work on variable structure instead of file structure
+ !
+ !> @param[in] td_var variable structure
+ !> @param[in] id_pivot pivot point index
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_perio_var(td_var, id_pivot)
+ IMPLICIT NONE
+
+ ! Argument
+ TYPE(TVAR) , INTENT(IN) :: td_var
+ INTEGER(i4), INTENT(IN) :: id_pivot
+
+ ! function
+ INTEGER(i4) :: grid__get_perio_var
+
+ ! local variable
+ INTEGER(i4) :: il_perio
+
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
+
+ ! loop indices
+ !----------------------------------------------------------------
+ ! intitalise
+ grid__get_perio_var=-1
+
+ IF( id_pivot < 0 .OR. id_pivot > 1 )THEN
+ CALL logger_error("GRID GET PERIO: invalid pivot point index. "//&
+ & "you should use grid_get_pivot to compute it")
+ ENDIF
+
+ IF( .NOT. ASSOCIATED(td_var%d_value) .OR. &
+ & .NOT. ALL(td_var%t_dim(1:2)%l_use) )THEN
+ CALL logger_error("GRID GET PERIO: can not compute periodicity"//&
+ & " with variable "//TRIM(td_var%c_name)//"."//&
+ & " no value associated or missing dimension.")
+ ELSE
+
+ il_dim(:)=td_var%t_dim(:)%i_len
+
+ CALL logger_info("GRID GET PERIO: use varibale "//TRIM(td_var%c_name))
+ CALL logger_info("GRID GET PERIO: fill value "//TRIM(fct_str(td_var%d_fill)))
+ CALL logger_info("GRID GET PERIO: fill value "//TRIM(fct_str(td_var%d_value(1,1,1,1))))
+
+ IF(ALL(td_var%d_value( 1 , : ,1,1)/=td_var%d_fill).AND.&
+ & ALL(td_var%d_value(il_dim(1), : ,1,1)/=td_var%d_fill).AND.&
+ & ALL(td_var%d_value( : , 1 ,1,1)/=td_var%d_fill).AND.&
+ & ALL(td_var%d_value( : ,il_dim(2),1,1)/=td_var%d_fill))THEN
+ ! no boundary closed
+ CALL logger_warn("GRID GET PERIO: can't determined periodicity. "//&
+ & "there is no boundary closed for variable "//&
+ & TRIM(td_var%c_name) )
+ ELSE
+ ! check periodicity
+ IF(ANY(td_var%d_value( 1 ,:,1,1)/=td_var%d_fill).OR.&
+ & ANY(td_var%d_value(il_dim(1),:,1,1)/=td_var%d_fill))THEN
+ ! East-West cyclic (1,4,6)
+
+ IF( ANY(td_var%d_value(:, 1, 1, 1) /= td_var%d_fill) )THEN
+ ! South boundary not closed
+
+ CALL logger_debug("GRID GET PERIO: East_West cyclic")
+ CALL logger_debug("GRID GET PERIO: South boundary not closed")
+ CALL logger_error("GRID GET PERIO: should have been an "//&
+ & "impossible case")
+
+ ELSE
+ ! South boundary closed (1,4,6)
+ CALL logger_info("GRID GET PERIO: South boundary closed")
+
+ IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill) )THEN
+ ! North boundary not closed (4,6)
+ CALL logger_info("GRID GET PERIO: North boundary not closed")
+ ! check pivot
+ SELECT CASE(id_pivot)
+ CASE(0)
+ ! F pivot
+ il_perio=6
+ CASE(1)
+ ! T pivot
+ il_perio=4
+ CASE DEFAULT
+ CALL logger_error("GRID GET PERIO: invalid pivot ")
+ END SELECT
+ ELSE
+ ! North boundary closed
+ CALL logger_info("GRID GET PERIO: North boundary closed")
+ il_perio=1 ! North and South boundaries closed
+ ENDIF
+
+ ENDIF
+
+ ELSE
+ ! East-West boundaries closed (0,2,3,5)
+ CALL logger_info("GRID GET PERIO: East West boundaries closed")
+
+ IF( ANY(td_var%d_value(:, 1, 1, 1) /= td_var%d_fill) )THEN
+ ! South boundary not closed (2)
+ CALL logger_info("GRID GET PERIO: South boundary not closed")
+
+ IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill))THEN
+ ! North boundary not closed
+ CALL logger_debug("GRID GET PERIO: East West boundaries "//&
+ & "closed")
+ CALL logger_debug("GRID GET PERIO: South boundary not closed")
+ CALL logger_debug("GRID GET PERIO: North boundary not closed")
+ CALL logger_error("GRID GET PERIO: should have been "//&
+ & "an impossible case")
+ ELSE
+ ! North boundary closed
+ il_perio=2 ! East-West and North boundaries closed
+ ENDIF
+
+ ELSE
+ ! South boundary closed (0,3,5)
+ CALL logger_info("GRID GET PERIO: South boundary closed")
+
+ IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill))THEN
+ ! North boundary not closed (3,5)
+ CALL logger_info("GRID GET PERIO: North boundary not closed")
+ ! check pivot
+ SELECT CASE(id_pivot)
+ CASE(0)
+ ! F pivot
+ il_perio=5
+ CASE(1)
+ ! T pivot
+ il_perio=3
+ CASE DEFAULT
+ CALL logger_error("GRID GET PERIO: invalid pivot")
+ END SELECT
+ ELSE
+ ! North boundary closed
+ CALL logger_info("GRID GET PERIO: North boundary closed")
+ il_perio=0 ! all boundary closed
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+
+ grid__get_perio_var=il_perio
+
+ ENDIF
+
+ ENDIF
+
+ END FUNCTION grid__get_perio_var
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine search NEMO periodicity index given file structure, and
+ !> optionaly pivot point index.
+ !> @details
+ !> The variable used must be on T point.
+ !>
+ !> 0: closed boundaries
+ !> 1: cyclic east-west boundary
+ !> 2: symmetric boundary condition across the equator
+ !> 3: North fold boundary (with a F-point pivot)
+ !> 4: North fold boundary (with a F-point pivot) and cyclic east-west boundary
+ !> 5: North fold boundary (with a T-point pivot)
+ !> 6: North fold boundary (with a T-point pivot) and cyclic east-west boundary
+ !>
+ !> @warning pivot point should have been computed before run this script. see grid_get_pivot.
+ !>
+ !> @author J.Paul
+ !> - October, 2014 - Initial version
+ !>
+ !> @param[in] td_file file structure
+ !> @param[in] id_pivot pivot point index
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_perio_file(td_file, id_pivot)
+ IMPLICIT NONE
+
+ ! Argument
+ TYPE(TFILE), INTENT(IN) :: td_file
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
+
+ ! function
+ INTEGER(i4) :: grid__get_perio_file
+
+ ! local variable
+ INTEGER(i4) :: il_varid
+ INTEGER(i4) :: il_pivot
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
+
+ TYPE(TVAR) :: tl_var
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ !initialise
+ grid__get_perio_file=-1
+
+ IF(PRESENT(id_pivot) )THEN
+ il_pivot=id_pivot
+ ELSE
+ il_pivot=grid_get_pivot(td_file)
+ ENDIF
+
+ IF( il_pivot < 0 .OR. il_pivot > 1 )THEN
+ CALL logger_error("GRID GET PERIO: invalid pivot point index. "//&
+ & "you should use grid_get_pivot to compute it")
+ ENDIF
! look for suitable variable
@@ -134,104 +1503,34 @@
ENDDO
- IF( il_varid/=0 )THEN
- IF( ASSOCIATED(td_file%t_var(il_varid)%d_value) )THEN
- CALL logger_debug("GRID GET PIVOT: ASSOCIATED")
- tl_var=td_file%t_var(il_varid)
- ELSE
- ! read variable
- il_dim(:)=td_file%t_var(il_varid)%t_dim(:)%i_len
-
- CALL logger_debug("GRID GET PIVOT: read variable")
- tl_var=iom_read_var(td_file, td_file%t_var(il_varid)%c_name, &
- & id_start=(/1,il_dim(2)-3,1,1/), &
- & id_count=(/3,4,1,1/) )
- ENDIF
-
- CALL logger_debug("GRID GET PIVOT: use variable "//TRIM(tl_var%c_name))
-
- IF( ASSOCIATED(tl_var%d_value) )THEN
-
- CALL logger_debug("GRID GET PIVOT: point "//TRIM(tl_var%c_point))
- ! T-point pivot !case of ORCA2, ORCA025, ORCA12 grid
- it1=1 ; jt1=4
- it2=3 ; jt2=2
-
- ! F-point pivot !case of ORCA05 grid
- if1=1 ; jf1=4
- if2=2 ; jf2=3
-
- SELECT CASE(TRIM(tl_var%c_point))
- CASE('T')
- IF( ABS(tl_var%d_value(it1,jt1,1,1)) == &
- & ABS(tl_var%d_value(it2,jt2,1,1)) )THEN
- CALL logger_info("GRID GET PIVOT: T-pivot")
- grid_get_pivot=1
- ELSEIF( ABS(tl_var%d_value(if1,jf1,1,1)) == &
- & ABS(tl_var%d_value(if2,jf2,1,1)) )THEN
- CALL logger_info("GRID GET PIVOT: F-pivot")
- grid_get_pivot=0
- ELSE
- CALL logger_error("GRID GET PIVOT: something wrong when "//&
- & "computing pivot point")
- ENDIF
- CASE('U')
- IF( ABS(tl_var%d_value(it1 ,jt1,1,1)) == &
- & ABS(tl_var%d_value(it2-1,jt2,1,1)) )THEN
- CALL logger_info("GRID GET PIVOT: T-pivot")
- grid_get_pivot=1
- ELSEIF( ABS(tl_var%d_value(if1 ,jf1,1,1)) == &
- & ABS(tl_var%d_value(if2-1,jf2,1,1)) )THEN
- CALL logger_info("GRID GET PIVOT: F-pivot")
- grid_get_pivot=0
- ELSE
- CALL logger_error("GRID GET PIVOT: something wrong when "//&
- & "computing pivot point")
- ENDIF
- CASE('V')
- IF( ABS(tl_var%d_value(it1,jt1 ,1,1)) == &
- & ABS(tl_var%d_value(it2,jt2-1,1,1)) )THEN
- CALL logger_info("GRID GET PIVOT: T-pivot")
- grid_get_pivot=1
- ELSEIF( ABS(tl_var%d_value(if1,jf1 ,1,1)) == &
- & ABS(tl_var%d_value(if2,jf2-1,1,1)) )THEN
- CALL logger_info("GRID GET PIVOT: F-pivot")
- grid_get_pivot=0
- ELSE
- CALL logger_error("GRID GET PIVOT: something wrong when "//&
- & "computing pivot point")
- ENDIF
- CASE('F')
- IF( ABS(tl_var%d_value(it1 ,jt1 ,1,1)) == &
- & ABS(tl_var%d_value(it2-1,jt2-1,1,1)) )THEN
- CALL logger_info("GRID GET PIVOT: T-pivot")
- grid_get_pivot=1
- ELSEIF( ABS(tl_var%d_value(if1 ,jf1 ,1,1)) == &
- & ABS(tl_var%d_value(if2-1,jf2-1,1,1)) )THEN
- CALL logger_info("GRID GET PIVOT: F-pivot")
- grid_get_pivot=0
- ELSE
- CALL logger_error("GRID GET PIVOT: something wrong when "//&
- & "computing pivot point")
- ENDIF
- END SELECT
- ELSE
- CALL logger_error("GRID GET PIVOT: can't compute pivot point. "//&
- & "no value associated to variable "//TRIM(tl_var%c_name) )
- ENDIF
+ IF( il_varid==0 )THEN
+
+ CALL logger_error("GRID GET PERIO: no suitable variable to compute "//&
+ & " periodicity in file "//TRIM(td_file%c_name))
ELSE
- CALL logger_error("GRID GET PIVOT: no suitable variable to compute "//&
- & "pivot point in file "//TRIM(td_file%c_name))
- ENDIF
-
- END FUNCTION grid_get_pivot
- !> @endcode
+
+ il_dim(:)= td_file%t_var(il_varid)%t_dim(:)%i_len
+
+ ! read variable
+ tl_var=iom_read_var(td_file, &
+ & td_file%t_var(il_varid)%c_name, &
+ & id_start=(/1,1,1,1/), &
+ & id_count=(/il_dim(1),il_dim(2),1,1/) )
+
+
+ grid__get_perio_file=grid_get_perio(tl_var,il_pivot)
+
+ ! clean
+ CALL var_clean(tl_var)
+
+ ENDIF
+
+ END FUNCTION grid__get_perio_file
!-------------------------------------------------------------------
!> @brief
- !> This funtion return NEMO periodicity index of the input file.
+ !> This subroutine search NEMO periodicity given mpp structure and optionaly
+ !> pivot point index.
+ !> @details
!> The variable used must be on T point.
- !>
- !> @note the NEMO periodicity index can't be compute from coordinates file,
- !> neither with mpp files.
!>
!> 0: closed boundaries
@@ -243,36 +1542,42 @@
!> 6: North fold boundary (with a T-point pivot) and cyclic east-west boundary
!>
+ !> @warning pivot point should have been computed before run this script. see grid_get_pivot.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Subroutine written
- !
- !> @todo
- !> - improve check between T or F pivot.
- !> - manage mpp case (read only border files)
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_pivot : pivot point
- !> @return NEMO periodicity index
- !-------------------------------------------------------------------
- !> @code
- INTEGER(i4) FUNCTION grid_get_perio(td_file, id_pivot)
+ !> - October, 2014 - Initial version
+ !
+ !> @param[in] td_mpp mpp file structure
+ !> @param[in] id_pivot pivot point index
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_perio_mpp(td_mpp, id_pivot)
IMPLICIT NONE
! Argument
- TYPE(TFILE), INTENT(IN) :: td_file
- INTEGER(i4), INTENT(IN) :: id_pivot
+ TYPE(TMPP) , INTENT(IN) :: td_mpp
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
+
+ ! function
+ INTEGER(i4) :: grid__get_perio_mpp
! local variable
+ INTEGER(i4) :: il_varid
+ INTEGER(i4) :: il_pivot
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
+
TYPE(TVAR) :: tl_var
- INTEGER(i4) :: il_varid
- INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
! loop indices
INTEGER(i4) :: ji
!----------------------------------------------------------------
-
! initialise
- grid_get_perio=-1
-
- IF( id_pivot < 0 .OR. id_pivot > 1 )THEN
+ grid__get_perio_mpp=-1
+
+ IF(PRESENT(id_pivot) )THEN
+ il_pivot=id_pivot
+ ELSE
+ il_pivot=grid_get_pivot(td_mpp)
+ ENDIF
+
+ IF( il_pivot < 0 .OR. il_pivot > 1 )THEN
CALL logger_error("GRID GET PERIO: invalid pivot point index. "//&
& "you should use grid_get_pivot to compute it")
@@ -281,7 +1586,7 @@
! look for suitable variable
il_varid=0
- DO ji=1,td_file%i_nvar
- IF( .NOT. ALL(td_file%t_var(ji)%t_dim(1:2)%l_use) ) CYCLE
- SELECT CASE(TRIM(fct_lower(td_file%t_var(ji)%c_stdname)) )
+ DO ji=1,td_mpp%t_proc(1)%i_nvar
+ IF( .NOT. ALL(td_mpp%t_proc(1)%t_var(ji)%t_dim(1:2)%l_use) ) CYCLE
+ SELECT CASE(TRIM(fct_lower(td_mpp%t_proc(1)%t_var(ji)%c_stdname)) )
CASE('longitude','latitude')
CASE DEFAULT
@@ -292,122 +1597,289 @@
IF( il_varid==0 )THEN
-
+
CALL logger_error("GRID GET PERIO: no suitable variable to compute "//&
- & " periodicity in file "//TRIM(td_file%c_name))
+ & " periodicity in file "//TRIM(td_mpp%c_name))
ELSE
- il_dim(:)=td_file%t_var(il_varid)%t_dim(:)%i_len
-
- IF( ASSOCIATED(td_file%t_var(il_varid)%d_value) )THEN
- tl_var=td_file%t_var(il_varid)
- ELSE
- ! read variable
- tl_var=iom_read_var(td_file, td_file%t_var(il_varid)%c_name, &
- & id_start=(/1,1,1,1/), &
- & id_count=(/il_dim(1),il_dim(2),1,1/) )
+
+ DO ji=1,ip_maxdim
+ IF( td_mpp%t_proc(1)%t_var(il_varid)%t_dim(ji)%l_use )THEN
+ il_dim(ji)=td_mpp%t_dim(ji)%i_len
+ ELSE
+ il_dim(ji)=1
+ ENDIF
+ ENDDO
+
+ ! read variable
+ tl_var=iom_mpp_read_var(td_mpp, &
+ & td_mpp%t_proc(1)%t_var(il_varid)%c_name, &
+ & id_start=(/1,1,1,1/), &
+ & id_count=(/il_dim(1),il_dim(2),1,1/) )
+
+ grid__get_perio_mpp=grid_get_perio(tl_var, il_pivot)
+
+ ! clean
+ CALL var_clean(tl_var)
+ ENDIF
+
+ END FUNCTION grid__get_perio_mpp
+ !-------------------------------------------------------------------
+ !> @brief This function get East-West overlap.
+ !
+ !> @details
+ !> If no East-West wrap return -1,
+ !> else return the size of the ovarlap band.
+ !> East-West overlap is computed comparing longitude value of the
+ !> South" part of the domain, to avoid north fold boundary.
+ !>
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !>
+ !> @param[in] td_lon longitude variable structure
+ !> @return East West overlap
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_ew_overlap_var(td_var)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR), INTENT(INOUT) :: td_var
+ ! function
+ INTEGER(i4) :: grid__get_ew_overlap_var
+
+ ! local variable
+ REAL(dp), DIMENSION(:,:), ALLOCATABLE :: dl_value
+ REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_vare
+ REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_varw
+
+ REAL(dp) :: dl_delta
+ REAL(dp) :: dl_varmax
+ REAL(dp) :: dl_varmin
+
+ INTEGER(i4) :: il_east
+ INTEGER(i4) :: il_west
+ INTEGER(i4) :: il_jmin
+ INTEGER(i4) :: il_jmax
+
+ INTEGER(i4), PARAMETER :: il_max_overlap = 5
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ ! initialise
+ grid__get_ew_overlap_var=-1
+
+ IF( ASSOCIATED(td_var%d_value) )THEN
+ IF( td_var%t_dim(1)%i_len > 1 )THEN
+ il_west=1
+ il_east=td_var%t_dim(1)%i_len
+
+ ALLOCATE( dl_value(td_var%t_dim(1)%i_len, &
+ & td_var%t_dim(2)%i_len) )
+
+ dl_value(:,:)=td_var%d_value(:,:,1,1)
+
+ ! we do not use jmax as dimension length due to north fold boundary
+ il_jmin=1+ip_ghost
+ il_jmax=(td_var%t_dim(2)%i_len-ip_ghost)/2
+
+ ALLOCATE( dl_vare(il_jmax-il_jmin+1) )
+ ALLOCATE( dl_varw(il_jmax-il_jmin+1) )
+
+ dl_vare(:)=dl_value(il_east,il_jmin:il_jmax)
+ dl_varw(:)=dl_value(il_west,il_jmin:il_jmax)
+
+ IF( .NOT.( ALL(dl_vare(:)==td_var%d_fill) .AND. &
+ & ALL(dl_varw(:)==td_var%d_fill) ) )THEN
+
+ IF( TRIM(td_var%c_stdname) == 'longitude' )THEN
+ WHERE( dl_value(:,:) > 180._dp .AND. &
+ & dl_value(:,:) /= td_var%d_fill )
+ dl_value(:,:)=360.-dl_value(:,:)
+ END WHERE
+
+ dl_varmax=MAXVAL(dl_value(:,il_jmin:il_jmax))
+ dl_varmin=MINVAL(dl_value(:,il_jmin:il_jmax))
+
+ dl_delta=(dl_varmax-dl_varmin)/td_var%t_dim(1)%i_len
+
+ IF( ALL(ABS(dl_vare(:)) - ABS(dl_varw(:)) == dl_delta) )THEN
+ grid__get_ew_overlap_var=0
+ ENDIF
+ ENDIF
+
+ IF( grid__get_ew_overlap_var == -1 )THEN
+ DO ji=0,il_max_overlap
+
+ IF( il_east-ji == il_west )THEN
+ ! case of small domain
+ EXIT
+ ELSE
+ dl_vare(:)=dl_value(il_east-ji,il_jmin:il_jmax)
+
+ IF( ALL( dl_varw(:) == dl_vare(:) ) )THEN
+ grid__get_ew_overlap_var=ji+1
+ EXIT
+ ENDIF
+ ENDIF
+
+ ENDDO
+ ENDIF
+ ENDIF
+
ENDIF
-
- IF(ALL(tl_var%d_value( 1 , : ,1,1)/=tl_var%d_fill).AND.&
- & ALL(tl_var%d_value(il_dim(1), : ,1,1)/=tl_var%d_fill).AND.&
- & ALL(tl_var%d_value( : , 1 ,1,1)/=tl_var%d_fill).AND.&
- & ALL(tl_var%d_value( : ,il_dim(2),1,1)/=tl_var%d_fill))THEN
- ! no boundary closed
- CALL logger_warn("GRID GET PERIO: can't determined periodicity. "//&
- & "there is no boundary closed for variable "//&
- & TRIM(tl_var%c_name)//" in file "//&
- & TRIM(td_file%c_name) )
- ELSE
- ! check periodicity
- IF(ANY(tl_var%d_value( 1 ,:,1,1)/=tl_var%d_fill).OR.&
- & ANY(tl_var%d_value(il_dim(1),:,1,1)/=tl_var%d_fill))THEN
- ! East-West cyclic (1,4,6)
-
- IF( ANY(tl_var%d_value(:, 1, 1, 1) /= tl_var%d_fill) )THEN
- ! South boundary not closed
-
- CALL logger_error("GRID GET PERIO: should have been an "//&
- & "impossible case")
- CALL logger_debug("GRID GET PERIO: East_West cyclic")
- CALL logger_debug("GRID GET PERIO: South boundary not closed")
-
- ELSE
- ! South boundary closed (1,4,6)
- CALL logger_info("GRID GET PERIO: South boundary closed")
-
- IF(ANY(tl_var%d_value(:,il_dim(2),1,1)/=tl_var%d_fill) )THEN
- ! North boundary not closed (4,6)
- CALL logger_info("GRID GET PERIO: North boundary not closed")
- ! check pivot
- SELECT CASE(id_pivot)
- CASE(0)
- ! F pivot
- grid_get_perio=4
- CASE(1)
- ! T pivot
- grid_get_perio=6
- CASE DEFAULT
- CALL logger_error("GRID GET PERIO: invalid pivot ")
- END SELECT
- ELSE
- ! North boundary closed
- CALL logger_info("GRID GET PERIO: North boundary closed")
- grid_get_perio=1 ! North and South boundaries closed
- ENDIF
-
- ENDIF
-
- ELSE
- ! East-West boundaries closed (0,2,3,5)
- CALL logger_info("GRID GET PERIO: East West boundaries closed")
-
- IF( ANY(tl_var%d_value(:, 1, 1, 1) /= tl_var%d_fill) )THEN
- ! South boundary not closed (2)
- CALL logger_info("GRID GET PERIO: South boundary not closed")
-
- IF(ANY(tl_var%d_value(:,il_dim(2),1,1)/=tl_var%d_fill))THEN
- ! North boundary not closed
- CALL logger_error("GRID GET PERIO: should have been "//&
- & "an impossible case")
- CALL logger_debug("GRID GET PERIO: East West boundaries "//&
- & "closed")
- CALL logger_debug("GRID GET PERIO: South boundary not closed")
- CALL logger_debug("GRID GET PERIO: North boundary not closed")
- ELSE
- ! North boundary closed
- grid_get_perio=2 ! East-West and North boundaries closed
- ENDIF
-
- ELSE
- ! South boundary closed (0,3,5)
- CALL logger_info("GRID GET PERIO: South boundary closed")
-
- IF(ANY(tl_var%d_value(:,il_dim(2),1,1)/=tl_var%d_fill))THEN
- ! North boundary not closed (3,5)
- CALL logger_info("GRID GET PERIO: North boundary not closed")
- ! check pivot
- SELECT CASE(id_pivot)
- CASE(0)
- ! F pivot
- grid_get_perio=3
- CASE(1)
- ! T pivot
- grid_get_perio=5
- CASE DEFAULT
- CALL logger_error("GRID GET PERIO: invalid pivot")
- END SELECT
- ELSE
- ! North boundary closed
- CALL logger_info("GRID GET PERIO: North boundary closed")
- grid_get_perio=0 ! all boundary closed
- ENDIF
-
- ENDIF
-
- ENDIF
-
+ ELSE
+ CALL logger_error("GRID GET EW OVERLAP: input variable standard name"//&
+ & TRIM(td_var%c_stdname)//" can not be used to compute East West "//&
+ & "overalp. no value associated. ")
+ ENDIF
+
+ END FUNCTION grid__get_ew_overlap_var
+ !-------------------------------------------------------------------
+ !> @brief This function get East-West overlap.
+ !
+ !> @details
+ !> If no East-West wrap return -1,
+ !> else return the size of the ovarlap band.
+ !> East-West overlap is computed comparing longitude value of the
+ !> South" part of the domain, to avoid north fold boundary.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !>
+ !> @param[in] td_file file structure
+ !> @return East West overlap
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_ew_overlap_file(td_file)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TFILE), INTENT(INOUT) :: td_file
+ ! function
+ INTEGER(i4) :: grid__get_ew_overlap_file
+
+ ! local variable
+ INTEGER(i4) :: il_varid
+
+ TYPE(TVAR) :: tl_var
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ il_varid=var_get_index(td_file%t_var(:), 'longitude')
+ IF( il_varid /= 0 )THEN
+ ! read longitude on boundary
+ tl_var=iom_read_var(td_file, 'longitude')
+ ELSE
+ DO ji=1,td_file%i_nvar
+ IF( .NOT. ALL(td_file%t_var(ji)%t_dim(1:2)%l_use) ) CYCLE
+
+ tl_var=iom_read_var(td_file, td_file%t_var(ji)%c_name)
+ EXIT
+ ENDDO
+ ENDIF
+
+ grid__get_ew_overlap_file=grid_get_ew_overlap(tl_var)
+
+ ! clean
+ CALL var_clean(tl_var)
+
+ END FUNCTION grid__get_ew_overlap_file
+ !-------------------------------------------------------------------
+ !> @brief This function get East-West overlap.
+ !
+ !> @details
+ !> If no East-West wrap return -1,
+ !> else return the size of the ovarlap band.
+ !> East-West overlap is computed comparing longitude value of the
+ !> South" part of the domain, to avoid north fold boundary.
+ !>
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @return East West overlap
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_ew_overlap_mpp(td_mpp)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), INTENT(INOUT) :: td_mpp
+ ! function
+ INTEGER(i4) :: grid__get_ew_overlap_mpp
+
+ ! local variable
+ INTEGER(i4) :: il_ew
+ INTEGER(i4) :: il_varid
+
+ TYPE(TVAR) :: tl_var
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ ! initialise
+ grid__get_ew_overlap_mpp=td_mpp%i_ew
+
+ ! read longitude on boundary
+ il_varid=var_get_index(td_mpp%t_proc(1)%t_var(:),'longitude')
+ IF( il_varid /= 0 )THEN
+ tl_var=iom_mpp_read_var(td_mpp, 'longitude')
+ ELSE
+ DO ji=1,td_mpp%t_proc(1)%i_nvar
+ IF( .NOT. ALL(td_mpp%t_proc(1)%t_var(ji)%t_dim(1:2)%l_use) ) CYCLE
+
+ tl_var=iom_mpp_read_var(td_mpp, td_mpp%t_proc(1)%t_var(ji)%c_name)
+ EXIT
+ ENDDO
+ ENDIF
+
+ il_ew=grid_get_ew_overlap(tl_var)
+ IF( il_ew >= 0 )THEN
+ grid__get_ew_overlap_mpp=il_ew
+ ENDIF
+
+
+ ! clean
+ CALL var_clean(tl_var)
+
+ END FUNCTION grid__get_ew_overlap_mpp
+ !-------------------------------------------------------------------
+ !> @brief This subroutine check if there is north fold.
+ !>
+ !> @details
+ !> check if maximum latitude greater than 88°N
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] td_lat latitude variable structure
+ !-------------------------------------------------------------------
+ LOGICAL FUNCTION grid_is_north_fold(td_lat)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR), INTENT(IN) :: td_lat
+
+ ! local variable
+ ! loop indices
+ !----------------------------------------------------------------
+
+ ! init
+ grid_is_north_fold=.FALSE.
+
+ IF( .NOT. ASSOCIATED(td_lat%d_value) )THEN
+ CALL logger_error("GRID IS NORTH FOLD: "//&
+ & " no value associated to latitude")
+ ELSE
+ IF( MAXVAL(td_lat%d_value(:,:,:,:), &
+ & td_lat%d_value(:,:,:,:)/= td_lat%d_fill) >= 88.0 )THEN
+
+ grid_is_north_fold=.TRUE.
+
ENDIF
ENDIF
- END FUNCTION grid_get_perio
- !> @endcode
+ END FUNCTION grid_is_north_fold
!-------------------------------------------------------------------
!> @brief This subroutine check domain validity.
@@ -415,23 +1887,21 @@
!> @details
!> If maximum latitude greater than 88°N, program will stop.
- !> It is not able to manage north fold boundary for now.
+ !> @note Not able to manage north fold for now.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_coord : coordinate file
- !> @param[in] id_imin : i-direction lower left point indice
- !> @param[in] id_imax : i-direction upper right point indice
- !> @param[in] id_jmin : j-direction lower left point indice
- !> @param[in] id_jmax : j-direction upper right point indice
- !>
- !> @todo
- !> - use domain instead of start count
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !
+ !> @param[in] cd_coord coordinate file
+ !> @param[in] id_imin i-direction lower left point indice
+ !> @param[in] id_imax i-direction upper right point indice
+ !> @param[in] id_jmin j-direction lower left point indice
+ !> @param[in] id_jmax j-direction upper right point indice
+ !-------------------------------------------------------------------
SUBROUTINE grid_check_dom(td_coord, id_imin, id_imax, id_jmin, id_jmax)
IMPLICIT NONE
! Argument
- TYPE(TFILE), INTENT(IN) :: td_coord
+ TYPE(TMPP) , INTENT(IN) :: td_coord
INTEGER(i4), INTENT(IN) :: id_imin
INTEGER(i4), INTENT(IN) :: id_imax
@@ -440,16 +1910,13 @@
! local variable
- TYPE(TVAR) :: tl_var
-
- TYPE(TFILE) :: tl_coord
-
- TYPE(TMPP) :: tl_mppcoord
-
- TYPE(TDOM) :: tl_dom
-
+ TYPE(TVAR) :: tl_var
+
+ TYPE(TMPP) :: tl_coord
+
+ TYPE(TDOM) :: tl_dom
! loop indices
!----------------------------------------------------------------
- IF( id_jmin >= id_jmax )THEN
+ IF( id_jmin > id_jmax .OR. id_jmax == 0 )THEN
CALL logger_fatal("GRID CHECK DOM: invalid domain. "//&
@@ -457,9 +1924,4 @@
ELSE
-
- IF( td_coord%i_id == 0 )THEN
- CALL logger_error("GRID CHECK DOM: can not check domain. "//&
- & " file "//TRIM(td_coord%c_name)//" not opened." )
- ELSE
IF( id_imin == id_imax .AND. td_coord%i_ew < 0 )THEN
@@ -469,36 +1931,23 @@
ENDIF
- !1- read domain
- tl_coord=td_coord
- CALL iom_open(tl_coord)
-
- !1-1 compute domain
+ ! copy structure
+ tl_coord=mpp_copy(td_coord)
+
+ ! compute domain
tl_dom=dom_init( tl_coord, &
- & id_imin, id_imax,&
- & id_jmin, id_jmax )
+ & id_imin, id_imax,&
+ & id_jmin, id_jmax )
- !1-2 close file
- CALL iom_close(tl_coord)
-
- !1-3 read variables on domain (ugly way to do it, have to work on it)
- !1-3-1 init mpp structure
- tl_mppcoord=mpp_init(tl_coord)
-
- CALL file_clean(tl_coord)
-
- !1-3-2 get processor to be used
- CALL mpp_get_use( tl_mppcoord, tl_dom )
-
- !1-3-3 open mpp files
- CALL iom_mpp_open(tl_mppcoord)
-
- !1-3-4 read variable value on domain
- tl_var=iom_mpp_read_var(tl_mppcoord,'latitude',td_dom=tl_dom)
-
- !1-3-5 close mpp files
- CALL iom_mpp_close(tl_mppcoord)
-
- !1-3-6 clean structure
- CALL mpp_clean(tl_mppcoord)
+ ! open mpp files to be used
+ CALL iom_dom_open(tl_coord, tl_dom)
+
+ ! read variable value on domain
+ tl_var=iom_dom_read_var(tl_coord,'latitude',tl_dom)
+
+ ! close mpp files
+ CALL iom_dom_close(tl_coord)
+
+ ! clean structure
+ CALL mpp_clean(tl_coord)
IF( MAXVAL(tl_var%d_value(:,:,:,:), &
@@ -513,41 +1962,49 @@
! clean
+ CALL dom_clean(tl_dom)
CALL var_clean(tl_var)
- ENDIF
-
-
ENDIF
END SUBROUTINE grid_check_dom
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function get closest coarse grid indices of fine grid domain.
!
!> @details
- !>
- !
+ !> it use coarse and fine grid coordinates files.
+ !> optionally, you could specify the array of refinment factor (default 1.)
+ !> optionally, you could specify on which Arakawa grid point you want to
+ !> work (default 'T')
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_coord0 : coarse grid coordinate structure
- !> @param[in] td_coord1 : fine grid coordinate structure
- !> @return coarse grid indices (/ (/imin0, imax0/), (/jmin0, jmax0/) /)
- !> @todo
- !> - use domain instead of start count
- !-------------------------------------------------------------------
- !> @code
- FUNCTION grid_get_coarse_index_ff( td_coord0, td_coord1, &
- & id_rho )
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - use grid point to read coordinates variable.
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !>
+ !> @param[in] td_coord0 coarse grid coordinate mpp structure
+ !> @param[in] td_coord1 fine grid coordinate mpp structure
+ !> @param[in] id_rho array of refinment factor (default 1.)
+ !> @param[in] cd_point Arakawa grid point (default 'T').
+ !> @return coarse grid indices(/(/imin0, imax0/), (/jmin0, jmax0/)/)
+ !>
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_coarse_index_ff( td_coord0, td_coord1, &
+ & id_rho, cd_point )
IMPLICIT NONE
! Argument
- TYPE(TFILE), INTENT(IN) :: td_coord0
- TYPE(TFILE), INTENT(IN) :: td_coord1
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho
+ TYPE(TMPP) , INTENT(IN) :: td_coord0
+ TYPE(TMPP) , INTENT(IN) :: td_coord1
+ INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho
+ CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point
! function
- INTEGER(i4), DIMENSION(2,2,2) :: grid_get_coarse_index_ff
+ INTEGER(i4), DIMENSION(2,2) :: grid__get_coarse_index_ff
! local variable
+ TYPE(TMPP) :: tl_coord0
+ TYPE(TMPP) :: tl_coord1
+
TYPE(TVAR) :: tl_lon0
TYPE(TVAR) :: tl_lat0
@@ -555,10 +2012,8 @@
TYPE(TVAR) :: tl_lat1
- INTEGER(i4) , DIMENSION(:), ALLOCATABLE :: il_rho
-
- INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
- INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
- INTEGER(i4), DIMENSION(2) :: il_xghost0
- INTEGER(i4), DIMENSION(2) :: il_xghost1
+ INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho
+
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost0
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost1
INTEGER(i4) :: il_imin0
@@ -567,8 +2022,6 @@
INTEGER(i4) :: il_jmax0
- INTEGER(i4) :: il_imin1
- INTEGER(i4) :: il_imax1
- INTEGER(i4) :: il_jmin1
- INTEGER(i4) :: il_jmax1
+ CHARACTER(LEN= 1) :: cl_point
+ CHARACTER(LEN=lc) :: cl_name
! loop indices
@@ -576,85 +2029,78 @@
! init
- grid_get_coarse_index_ff(:,:,:)=0
-
- ALLOCATE(il_rho(ig_ndim))
+ grid__get_coarse_index_ff(:,:)=0
+
+ ALLOCATE(il_rho(ip_maxdim))
il_rho(:)=1
IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:)
- IF( td_coord0%i_id == 0 .OR. td_coord1%i_id == 0 )THEN
- CALL logger_error("GRID GET COARSE INDEX: can not get corase "//&
- & "grid indices. file "//TRIM(td_coord0%c_name)//" and/or "//&
- & TRIM(td_coord1%c_name)//" not opened." )
+ cl_point='T'
+ IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point))
+
+ ! copy structure
+ tl_coord0=mpp_copy(td_coord0)
+ tl_coord1=mpp_copy(td_coord1)
+
+ IF( .NOT. ASSOCIATED(tl_coord0%t_proc) .OR. &
+ & .NOT. ASSOCIATED(tl_coord1%t_proc) )THEN
+ CALL logger_error("GRID GET COARSE INDEX: can not get coarse "//&
+ & "grid indices. decompsition of mpp file "//TRIM(tl_coord0%c_name)//&
+ & " and/or "//TRIM(tl_coord1%c_name)//" not defined." )
ELSE
- !1- Coarse grid
+ ! Coarse grid
+ ! get ghost cell factor on coarse grid
+ il_xghost0(:,:)=grid_get_ghost( tl_coord0 )
+
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord0)
+
! read coarse longitue and latitude
- tl_lon0=iom_read_var(td_coord0,'longitude')
- tl_lat0=iom_read_var(td_coord0,'latitude')
-
- ! get ghost cell factor on coarse grid
- il_xghost0(:)=grid_get_ghost( tl_lon0, tl_lat0 )
-
- il_imin0=1+il_xghost0(1)*ig_ghost
- il_jmin0=1+il_xghost0(2)*ig_ghost
-
- il_imax0=tl_lon0%t_dim(1)%i_len-il_xghost0(1)*ig_ghost
- il_jmax0=tl_lon0%t_dim(2)%i_len-il_xghost0(2)*ig_ghost
-
- CALL var_clean(tl_lon0)
- CALL var_clean(tl_lat0)
-
- ! read coarse longitue and latitude without ghost cell
- il_start(:)=(/il_imin0,il_jmin0,1,1/)
- il_count(:)=(/il_imax0-il_imin0+1, &
- & il_jmax0-il_jmin0+1, &
- & tl_lon0%t_dim(3)%i_len, &
- & tl_lon0%t_dim(4)%i_len /)
-
- tl_lon0=iom_read_var(td_coord0,'longitude',il_start(:), il_count(:))
- tl_lat0=iom_read_var(td_coord0,'latitude' ,il_start(:), il_count(:))
+ WRITE(cl_name,*) 'longitude_'//TRIM(cl_point)
+ tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name))
+ WRITE(cl_name,*) 'latitude_'//TRIM(cl_point)
+ tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name))
- !2- Fine grid
+ CALL grid_del_ghost(tl_lon0, il_xghost0(:,:))
+ CALL grid_del_ghost(tl_lat0, il_xghost0(:,:))
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_coord0)
+
+ ! Fine grid
+
+ ! get ghost cell factor on fine grid
+ il_xghost1(:,:)=grid_get_ghost( tl_coord1 )
+
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord1)
+
! read fine longitue and latitude
- tl_lon1=iom_read_var(td_coord1,'longitude')
- tl_lat1=iom_read_var(td_coord1,'latitude')
-
- ! get ghost cell factor on fine grid
- il_xghost1(:)=grid_get_ghost( tl_lon1, tl_lat1 )
-
- il_imin1=1+il_xghost1(1)*ig_ghost
- il_jmin1=1+il_xghost1(2)*ig_ghost
-
- il_imax1=tl_lon1%t_dim(1)%i_len-il_xghost1(1)*ig_ghost
- il_jmax1=tl_lon1%t_dim(2)%i_len-il_xghost1(2)*ig_ghost
-
- CALL var_clean(tl_lon1)
- CALL var_clean(tl_lat1)
-
- ! read fine longitue and latitude without ghost cell
- il_start(:)=(/il_imin1,il_jmin1,1,1/)
- il_count(:)=(/il_imax1-il_imin1+1, &
- & il_jmax1-il_jmin1+1, &
- & tl_lon1%t_dim(3)%i_len, &
- & tl_lon1%t_dim(4)%i_len /)
-
- tl_lon1=iom_read_var(td_coord1,'longitude',il_start(:), il_count(:))
-
- tl_lat1=iom_read_var(td_coord1,'latitude' ,il_start(:), il_count(:))
+ WRITE(cl_name,*) 'longitude_'//TRIM(cl_point)
+ tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name))
+ WRITE(cl_name,*) 'latitude_'//TRIM(cl_point)
+ tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name))
- !3- compute
-
- grid_get_coarse_index_ff(:,:,:)=grid_get_coarse_index(tl_lon0,tl_lat0,&
- & tl_lon1,tl_lat1,&
- & il_rho(:) )
-
- il_imin0=grid_get_coarse_index_ff(1,1,1)-il_xghost0(1)*ig_ghost
- il_imax0=grid_get_coarse_index_ff(1,2,1)+il_xghost0(1)*ig_ghost
- il_jmin0=grid_get_coarse_index_ff(2,1,1)-il_xghost0(2)*ig_ghost
- il_jmax0=grid_get_coarse_index_ff(2,2,1)+il_xghost0(2)*ig_ghost
-
- grid_get_coarse_index_ff(1,1,1)=il_imin0
- grid_get_coarse_index_ff(1,2,1)=il_imax0
- grid_get_coarse_index_ff(2,1,1)=il_jmin0
- grid_get_coarse_index_ff(2,2,1)=il_jmax0
+ CALL grid_del_ghost(tl_lon1, il_xghost1(:,:))
+ CALL grid_del_ghost(tl_lat1, il_xghost1(:,:))
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_coord1)
+
+ ! compute
+ grid__get_coarse_index_ff(:,:)=grid_get_coarse_index(tl_lon0,tl_lat0,&
+ & tl_lon1,tl_lat1,&
+ & il_rho(:) )
+
+ ! add ghost cell to indices
+ il_imin0=grid__get_coarse_index_ff(1,1)+il_xghost0(jp_I,1)*ip_ghost
+ il_imax0=grid__get_coarse_index_ff(1,2)+il_xghost0(jp_I,1)*ip_ghost
+
+ il_jmin0=grid__get_coarse_index_ff(2,1)+il_xghost0(jp_J,1)*ip_ghost
+ il_jmax0=grid__get_coarse_index_ff(2,2)+il_xghost0(jp_J,1)*ip_ghost
+
+ grid__get_coarse_index_ff(jp_I,1)=il_imin0
+ grid__get_coarse_index_ff(jp_I,2)=il_imax0
+ grid__get_coarse_index_ff(jp_J,1)=il_jmin0
+ grid__get_coarse_index_ff(jp_J,2)=il_jmax0
CALL var_clean(tl_lon0)
@@ -665,34 +2111,49 @@
ENDIF
- END FUNCTION grid_get_coarse_index_ff
- !> @endcode
+ ! clean
+ CALL mpp_clean(tl_coord0)
+ CALL mpp_clean(tl_coord1)
+ DEALLOCATE(il_rho)
+
+ END FUNCTION grid__get_coarse_index_ff
!-------------------------------------------------------------------
!> @brief This function get closest coarse grid indices of fine grid domain.
!
!> @details
- !>
- !
+ !> it use coarse array of longitude and latitude and fine grid coordinates file.
+ !> optionaly, you could specify the array of refinment factor (default 1.)
+ !> optionally, you could specify on which Arakawa grid point you want to
+ !> work (default 'T')
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_longitude0 : coarse grid longitude
- !> @param[in] td_latitude0 : coarse grid latitude
- !> @param[in] td_coord1 : fine grid coordinate structure
- !> @return coarse grid indices (/ (/imin0, imax0/), (/jmin0, jmax0/) /)
- !-------------------------------------------------------------------
- !> @code
- FUNCTION grid_get_coarse_index_cf( td_lon0, td_lat0, td_coord1, &
- & id_rho )
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - use grid point to read coordinates variable.
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !>
+ !> @param[in] td_longitude0 coarse grid longitude
+ !> @param[in] td_latitude0 coarse grid latitude
+ !> @param[in] td_coord1 fine grid coordinate mpp structure
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] cd_point Arakawa grid point (default 'T')
+ !> @return coarse grid indices (/(/imin0, imax0/), (/jmin0, jmax0/)/)
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_coarse_index_cf( td_lon0, td_lat0, td_coord1, &
+ & id_rho, cd_point )
IMPLICIT NONE
! Argument
- TYPE(TVAR ), INTENT(IN) :: td_lon0
- TYPE(TVAR ), INTENT(IN) :: td_lat0
- TYPE(TFILE), INTENT(IN) :: td_coord1
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho
+ TYPE(TVAR ) , INTENT(IN) :: td_lon0
+ TYPE(TVAR ) , INTENT(IN) :: td_lat0
+ TYPE(TMPP ) , INTENT(IN) :: td_coord1
+ INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho
+ CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point
! function
- INTEGER(i4), DIMENSION(2,2,2) :: grid_get_coarse_index_cf
+ INTEGER(i4), DIMENSION(2,2) :: grid__get_coarse_index_cf
! local variable
+ TYPE(TMPP) :: tl_coord1
+
TYPE(TVAR) :: tl_lon1
TYPE(TVAR) :: tl_lat1
@@ -700,12 +2161,8 @@
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho
- INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
- INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
- INTEGER(i4), DIMENSION(2) :: il_xghost
-
- INTEGER(i4) :: il_imin1
- INTEGER(i4) :: il_imax1
- INTEGER(i4) :: il_jmin1
- INTEGER(i4) :: il_jmax1
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost
+
+ CHARACTER(LEN= 1) :: cl_point
+ CHARACTER(LEN=lc) :: cl_name
! loop indices
@@ -713,13 +2170,19 @@
! init
- grid_get_coarse_index_cf(:,:,:)=0
-
- ALLOCATE(il_rho(ig_ndim) )
+ grid__get_coarse_index_cf(:,:)=0
+
+ ALLOCATE(il_rho(ip_maxdim) )
il_rho(:)=1
IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:)
- IF( td_coord1%i_id == 0 )THEN
- CALL logger_error("GRID GET COARSE INDEX: file "//&
- & TRIM(td_coord1%c_name)//" not opened." )
+ ! copy structure
+ tl_coord1=mpp_copy(td_coord1)
+
+ cl_point='T'
+ IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point))
+
+ IF( .NOT. ASSOCIATED(tl_coord1%t_proc) )THEN
+ CALL logger_error("GRID GET COARSE INDEX: decompsition of mpp "//&
+ & "file "//TRIM(tl_coord1%c_name)//" not defined." )
ELSE IF( .NOT. ASSOCIATED(td_lon0%d_value) .OR. &
@@ -731,36 +2194,35 @@
ELSE
- !1- Fine grid
+ IF( TRIM(td_lon0%c_point)/='' )THEN
+ cl_point=TRIM(td_lon0%c_point)
+ ELSEIF( TRIM(td_lat0%c_point)/='' )THEN
+ cl_point=TRIM(td_lat0%c_point)
+ ENDIF
+
+ ! Fine grid
+ ! get ghost cell factor on fine grid
+ il_xghost(:,:)=grid_get_ghost( tl_coord1 )
+
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord1)
+
! read fine longitue and latitude
- tl_lon1=iom_read_var(td_coord1,'longitude')
- tl_lat1=iom_read_var(td_coord1,'latitude')
-
- ! get ghost cell factor on fine grid
- il_xghost(:)=grid_get_ghost( tl_lon1, tl_lat1 )
-
- il_imin1=1+il_xghost(1)*ig_ghost
- il_jmin1=1+il_xghost(2)*ig_ghost
-
- il_imax1=tl_lon1%t_dim(1)%i_len-il_xghost(1)*ig_ghost
- il_jmax1=tl_lon1%t_dim(2)%i_len-il_xghost(2)*ig_ghost
-
- CALL var_clean(tl_lon1)
- CALL var_clean(tl_lat1)
-
- ! read fine longitue and latitude without ghost cell
- il_start(:)=(/il_imin1,il_jmin1,1,1/)
- il_count(:)=(/il_imax1-il_imin1+1, &
- & il_jmax1-il_jmin1+1, &
- & tl_lon1%t_dim(3)%i_len, &
- & tl_lon1%t_dim(4)%i_len /)
-
- tl_lon1=iom_read_var(td_coord1,'longitude',il_start(:), il_count(:))
- tl_lat1=iom_read_var(td_coord1,'latitude' ,il_start(:), il_count(:))
+ WRITE(cl_name,*) 'longitude_'//TRIM(cl_point)
+ tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name))
+ WRITE(cl_name,*) 'latitude_'//TRIM(cl_point)
+ tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name))
- !3- compute
- grid_get_coarse_index_cf(:,:,:)=grid_get_coarse_index(td_lon0,td_lat0,&
- & tl_lon1,tl_lat1,&
- & il_rho(:) )
-
+ CALL grid_del_ghost(tl_lon1, il_xghost(:,:))
+ CALL grid_del_ghost(tl_lat1, il_xghost(:,:))
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_coord1)
+
+ ! compute
+ grid__get_coarse_index_cf(:,:)=grid_get_coarse_index(td_lon0,td_lat0,&
+ & tl_lon1,tl_lat1,&
+ & il_rho(:), cl_point )
+
+
CALL var_clean(tl_lon1)
CALL var_clean(tl_lat1)
@@ -768,36 +2230,47 @@
ENDIF
- END FUNCTION grid_get_coarse_index_cf
- !> @endcode
+ DEALLOCATE(il_rho)
+ CALL mpp_clean(tl_coord1)
+
+ END FUNCTION grid__get_coarse_index_cf
!-------------------------------------------------------------------
!> @brief This function get closest coarse grid indices of fine grid domain.
!
!> @details
- !>
- !> @warning use ghost cell so can not be used on extracted domain without
- !> ghost cell
- !
+ !> it use coarse grid coordinates file and fine grid array of longitude and latitude.
+ !> optionaly, you could specify the array of refinment factor (default 1.)
+ !> optionally, you could specify on which Arakawa grid point you want to
+ !> work (default 'T')
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_coord0 : coarse grid coordinate structure
- !> @param[in] td_lon1 : fine grid longitude
- !> @param[in] td_lat1 : fine grid latitude
- !> @return coarse grid indices (/ (/imin0, imax0/), (/jmin0, jmax0/) /)
- !-------------------------------------------------------------------
- !> @code
- FUNCTION grid_get_coarse_index_fc( td_coord0, td_lon1, td_lat1, &
- & id_rho )
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - use grid point to read coordinates variable.
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !>
+ !> @param[in] td_coord0 coarse grid coordinate mpp structure
+ !> @param[in] td_lon1 fine grid longitude
+ !> @param[in] td_lat1 fine grid latitude
+ !> @param[in] id_rho array of refinment factor (default 1.)
+ !> @param[in] cd_point Arakawa grid point (default 'T')
+ !> @return coarse grid indices (/(/imin0, imax0/), (/jmin0, jmax0/)/)
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_coarse_index_fc( td_coord0, td_lon1, td_lat1, &
+ & id_rho, cd_point )
IMPLICIT NONE
! Argument
- TYPE(TFILE), INTENT(IN) :: td_coord0
- TYPE(TVAR ), INTENT(IN) :: td_lon1
- TYPE(TVAR ), INTENT(IN) :: td_lat1
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho
+ TYPE(TMPP ) , INTENT(IN) :: td_coord0
+ TYPE(TVAR ) , INTENT(IN) :: td_lon1
+ TYPE(TVAR ) , INTENT(IN) :: td_lat1
+ INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho
+ CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point
! function
- INTEGER(i4), DIMENSION(2,2,2) :: grid_get_coarse_index_fc
+ INTEGER(i4), DIMENSION(2,2) :: grid__get_coarse_index_fc
! local variable
+ TYPE(TMPP) :: tl_coord0
+
TYPE(TVAR) :: tl_lon0
TYPE(TVAR) :: tl_lat0
@@ -805,7 +2278,5 @@
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho
- INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
- INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
- INTEGER(i4), DIMENSION(2) :: il_xghost
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost
INTEGER(i4) :: il_imin0
@@ -814,4 +2285,6 @@
INTEGER(i4) :: il_jmax0
+ CHARACTER(LEN= 1) :: cl_point
+ CHARACTER(LEN=lc) :: cl_name
! loop indices
@@ -819,13 +2292,19 @@
! init
- grid_get_coarse_index_fc(:,:,:)=0
-
- ALLOCATE(il_rho(ig_ndim))
+ grid__get_coarse_index_fc(:,:)=0
+
+ ALLOCATE(il_rho(ip_maxdim))
il_rho(:)=1
IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:)
- IF( td_coord0%i_id == 0 )THEN
- CALL logger_error("GRID GET COARSE INDEX: file "//&
- & TRIM(td_coord0%c_name)//" not opened." )
+ cl_point='T'
+ IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point))
+
+ ! copy structure
+ tl_coord0=mpp_copy(td_coord0)
+
+ IF( .NOT. ASSOCIATED(tl_coord0%t_proc) )THEN
+ CALL logger_error("GRID GET COARSE INDEX: decompsition of mpp "//&
+ & "file "//TRIM(tl_coord0%c_name)//" not defined." )
ELSE IF( .NOT. ASSOCIATED(td_lon1%d_value) .OR. &
@@ -836,83 +2315,95 @@
ELSE
+
+ IF( TRIM(td_lon1%c_point)/='' )THEN
+ cl_point=TRIM(td_lon1%c_point)
+ ELSEIF( TRIM(td_lat1%c_point)/='' )THEN
+ cl_point=TRIM(td_lat1%c_point)
+ ENDIF
+
+ ! get ghost cell factor on coarse grid
+ il_xghost(:,:)=grid_get_ghost( tl_coord0 )
+
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord0)
+
! read coarse longitue and latitude
- tl_lon0=iom_read_var(td_coord0,'longitude')
- tl_lat0=iom_read_var(td_coord0,'latitude')
-
- ! get ghost cell factor on coarse grid
- il_xghost(:)=grid_get_ghost( tl_lon0, tl_lat0 )
-
- il_imin0=1+il_xghost(1)*ig_ghost
- il_jmin0=1+il_xghost(2)*ig_ghost
-
- il_imax0=tl_lon0%t_dim(1)%i_len-il_xghost(1)*ig_ghost
- il_jmax0=tl_lon0%t_dim(2)%i_len-il_xghost(2)*ig_ghost
+ WRITE(cl_name,*) 'longitude_'//TRIM(cl_point)
+ tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name))
+ WRITE(cl_name,*) 'latitude_'//TRIM(cl_point)
+ tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name))
+
+ CALL grid_del_ghost(tl_lon0, il_xghost(:,:))
+ CALL grid_del_ghost(tl_lat0, il_xghost(:,:))
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_coord0)
+
+ grid__get_coarse_index_fc(:,:)=grid_get_coarse_index(tl_lon0,tl_lat0,&
+ & td_lon1,td_lat1,&
+ & il_rho(:), cl_point )
+
+ ! remove ghost cell
+ il_imin0=grid__get_coarse_index_fc(1,1)+il_xghost(jp_I,1)*ip_ghost
+ il_imax0=grid__get_coarse_index_fc(1,2)+il_xghost(jp_I,1)*ip_ghost
+
+ il_jmin0=grid__get_coarse_index_fc(2,1)+il_xghost(jp_J,1)*ip_ghost
+ il_jmax0=grid__get_coarse_index_fc(2,2)+il_xghost(jp_J,1)*ip_ghost
+
+ grid__get_coarse_index_fc(1,1)=il_imin0
+ grid__get_coarse_index_fc(1,2)=il_imax0
+ grid__get_coarse_index_fc(2,1)=il_jmin0
+ grid__get_coarse_index_fc(2,2)=il_jmax0
CALL var_clean(tl_lon0)
CALL var_clean(tl_lat0)
- ! read coarse longitue and latitude without ghost cell
- il_start(:)=(/il_imin0,il_jmin0,1,1/)
- il_count(:)=(/il_imax0-il_imin0+1, &
- & il_jmax0-il_jmin0+1, &
- & tl_lon0%t_dim(3)%i_len, &
- & tl_lon0%t_dim(4)%i_len /)
-
- tl_lon0=iom_read_var(td_coord0,'longitude',il_start(:), il_count(:))
- tl_lat0=iom_read_var(td_coord0,'latitude' ,il_start(:), il_count(:))
-
- grid_get_coarse_index_fc(:,:,:)=grid_get_coarse_index(tl_lon0,tl_lat0,&
- & td_lon1,td_lat1,&
- & il_rho(:) )
-
- ! remove ghost cell
- il_imin0=grid_get_coarse_index_fc(1,1,1)+il_xghost(1)*ig_ghost
- il_imax0=grid_get_coarse_index_fc(1,2,1)+il_xghost(1)*ig_ghost
- il_jmin0=grid_get_coarse_index_fc(2,1,1)+il_xghost(2)*ig_ghost
- il_jmax0=grid_get_coarse_index_fc(2,2,1)+il_xghost(2)*ig_ghost
-
- grid_get_coarse_index_fc(1,1,1)=il_imin0
- grid_get_coarse_index_fc(1,2,1)=il_imax0
- grid_get_coarse_index_fc(2,1,1)=il_jmin0
- grid_get_coarse_index_fc(2,2,1)=il_jmax0
-
- CALL var_clean(tl_lon0)
- CALL var_clean(tl_lat0)
-
- ENDIF
-
- END FUNCTION grid_get_coarse_index_fc
- !> @endcode
+ ENDIF
+
+ CALL mpp_clean(tl_coord0)
+ DEALLOCATE(il_rho)
+
+ END FUNCTION grid__get_coarse_index_fc
!-------------------------------------------------------------------
!> @brief This function get closest coarse grid indices of fine grid domain.
!
!> @details
- !>
- !> @warning use ghost cell so can not be used on extracted domain without
- !> ghost cell
- !
+ !> it use coarse and fine grid array of longitude and latitude.
+ !> optionaly, you could specify the array of refinment factor (default 1.)
+ !> optionally, you could specify on which Arakawa grid point you want to
+ !> work (default 'T')
+ !>
+ !> @note do not use ghost cell
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_lon0 : coarse grid longitude
- !> @param[in] td_lat0 : coarse grid latitude
- !> @param[in] td_lon1 : fine grid longitude
- !> @param[in] td_lat1 : fine grid latitude
- !> @return coarse grid indices (/ (/imin0, imax0/), (/jmin0, jmax0/) /)
- !>
- !-------------------------------------------------------------------
- !> @code
- FUNCTION grid_get_coarse_index_cc( td_lon0, td_lat0, td_lon1, td_lat1, &
- & id_rho )
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - check grid point
+ !> - take into account EW overlap
+ !>
+ !> @param[in] td_lon0 coarse grid longitude
+ !> @param[in] td_lat0 coarse grid latitude
+ !> @param[in] td_lon1 fine grid longitude
+ !> @param[in] td_lat1 fine grid latitude
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] cd_point Arakawa grid point ('T','U','V','F')
+ !> @return coarse grid indices (/(/imin0, imax0/), (/jmin0, jmax0/)/)
+ !>
+ !> @todo
+ !> -check case boundary domain on overlap band
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_coarse_index_cc( td_lon0, td_lat0, td_lon1, td_lat1, &
+ & id_rho, cd_point )
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(IN) :: td_lon0
- TYPE(TVAR) , INTENT(IN) :: td_lat0
- TYPE(TVAR) , INTENT(IN) :: td_lon1
- TYPE(TVAR) , INTENT(IN) :: td_lat1
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho
+ TYPE(TVAR) , INTENT(IN) :: td_lon0
+ TYPE(TVAR) , INTENT(IN) :: td_lat0
+ TYPE(TVAR) , INTENT(IN) :: td_lon1
+ TYPE(TVAR) , INTENT(IN) :: td_lat1
+ INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho
+ CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point
! function
- INTEGER(i4), DIMENSION(2,2,2) :: grid_get_coarse_index_cc
+ INTEGER(i4), DIMENSION(2,2) :: grid__get_coarse_index_cc
! local variable
@@ -927,7 +2418,4 @@
REAL(dp) :: dl_lat1_ur
- REAL(dp) :: dl_dlon
- REAL(dp) :: dl_dlat
-
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho
@@ -954,18 +2442,35 @@
INTEGER(i4) :: il_jmax
- INTEGER(i4), DIMENSION(2,2) :: il_offset
-
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost0
+ INTEGER(i4), DIMENSION(2,2) :: il_yghost0
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost1
+ INTEGER(i4), DIMENSION(2,2) :: il_yghost1
+
+ TYPE(TVAR) :: tl_lon0
+ TYPE(TVAR) :: tl_lat0
+ TYPE(TVAR) :: tl_lon1
+ TYPE(TVAR) :: tl_lat1
+
+ CHARACTER(LEN= 1) :: cl_point0
+ CHARACTER(LEN= 1) :: cl_point1
+
! loop indices
INTEGER(i4) :: ji
INTEGER(i4) :: jj
!----------------------------------------------------------------
-
! init
- grid_get_coarse_index_cc(:,:,:)=0
-
- ALLOCATE( il_rho(ig_ndim) )
+ grid__get_coarse_index_cc(:,:)=0
+
+ ALLOCATE( il_rho(ip_maxdim) )
il_rho(:)=1
IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:)
+ cl_point0='T'
+ cl_point1='T'
+ IF( PRESENT(cd_point) )THEN
+ cl_point0=TRIM(fct_upper(cd_point))
+ cl_point1=TRIM(fct_upper(cd_point))
+ ENDIF
+
IF( .NOT. ASSOCIATED(td_lon0%d_value) .OR. &
& .NOT. ASSOCIATED(td_lat0%d_value) .OR. &
@@ -976,10 +2481,25 @@
ELSE
+ IF( TRIM(td_lon0%c_point)/='' )THEN
+ cl_point0=TRIM(td_lon0%c_point)
+ ELSEIF( TRIM(td_lat0%c_point)/='' )THEN
+ cl_point0=TRIM(td_lat0%c_point)
+ ENDIF
+ IF( TRIM(td_lon1%c_point)/='' )THEN
+ cl_point1=TRIM(td_lon1%c_point)
+ ELSEIF( TRIM(td_lat1%c_point)/='' )THEN
+ cl_point1=TRIM(td_lat1%c_point)
+ ENDIF
+ IF( cl_point0 /= cl_point1 )THEN
+ CALL logger_error("GRID GET COARSE INDEX: fine and coarse grid"//&
+ & " coordinate not on same grid point.")
+ ENDIF
+
IF( grid_is_global(td_lon1, td_lat1) )THEN
IF( grid_is_global(td_lon0, td_lat0) )THEN
CALL logger_trace("GRID GET COARSE INDEX: fine grid is global ")
- grid_get_coarse_index_cc(:,:,1) = 1
- grid_get_coarse_index_cc(:,:,2) = 0
+ grid__get_coarse_index_cc(:,:) = 1
+ grid__get_coarse_index_cc(:,:) = 0
ELSE
CALL logger_error("GRID GET COARSE INDEX: fine grid is "//&
@@ -989,13 +2509,25 @@
ELSE
+ il_xghost0(:,:)=grid_get_ghost( td_lon0 )
+ il_yghost0(:,:)=grid_get_ghost( td_lat0 )
+ IF( ANY(il_xghost0(:,:) /= il_yghost0(:,:)) )THEN
+ CALL logger_error("GRID GET COARSE INDEX: coarse grid "//&
+ & "coordinate do not share same ghost cell")
+ ENDIF
+
+ tl_lon0=var_copy(td_lon0)
+ tl_lat0=var_copy(td_lat0)
+ CALL grid_del_ghost(tl_lon0, il_xghost0(:,:))
+ CALL grid_del_ghost(tl_lat0, il_xghost0(:,:))
+
! "global" coarse grid indice
il_imin0=1
il_jmin0=1
- il_imax0=td_lon0%t_dim(1)%i_len
- il_jmax0=td_lon0%t_dim(2)%i_len
+ il_imax0=tl_lon0%t_dim(1)%i_len
+ il_jmax0=tl_lon0%t_dim(2)%i_len
! get east west overlap for coarse grid
- il_ew0=dom_get_ew_overlap(td_lon0)
+ il_ew0=tl_lon0%i_ew
IF( il_ew0 >= 0 )THEN
! last point before overlap
@@ -1003,13 +2535,25 @@
ENDIF
+ il_xghost1(:,:)=grid_get_ghost( td_lon1 )
+ il_yghost1(:,:)=grid_get_ghost( td_lat1 )
+ IF( ANY(il_xghost1(:,:) /= il_yghost1(:,:)) )THEN
+ CALL logger_error("GRID GET COARSE INDEX: fine grid "//&
+ & "coordinate do not share same ghost cell")
+ ENDIF
+
+ tl_lon1=var_copy(td_lon1)
+ tl_lat1=var_copy(td_lat1)
+ CALL grid_del_ghost(tl_lon1, il_xghost1(:,:))
+ CALL grid_del_ghost(tl_lat1, il_xghost1(:,:))
+
! "global" fine grid indice
il_imin1=1
il_jmin1=1
- il_imax1=td_lon1%t_dim(1)%i_len
- il_jmax1=td_lon1%t_dim(2)%i_len
-
- ! get east west overlap for coarse grid
- il_ew1=dom_get_ew_overlap(td_lon1)
+ il_imax1=tl_lon1%t_dim(1)%i_len
+ il_jmax1=tl_lon1%t_dim(2)%i_len
+
+ ! get east west overlap for fine grid
+ il_ew1=tl_lon1%i_ew
IF( il_ew1 >= 0 )THEN
! last point before overlap
@@ -1019,30 +2563,18 @@
! get indices for each corner
!1- search lower left corner indices
- dl_lon1_ll=td_lon1%d_value( il_imin1, il_jmin1, 1, 1 )
- dl_lat1_ll=td_lat1%d_value( il_imin1, il_jmin1, 1, 1 )
-
- dl_dlon=ABS(td_lon1%d_value(il_imin1+1,il_jmin1 ,1,1)-dl_lon1_ll)
- dl_dlat=ABS(td_lat1%d_value(il_imin1 ,il_jmin1+1,1,1)-dl_lat1_ll)
-
-! CALL logger_debug("GRID GET COARSE INDEX: lon1 ll "//&
-! & TRIM(fct_str(dl_lon1_ll)) )
-! CALL logger_debug("GRID GET COARSE INDEX: lat1 ll "//&
-! & TRIM(fct_str(dl_lat1_ll)) )
-!
-! CALL logger_debug("GRID GET COARSE INDEX: lon0 min "//&
-! & TRIM(fct_str(minval(td_lon0%d_value(2:,2:,:,:)))) )
-! CALL logger_debug("GRID GET COARSE INDEX: lon0 max "//&
-! & TRIM(fct_str(maxval(td_lon0%d_value(2:,2:,:,:)))) )
-!
-! CALL logger_debug("GRID GET COARSE INDEX: lat0 min "//&
-! & TRIM(fct_str(minval(td_lat0%d_value(2:,2:,:,:)))) )
-! CALL logger_debug("GRID GET COARSE INDEX: lat0 max "//&
-! & TRIM(fct_str(maxval(td_lat0%d_value(2:,2:,:,:)))) )
-
+ dl_lon1_ll=tl_lon1%d_value( il_imin1, il_jmin1, 1, 1 )
+ dl_lat1_ll=tl_lat1%d_value( il_imin1, il_jmin1, 1, 1 )
+
+ IF( dl_lon1_ll == tl_lon1%d_fill .OR. &
+ & dl_lat1_ll == tl_lat1%d_fill )THEN
+ CALL logger_error("GRID GET COARSE INDEX: lower left corner "//&
+ & "point is FillValue. remove ghost cell "//&
+ & "before running grid_get_coarse_index.")
+ ENDIF
! look for closest point on coarse grid
- il_ill(:)= grid_get_closest(td_lon0%d_value(il_imin0:il_imax0, &
+ il_ill(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, &
& il_jmin0:il_jmax0, &
& 1,1), &
- & td_lat0%d_value(il_imin0:il_imax0, &
+ & tl_lat0%d_value(il_imin0:il_imax0, &
& il_jmin0:il_jmax0, &
& 1,1), &
@@ -1053,23 +2585,44 @@
jj = il_ill(2)
- IF( ABS(td_lon0%d_value(ji,jj,1,1)-dl_lon1_ll) > dl_dlon*1.e-3 )THEN
- IF(td_lon0%d_value(ji,jj,1,1) > dl_lon1_ll ) il_ill(1)=il_ill(1)-1
+ IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_ll) > dp_delta )THEN
+ IF(tl_lon0%d_value(ji,jj,1,1) > dl_lon1_ll )THEN
+ il_ill(1)=il_ill(1)-1
+ IF( il_ill(1) <= 0 )THEN
+ IF( tl_lon0%i_ew >= 0 )THEN
+ il_ill(1)=tl_lon0%t_dim(jp_I)%i_len-tl_lon0%i_ew
+ ELSE
+ CALL logger_error("GRID GET COARSE INDEX: error "//&
+ & "computing lower left corner "//&
+ & "index for longitude")
+ ENDIF
+ ENDIF
+ ENDIF
ENDIF
- IF( ABS(td_lat0%d_value(ji,jj,1,1)-dl_lat1_ll) > dl_dlat*1.e-3 )THEN
- IF(td_lat0%d_value(ji,jj,1,1) > dl_lat1_ll ) il_ill(2)=il_ill(2)-1
+ IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_ll) > dp_delta )THEN
+ IF(tl_lat0%d_value(ji,jj,1,1) > dl_lat1_ll )THEN
+ il_ill(2)=il_ill(2)-1
+ IF( il_ill(2)-1 <= 0 )THEN
+ CALL logger_error("GRID GET COARSE INDEX: error "//&
+ & "computing lower left corner "//&
+ & "index for latitude")
+ ENDIF
+ ENDIF
ENDIF
!2- search upper left corner indices
- dl_lon1_ul=td_lon1%d_value( il_imin1, il_jmax1, 1, 1 )
- dl_lat1_ul=td_lat1%d_value( il_imin1, il_jmax1, 1, 1 )
-
- dl_dlon=ABS(td_lon1%d_value(il_imin1+1,il_jmax1 ,1,1)-dl_lon1_ll)
- dl_dlat=ABS(td_lat1%d_value(il_imin1 ,il_jmax1-1,1,1)-dl_lat1_ll)
-
+ dl_lon1_ul=tl_lon1%d_value( il_imin1, il_jmax1, 1, 1 )
+ dl_lat1_ul=tl_lat1%d_value( il_imin1, il_jmax1, 1, 1 )
+
+ IF( dl_lon1_ul == tl_lon1%d_fill .OR. &
+ & dl_lat1_ul == tl_lat1%d_fill )THEN
+ CALL logger_error("GRID GET COARSE INDEX: upper left corner "//&
+ & "point is FillValue. remove ghost cell "//&
+ & "running grid_get_coarse_index.")
+ ENDIF
! look for closest point on coarse grid
- il_iul(:)= grid_get_closest(td_lon0%d_value(il_imin0:il_imax0, &
+ il_iul(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, &
& il_jmin0:il_jmax0, &
& 1,1), &
- & td_lat0%d_value(il_imin0:il_imax0, &
+ & tl_lat0%d_value(il_imin0:il_imax0, &
& il_jmin0:il_jmax0, &
& 1,1), &
@@ -1080,23 +2633,45 @@
jj = il_iul(2)
- IF( ABS(td_lon0%d_value(ji,jj,1,1)-dl_lon1_ul) > dl_dlon*1.e-3 )THEN
- IF(td_lon0%d_value(ji,jj,1,1) > dl_lon1_ul ) il_iul(1)=il_iul(1)-1
+ IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_ul) > dp_delta )THEN
+ IF(tl_lon0%d_value(ji,jj,1,1) > dl_lon1_ul )THEN
+ il_iul(1)=il_iul(1)-1
+ IF( il_iul(1) <= 0 )THEN
+ IF( tl_lon0%i_ew >= 0 )THEN
+ il_iul(1)=tl_lon0%t_dim(jp_I)%i_len-tl_lon0%i_ew
+ ELSE
+ CALL logger_error("GRID GET COARSE INDEX: error "//&
+ & "computing upper left corner "//&
+ & "index for longitude")
+ ENDIF
+ ENDIF
+ ENDIF
ENDIF
- IF( ABS(td_lat0%d_value(ji,jj,1,1)-dl_lat1_ul) > dl_dlat*1.e-3 )THEN
- IF(td_lat0%d_value(ji,jj,1,1) < dl_lat1_ul ) il_iul(2)=il_iul(2)+1
+
+ IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_ul) > dp_delta )THEN
+ IF(tl_lat0%d_value(ji,jj,1,1) < dl_lat1_ul )THEN
+ il_iul(2)=il_iul(2)+1
+ IF( il_ill(2) > tl_lat0%t_dim(jp_J)%i_len )THEN
+ CALL logger_error("GRID GET COARSE INDEX: error "//&
+ & "computing upper left corner "//&
+ & "index for latitude")
+ ENDIF
+ ENDIF
ENDIF
!3- search lower right corner indices
- dl_lon1_lr=td_lon1%d_value( il_imax1, il_jmin1, 1, 1 )
- dl_lat1_lr=td_lat1%d_value( il_imax1, il_jmin1, 1, 1 )
-
- dl_dlon=ABS(td_lon1%d_value(il_imax1-1,il_jmin1 ,1,1)-dl_lon1_ll)
- dl_dlat=ABS(td_lat1%d_value(il_imax1 ,il_jmin1+1,1,1)-dl_lat1_ll)
-
+ dl_lon1_lr=tl_lon1%d_value( il_imax1, il_jmin1, 1, 1 )
+ dl_lat1_lr=tl_lat1%d_value( il_imax1, il_jmin1, 1, 1 )
+
+ IF( dl_lon1_lr == tl_lon1%d_fill .OR. &
+ & dl_lat1_lr == tl_lat1%d_fill )THEN
+ CALL logger_error("GRID GET COARSE INDEX: lower right corner "//&
+ & "point is FillValue. remove ghost cell "//&
+ & "running grid_get_coarse_index.")
+ ENDIF
! look for closest point on coarse grid
- il_ilr(:)= grid_get_closest(td_lon0%d_value(il_imin0:il_imax0, &
+ il_ilr(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, &
& il_jmin0:il_jmax0, &
& 1,1), &
- & td_lat0%d_value(il_imin0:il_imax0, &
+ & tl_lat0%d_value(il_imin0:il_imax0, &
& il_jmin0:il_jmax0, &
& 1,1), &
@@ -1106,23 +2681,44 @@
ji = il_ilr(1)
jj = il_ilr(2)
- IF( ABS(td_lon0%d_value(ji,jj,1,1)-dl_lon1_lr) > dl_dlon*1.e-3 )THEN
- IF( td_lon0%d_value(ji,jj,1,1) < dl_lon1_lr ) il_ilr(1)=il_ilr(1)+1
+ IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_lr) > dp_delta )THEN
+ IF( tl_lon0%d_value(ji,jj,1,1) < dl_lon1_lr )THEN
+ il_ilr(1)=il_ilr(1)+1
+ IF( il_ilr(1) > tl_lon0%t_dim(jp_I)%i_len )THEN
+ IF( tl_lon0%i_ew >= 0 )THEN
+ il_ilr(1)=tl_lon0%i_ew+1
+ ELSE
+ CALL logger_error("GRID GET COARSE INDEX: error "//&
+ & "computing lower right corner "//&
+ & "index for longitude")
+ ENDIF
+ ENDIF
+ ENDIF
ENDIF
- IF( ABS(td_lat0%d_value(ji,jj,1,1)-dl_lat1_lr) > dl_dlat*1.e-3 )THEN
- IF( td_lat0%d_value(ji,jj,1,1) > dl_lat1_lr ) il_ilr(2)=il_ilr(2)-1
+ IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_lr) > dp_delta )THEN
+ IF( tl_lat0%d_value(ji,jj,1,1) > dl_lat1_lr )THEN
+ il_ilr(2)=il_ilr(2)-1
+ IF( il_ilr(2) <= 0 )THEN
+ CALL logger_error("GRID GET COARSE INDEX: error "//&
+ & "computing lower right corner "//&
+ & "index for latitude")
+ ENDIF
+ ENDIF
ENDIF
!4- search upper right corner indices
- dl_lon1_ur=td_lon1%d_value( il_imax1, il_jmax1, 1, 1 )
- dl_lat1_ur=td_lat1%d_value( il_imax1, il_jmax1, 1, 1 )
-
- dl_dlon=ABS(td_lon1%d_value(il_imax1-1,il_jmax1 ,1,1)-dl_lon1_ll)
- dl_dlat=ABS(td_lat1%d_value(il_imax1 ,il_jmax1-1,1,1)-dl_lat1_ll)
-
+ dl_lon1_ur=tl_lon1%d_value( il_imax1, il_jmax1, 1, 1 )
+ dl_lat1_ur=tl_lat1%d_value( il_imax1, il_jmax1, 1, 1 )
+
+ IF( dl_lon1_ur == tl_lon1%d_fill .OR. &
+ & dl_lat1_ur == tl_lat1%d_fill )THEN
+ CALL logger_error("GRID GET COARSE INDEX: upper right corner "//&
+ & "point is FillValue. remove ghost cell "//&
+ & "running grid_get_coarse_index.")
+ ENDIF
! look for closest point on coarse grid
- il_iur(:)= grid_get_closest(td_lon0%d_value(il_imin0:il_imax0, &
+ il_iur(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, &
& il_jmin0:il_jmax0, &
& 1,1), &
- & td_lat0%d_value(il_imin0:il_imax0, &
+ & tl_lat0%d_value(il_imin0:il_imax0, &
& il_jmin0:il_jmax0, &
& 1,1), &
@@ -1132,9 +2728,27 @@
ji = il_iur(1)
jj = il_iur(2)
- IF( ABS(td_lon0%d_value(ji,jj,1,1)-dl_lon1_ur) > dl_dlon*1.e-3 )THEN
- IF( td_lon0%d_value(ji,jj,1,1) < dl_lon1_ur ) il_iur(1)=il_iur(1)+1
+ IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_ur) > dp_delta )THEN
+ IF( tl_lon0%d_value(ji,jj,1,1) < dl_lon1_ur )THEN
+ il_iur(1)=il_iur(1)+1
+ IF( il_iur(1) > tl_lon0%t_dim(jp_I)%i_len )THEN
+ IF( tl_lon0%i_ew >= 0 )THEN
+ il_iur(1)=tl_lon0%i_ew+1
+ ELSE
+ CALL logger_error("GRID GET COARSE INDEX: error "//&
+ & "computing upper right corner "//&
+ & "index for longitude")
+ ENDIF
+ ENDIF
+ ENDIF
ENDIF
- IF( ABS(td_lat0%d_value(ji,jj,1,1)-dl_lat1_ur) > dl_dlat*1.e-3 )THEN
- IF( td_lat0%d_value(ji,jj,1,1) < dl_lat1_ur ) il_iur(2)=il_iur(2)+1
+ IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_ur) > dp_delta )THEN
+ IF( tl_lat0%d_value(ji,jj,1,1) < dl_lat1_ur )THEN
+ il_iur(2)=il_iur(2)+1
+ IF( il_iur(2) > tl_lat0%t_dim(jp_J)%i_len )THEN
+ CALL logger_error("GRID GET COARSE INDEX: error "//&
+ & "computing upper right corner "//&
+ & "index for latitude")
+ ENDIF
+ ENDIF
ENDIF
@@ -1144,23 +2758,10 @@
IF( il_imax <= il_ew0 )THEN
- il_imax = td_lon0%t_dim(1)%i_len - il_ew0 + il_imax
+ !il_imin = 1
+ il_imax = tl_lon0%t_dim(1)%i_len - il_ew0 + il_imax
ENDIF
il_jmin = il_jmin0-1+MIN(il_ill(2), il_ilr(2))
il_jmax = il_jmin0-1+MAX(il_iul(2), il_iur(2))
-
- il_offset(:,:)= grid_get_fine_offset( td_lon0%d_value( :,:,1,1 ), &
- & td_lat0%d_value( :,:,1,1 ), &
- & il_imin, il_jmin, &
- & il_imax, il_jmax, &
- & td_lon1%d_value( :,:,1,1 ), &
- & td_lat1%d_value( :,:,1,1 ), &
- & il_rho(:) )
-
- grid_get_coarse_index_cc(1,1,2) = il_offset(1,1)
- grid_get_coarse_index_cc(1,2,2) = il_offset(1,2)
-
- grid_get_coarse_index_cc(2,1,2) = il_offset(2,1)
- grid_get_coarse_index_cc(2,2,2) = il_offset(2,2)
! special case if east west overlap
@@ -1170,25 +2771,25 @@
il_imin = 1
- il_imax = 1
-
- grid_get_coarse_index_cc(1,1,2) = 0
- grid_get_coarse_index_cc(1,2,2) = 0
+ il_imax = tl_lon0%t_dim(1)%i_len
+
ENDIF
-
ENDIF
- IF( il_imin == il_imax ) il_imax=td_lon0%t_dim(1)%i_len
- IF( il_jmin == il_jmax ) il_jmax=td_lon0%t_dim(2)%i_len
-
- grid_get_coarse_index_cc(1,1,1) = il_imin
- grid_get_coarse_index_cc(1,2,1) = il_imax
-
- grid_get_coarse_index_cc(2,1,1) = il_jmin
- grid_get_coarse_index_cc(2,2,1) = il_jmax
+ grid__get_coarse_index_cc(1,1) = il_imin
+ grid__get_coarse_index_cc(1,2) = il_imax
+
+ grid__get_coarse_index_cc(2,1) = il_jmin
+ grid__get_coarse_index_cc(2,2) = il_jmax
- ENDIF
-
- END FUNCTION grid_get_coarse_index_cc
- !> @endcode
+ ! clean
+ CALL var_clean(tl_lon1)
+ CALL var_clean(tl_lat1)
+ CALL var_clean(tl_lon0)
+ CALL var_clean(tl_lat0)
+ ENDIF
+
+ DEALLOCATE( il_rho )
+
+ END FUNCTION grid__get_coarse_index_cc
!-------------------------------------------------------------------
!> @brief This function check if grid is global or not
@@ -1197,10 +2798,9 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_lon : longitude structure
- !> @param[in] td_lat : latitude structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_lon longitude structure
+ !> @param[in] td_lat latitude structure
+ !-------------------------------------------------------------------
FUNCTION grid_is_global(td_lon, td_lat)
IMPLICIT NONE
@@ -1233,5 +2833,5 @@
IF( .NOT. ASSOCIATED(td_lon%d_value) .OR. &
& .NOT. ASSOCIATED(td_lat%d_value) )THEN
- CALL logger_error("GRID IS GLOBAL: na value associated to "//&
+ CALL logger_error("GRID IS GLOBAL: no value associated to "//&
& " longitude or latitude strucutre")
ELSE
@@ -1256,28 +2856,23 @@
END FUNCTION grid_is_global
- !> @endcode
-
!-------------------------------------------------------------------
!> @brief This function return coarse grid indices of the closest point
!> from fine grid point (lon1,lat1)
!>
- !
!> @details
- !
- !> @note overlap band should have been already removed from coarse grid table
+ !>
+ !> @note overlap band should have been already removed from coarse grid array
!> of longitude and latitude, before running this function
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_lon0 : coarse grid table of longitude
- !> @param[in] dd_lat0 : coarse grid table of latitude
- !> @param[in] dd_lon1 : fine grid longitude
- !> @param[in] dd_lat1 : fine grid latitude
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] dd_lon0 coarse grid array of longitude
+ !> @param[in] dd_lat0 coarse grid array of latitude
+ !> @param[in] dd_lon1 fine grid longitude
+ !> @param[in] dd_lat1 fine grid latitude
!> @return coarse grid indices of closest point of fine grid point
!>
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !-------------------------------------------------------------------
FUNCTION grid_get_closest( dd_lon0, dd_lat0, dd_lon1, dd_lat1 )
IMPLICIT NONE
@@ -1326,5 +2921,5 @@
IF( dd_lon1 < 0 ) dl_lon1 = dd_lon1 + 360.
- !1- first, use dichotomy to reduce domain
+ ! first, use dichotomy to reduce domain
il_iinf = 1 ; il_jinf = 1
il_isup = il_shape(1) ; il_jsup = il_shape(2)
@@ -1336,5 +2931,5 @@
ll_continue=.TRUE.
- !1-1 look for meridian 0°/360°
+ ! look for meridian 0°/360°
il_jmid = il_jinf + INT(il_shape(2)/2)
il_ind(:) = MAXLOC( dl_lon0(:,il_jmid), dl_lon0(:,il_jmid) <= 360._dp )
@@ -1378,5 +2973,5 @@
ENDIF
- !1-2
+ !
DO WHILE( ll_continue .AND. .NOT. ll_north )
@@ -1401,5 +2996,4 @@
ENDIF
-
IF( dd_lat1 > dd_lat0(il_imid,il_jmid) )THEN
@@ -1430,5 +3024,5 @@
ENDDO
- !2- then find closest point by computing distances
+ ! then find closest point by computing distances
il_shape(1)= il_isup - il_iinf + 1
il_shape(2)= il_jsup - il_jinf + 1
@@ -1449,20 +3043,18 @@
END FUNCTION grid_get_closest
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function compute the distance between a point A and
- !> points of a grid
+ !-------------------------------------------------------------------
+ !> @brief This function compute the distance between a point A and grid points.
!
!> @details
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_lon : grid longitude table
- !> @param[in] dd_lat : grid latitude table
- !> @param[in] dd_lonA : longitude of point A
- !> @param[in] dd_latA : latitude of point A
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] dd_lon grid longitude array
+ !> @param[in] dd_lat grid latitude array
+ !> @param[in] dd_lonA longitude of point A
+ !> @param[in] dd_latA latitude of point A
+ !> @return array of distance between point A and grid points.
+ !-------------------------------------------------------------------
FUNCTION grid_distance(dd_lon, dd_lat, dd_lonA, dd_latA)
IMPLICIT NONE
@@ -1507,9 +3099,9 @@
IF( dd_lonA < 0 ) dl_lonA = dd_lonA + 360.
- dl_lonA = dd_lonA * dg_deg2rad
- dl_latA = dd_latA * dg_deg2rad
-
- dl_lon(:,:) = dl_lon(:,:) * dg_deg2rad
- dl_lat(:,:) = dd_lat(:,:) * dg_deg2rad
+ dl_lonA = dd_lonA * dp_deg2rad
+ dl_latA = dd_latA * dp_deg2rad
+
+ dl_lon(:,:) = dl_lon(:,:) * dp_deg2rad
+ dl_lat(:,:) = dd_lat(:,:) * dp_deg2rad
grid_distance(:,:)=NF90_FILL_DOUBLE
@@ -1518,5 +3110,5 @@
DO ji=1,il_shape(1)
IF( dl_lon(ji,jj) == dl_lonA .AND. &
- & dl_lat(ji,jj) == dl_lATA )THEN
+ & dl_lat(ji,jj) == dl_laTA )THEN
grid_distance(ji,jj)=0.0
ELSE
@@ -1526,5 +3118,5 @@
IF( dl_tmp < -1.0 ) dl_tmp = -1.0
IF( dl_tmp > 1.0 ) dl_tmp = 1.0
- grid_distance(ji,jj)=ACOS(dl_tmp)*dg_rearth
+ grid_distance(ji,jj)=ACOS(dl_tmp)*dp_rearth
ENDIF
ENDDO
@@ -1535,7 +3127,457 @@
END FUNCTION grid_distance
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function get fine grid offset.
+ !-------------------------------------------------------------------
+ !> @brief This function get offset between fine grid and coarse grid.
+ !
+ !> @details
+ !> optionally, you could specify on which Arakawa grid point you want to
+ !> work (default 'T')
+ !> offset value could be 0,1,..,rho-1
+ !
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !
+ !> @param[in] td_coord0 coarse grid coordinate
+ !> @param[in] id_imin0 coarse grid lower left corner i-indice of fine grid domain
+ !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain
+ !> @param[in] id_imax0 coarse grid upper right corner i-indice of fine grid domain
+ !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain
+ !> @param[in] td_coord1 fine grid coordinate
+ !> @param[in] id_rho array of refinement factor
+ !> @param[in] cd_point Arakawa grid point
+ !> @return offset array (/ (/i_offset_left,i_offset_right/),(/j_offset_lower,j_offset_upper/) /)
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_fine_offset_ff( td_coord0, &
+ & id_imin0, id_jmin0, id_imax0, id_jmax0, &
+ & td_coord1, id_rho, cd_point )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP) , INTENT(IN) :: td_coord0
+ TYPE(TMPP) , INTENT(IN) :: td_coord1
+
+ INTEGER(i4) , INTENT(IN) :: id_imin0
+ INTEGER(i4) , INTENT(IN) :: id_jmin0
+ INTEGER(i4) , INTENT(IN) :: id_imax0
+ INTEGER(i4) , INTENT(IN) :: id_jmax0
+
+ INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_rho
+ CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point
+
+ ! function
+ INTEGER(i4), DIMENSION(2,2) :: grid__get_fine_offset_ff
+
+ ! local variable
+ INTEGER(i4) :: il_imin0
+ INTEGER(i4) :: il_jmin0
+ INTEGER(i4) :: il_imax0
+ INTEGER(i4) :: il_jmax0
+
+ INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho
+
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost0
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost1
+
+ CHARACTER(LEN= 1) :: cl_point
+ CHARACTER(LEN=lc) :: cl_name
+
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat0
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon1
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat1
+
+ TYPE(TVAR) :: tl_lon0
+ TYPE(TVAR) :: tl_lat0
+ TYPE(TVAR) :: tl_lon1
+ TYPE(TVAR) :: tl_lat1
+
+ TYPE(TMPP) :: tl_coord0
+ TYPE(TMPP) :: tl_coord1
+
+ ! loop indices
+ !----------------------------------------------------------------
+ ! init
+ grid__get_fine_offset_ff(:,:)=-1
+
+ ALLOCATE(il_rho(ip_maxdim))
+ il_rho(:)=1
+ IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:)
+
+ cl_point='T'
+ IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point))
+
+ ! copy structure
+ tl_coord0=mpp_copy(td_coord0)
+ tl_coord1=mpp_copy(td_coord1)
+
+ IF( .NOT. ASSOCIATED(tl_coord0%t_proc) .OR. &
+ & .NOT. ASSOCIATED(tl_coord1%t_proc) )THEN
+ CALL logger_error("GRID GET FINE OFFSET: can not get coarse "//&
+ & "grid indices. decompsition of mpp file "//TRIM(tl_coord0%c_name)//&
+ & " and/or "//TRIM(tl_coord1%c_name)//" not defined." )
+ ELSE
+ !1- Coarse grid
+ ! get ghost cell factor on coarse grid
+ il_xghost0(:,:)=grid_get_ghost( tl_coord0 )
+
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord0)
+
+ ! read coarse longitue and latitude
+ WRITE(cl_name,*) 'longitude_'//TRIM(cl_point)
+ tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name))
+ WRITE(cl_name,*) 'latitude_'//TRIM(cl_point)
+ tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name))
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_coord0)
+
+ CALL grid_del_ghost(tl_lon0, il_xghost0(:,:))
+ CALL grid_del_ghost(tl_lat0, il_xghost0(:,:))
+
+ ALLOCATE(dl_lon0(tl_lon0%t_dim(jp_I)%i_len, &
+ & tl_lon0%t_dim(jp_J)%i_len ))
+
+ dl_lon0(:,:)=tl_lon0%d_value(:,:,1,1)
+
+ ALLOCATE(dl_lat0(tl_lat0%t_dim(jp_I)%i_len, &
+ & tl_lat0%t_dim(jp_J)%i_len ))
+
+ dl_lat0(:,:)=tl_lat0%d_value(:,:,1,1)
+
+ ! clean
+ CALL var_clean(tl_lon0)
+ CALL var_clean(tl_lat0)
+
+ ! adjust coarse grid indices
+ il_imin0=id_imin0-il_xghost0(jp_I,1)
+ il_imax0=id_imax0-il_xghost0(jp_I,1)
+
+ il_jmin0=id_jmin0-il_xghost0(jp_J,1)
+ il_jmax0=id_jmax0-il_xghost0(jp_J,1)
+
+ !2- Fine grid
+ ! get ghost cell factor on fine grid
+ il_xghost1(:,:)=grid_get_ghost( tl_coord1 )
+
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord1)
+
+ ! read fine longitue and latitude
+ WRITE(cl_name,*) 'longitude_'//TRIM(cl_point)
+ tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name))
+ WRITE(cl_name,*) 'latitude_'//TRIM(cl_point)
+ tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name))
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_coord1)
+
+ CALL grid_del_ghost(tl_lon1, il_xghost1(:,:))
+ CALL grid_del_ghost(tl_lat1, il_xghost1(:,:))
+
+ ALLOCATE(dl_lon1(tl_lon1%t_dim(jp_I)%i_len, &
+ & tl_lon1%t_dim(jp_J)%i_len ))
+
+ dl_lon1(:,:)=tl_lon1%d_value(:,:,1,1)
+
+ ALLOCATE(dl_lat1(tl_lat1%t_dim(jp_I)%i_len, &
+ & tl_lat1%t_dim(jp_J)%i_len ))
+
+ dl_lat1(:,:)=tl_lat1%d_value(:,:,1,1)
+
+ ! clean
+ CALL var_clean(tl_lon1)
+ CALL var_clean(tl_lat1)
+
+ !3- compute
+ grid__get_fine_offset_ff(:,:)=grid_get_fine_offset( &
+ & dl_lon0(:,:), dl_lat0(:,:),&
+ & il_imin0, il_jmin0, &
+ & il_imax0, il_jmax0, &
+ & dl_lon1(:,:), dl_lat1(:,:),&
+ & id_rho(:) )
+
+ DEALLOCATE(dl_lon0, dl_lat0)
+ DEALLOCATE(dl_lon1, dl_lat1)
+ ENDIF
+
+ ! clean
+ CALL mpp_clean(tl_coord0)
+ CALL mpp_clean(tl_coord1)
+ DEALLOCATE(il_rho)
+
+ END FUNCTION grid__get_fine_offset_ff
+ !-------------------------------------------------------------------
+ !> @brief This function get offset between fine grid and coarse grid.
+ !
+ !> @details
+ !> optionally, you could specify on which Arakawa grid point you want to
+ !> work (default 'T')
+ !> offset value could be 0,1,..,rho-1
+ !
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !
+ !> @param[in] dd_lon0 coarse grid longitude array
+ !> @param[in] dd_lat0 coarse grid latitude array
+ !> @param[in] id_imin0 coarse grid lower left corner i-indice of fine grid domain
+ !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain
+ !> @param[in] id_imax0 coarse grid upper right corner i-indice of fine grid domain
+ !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain
+ !> @param[in] td_coord1 fine grid coordinate
+ !> @param[in] id_rho array of refinement factor
+ !> @param[in] cd_point Arakawa grid point
+ !> @return offset array (/ (/i_offset_left,i_offset_right/),(/j_offset_lower,j_offset_upper/) /)
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_fine_offset_cf( dd_lon0, dd_lat0, &
+ & id_imin0, id_jmin0, id_imax0, id_jmax0, &
+ & td_coord1, id_rho, cd_point )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon0
+ REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat0
+ TYPE(TMPP) , INTENT(IN) :: td_coord1
+
+ INTEGER(i4) , INTENT(IN) :: id_imin0
+ INTEGER(i4) , INTENT(IN) :: id_jmin0
+ INTEGER(i4) , INTENT(IN) :: id_imax0
+ INTEGER(i4) , INTENT(IN) :: id_jmax0
+
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_rho
+ CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point
+
+ ! function
+ INTEGER(i4), DIMENSION(2,2) :: grid__get_fine_offset_cf
+
+ ! local variable
+ INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho
+
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost1
+
+ CHARACTER(LEN= 1) :: cl_point
+ CHARACTER(LEN=lc) :: cl_name
+
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon1
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat1
+
+ TYPE(TVAR) :: tl_lon1
+ TYPE(TVAR) :: tl_lat1
+
+ TYPE(TMPP) :: tl_coord1
+ ! loop indices
+ !----------------------------------------------------------------
+ ! init
+ grid__get_fine_offset_cf(:,:)=-1
+
+ ALLOCATE(il_rho(ip_maxdim))
+ il_rho(:)=1
+ IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:)
+
+ cl_point='T'
+ IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point))
+
+ ! copy structure
+ tl_coord1=mpp_copy(td_coord1)
+
+ IF( .NOT. ASSOCIATED(tl_coord1%t_proc) )THEN
+ CALL logger_error("GRID GET FINE OFFSET: decompsition of mpp "//&
+ & "file "//TRIM(tl_coord1%c_name)//" not defined." )
+ ELSE
+
+ ! Fine grid
+ ! get ghost cell factor on fine grid
+ il_xghost1(:,:)=grid_get_ghost( tl_coord1 )
+
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord1)
+
+ ! read fine longitue and latitude
+ WRITE(cl_name,*) 'longitude_'//TRIM(cl_point)
+ tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name))
+ WRITE(cl_name,*) 'latitude_'//TRIM(cl_point)
+ tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name))
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_coord1)
+
+ CALL grid_del_ghost(tl_lon1, il_xghost1(:,:))
+ CALL grid_del_ghost(tl_lat1, il_xghost1(:,:))
+
+ ALLOCATE(dl_lon1(tl_lon1%t_dim(jp_I)%i_len, &
+ & tl_lon1%t_dim(jp_J)%i_len ))
+
+ dl_lon1(:,:)=tl_lon1%d_value(:,:,1,1)
+
+ ALLOCATE(dl_lat1(tl_lat1%t_dim(jp_I)%i_len, &
+ & tl_lat1%t_dim(jp_J)%i_len ))
+
+ dl_lat1(:,:)=tl_lat1%d_value(:,:,1,1)
+
+ ! clean
+ CALL var_clean(tl_lon1)
+ CALL var_clean(tl_lat1)
+
+ ! compute
+ grid__get_fine_offset_cf(:,:)=grid_get_fine_offset( &
+ & dd_lon0(:,:), dd_lat0(:,:),&
+ & id_imin0, id_jmin0, &
+ & id_imax0, id_jmax0, &
+ & dl_lon1(:,:), dl_lat1(:,:),&
+ & id_rho(:) )
+
+ DEALLOCATE(dl_lon1, dl_lat1)
+ ENDIF
+
+ ! clean
+ CALL mpp_clean(tl_coord1)
+ DEALLOCATE(il_rho)
+
+ END FUNCTION grid__get_fine_offset_cf
+ !-------------------------------------------------------------------
+ !> @brief This function get offset between fine grid and coarse grid.
+ !
+ !> @details
+ !> optionally, you could specify on which Arakawa grid point you want to
+ !> work (default 'T')
+ !> offset value could be 0,1,..,rho-1
+ !
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !
+ !> @param[in] td_coord0 coarse grid coordinate
+ !> @param[in] id_imin0 coarse grid lower left corner i-indice of fine grid domain
+ !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain
+ !> @param[in] id_imax0 coarse grid upper right corner i-indice of fine grid domain
+ !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain
+ !> @param[in] dd_lon1 fine grid longitude array
+ !> @param[in] dd_lat1 fine grid latitude array
+ !> @param[in] id_rho array of refinement factor
+ !> @param[in] cd_point Arakawa grid point
+ !> @return offset array (/ (/i_offset_left,i_offset_right/),(/j_offset_lower,j_offset_upper/) /)
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_fine_offset_fc( td_coord0, &
+ & id_imin0, id_jmin0, id_imax0, id_jmax0, &
+ & dd_lon1, dd_lat1, &
+ & id_rho, cd_point )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP) , INTENT(IN) :: td_coord0
+ REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon1
+ REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat1
+
+ INTEGER(i4) , INTENT(IN) :: id_imin0
+ INTEGER(i4) , INTENT(IN) :: id_jmin0
+ INTEGER(i4) , INTENT(IN) :: id_imax0
+ INTEGER(i4) , INTENT(IN) :: id_jmax0
+
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_rho
+ CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point
+
+ ! function
+ INTEGER(i4), DIMENSION(2,2) :: grid__get_fine_offset_fc
+
+ ! local variable
+ INTEGER(i4) :: il_imin0
+ INTEGER(i4) :: il_jmin0
+ INTEGER(i4) :: il_imax0
+ INTEGER(i4) :: il_jmax0
+
+ INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho
+
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost0
+
+ CHARACTER(LEN= 1) :: cl_point
+ CHARACTER(LEN=lc) :: cl_name
+
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lat0
+
+ TYPE(TVAR) :: tl_lon0
+ TYPE(TVAR) :: tl_lat0
+
+ TYPE(TMPP) :: tl_coord0
+ ! loop indices
+ !----------------------------------------------------------------
+ ! init
+ grid__get_fine_offset_fc(:,:)=-1
+
+ ALLOCATE(il_rho(ip_maxdim))
+ il_rho(:)=1
+ IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:)
+
+ cl_point='T'
+ IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point))
+
+ ! copy structure
+ tl_coord0=mpp_copy(td_coord0)
+
+ IF( .NOT. ASSOCIATED(tl_coord0%t_proc) )THEN
+ CALL logger_error("GRID GET FINE OFFSET: decompsition of mpp "//&
+ & "file "//TRIM(tl_coord0%c_name)//" not defined." )
+ ELSE
+ !1- Coarse grid
+ ! get ghost cell factor on coarse grid
+ il_xghost0(:,:)=grid_get_ghost( tl_coord0 )
+
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord0)
+
+ ! read coarse longitue and latitude
+ WRITE(cl_name,*) 'longitude_'//TRIM(cl_point)
+ tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name))
+ WRITE(cl_name,*) 'latitude_'//TRIM(cl_point)
+ tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name))
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_coord0)
+
+ CALL grid_del_ghost(tl_lon0, il_xghost0(:,:))
+ CALL grid_del_ghost(tl_lat0, il_xghost0(:,:))
+
+ ALLOCATE(dl_lon0(tl_lon0%t_dim(jp_I)%i_len, &
+ & tl_lon0%t_dim(jp_J)%i_len ))
+
+ dl_lon0(:,:)=tl_lon0%d_value(:,:,1,1)
+
+ ALLOCATE(dl_lat0(tl_lat0%t_dim(jp_I)%i_len, &
+ & tl_lat0%t_dim(jp_J)%i_len ))
+
+ dl_lat0(:,:)=tl_lat0%d_value(:,:,1,1)
+
+ ! clean
+ CALL var_clean(tl_lon0)
+ CALL var_clean(tl_lat0)
+
+ ! adjust coarse grid indices
+ il_imin0=id_imin0-il_xghost0(jp_I,1)
+ il_imax0=id_imax0-il_xghost0(jp_I,1)
+
+ il_jmin0=id_jmin0-il_xghost0(jp_J,1)
+ il_jmax0=id_jmax0-il_xghost0(jp_J,1)
+
+
+ !3- compute
+ grid__get_fine_offset_fc(:,:)=grid_get_fine_offset(&
+ & dl_lon0(:,:), dl_lat0(:,:),&
+ & il_imin0, il_jmin0, &
+ & il_imax0, il_jmax0, &
+ & dd_lon1(:,:), dd_lat1(:,:),&
+ & id_rho(:) )
+
+ DEALLOCATE(dl_lon0, dl_lat0)
+ ENDIF
+
+ ! clean
+ CALL mpp_clean(tl_coord0)
+ DEALLOCATE(il_rho)
+
+ END FUNCTION grid__get_fine_offset_fc
+ !-------------------------------------------------------------------
+ !> @brief This function get offset between fine grid and coarse grid.
!
!> @details
@@ -1543,22 +3585,21 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_lon0 : coarse grid longitude table
- !> @param[in] dd_lat0 : coarse grid latitude table
- !> @param[in] dd_lon1 : fine grid longitude table
- !> @param[in] dd_lat1 : fine grid latitude table
- !> @param[in] id_imin0 : coarse grid lower left corner i-indice of fine grid domain
- !> @param[in] id_jmin0 : coarse grid lower left corner j-indice of fine grid domain
- !> @param[in] id_imax0 : coarse grid upper right corner i-indice of fine grid domain
- !> @param[in] id_jmax0 : coarse grid upper right corner j-indice of fine grid domain
- !> @param[in] id_rhoi : i-direction refinement factor
- !> @param[in] id_rhoj : j-direction refinement factor
- !> @return offset table (/ (/i_offset_left,i_offset_right!/),(/j_offset_lower,j_offset_upper/) /)
- !-------------------------------------------------------------------
- !> @code
- FUNCTION grid_get_fine_offset( dd_lon0, dd_lat0, &
- & id_imin0, id_jmin0, id_imax0, id_jmax0, &
- & dd_lon1, dd_lat1, id_rho )
+ !> - November, 2013 - Initial Version
+ !> @date September, 2014 - rename from grid_get_fine_offset
+ !
+ !> @param[in] dd_lon0 coarse grid longitude array
+ !> @param[in] dd_lat0 coarse grid latitude array
+ !> @param[in] id_imin0 coarse grid lower left corner i-indice of fine grid domain
+ !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain
+ !> @param[in] id_imax0 coarse grid upper right corner i-indice of fine grid domain
+ !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain
+ !> @param[in] dd_lon1 fine grid longitude array
+ !> @param[in] dd_lat1 fine grid latitude array
+ !> @param[in] id_rho array of refinement factor
+ !> @return offset array (/ (/i_offset_left,i_offset_right/),(/j_offset_lower,j_offset_upper/) /)
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_fine_offset_cc( dd_lon0, dd_lat0, &
+ & id_imin0, id_jmin0, id_imax0, id_jmax0, &
+ & dd_lon1, dd_lat1, id_rho )
IMPLICIT NONE
! Argument
@@ -1576,5 +3617,5 @@
! function
- INTEGER(i4), DIMENSION(2,2) :: grid_get_fine_offset
+ INTEGER(i4), DIMENSION(2,2) :: grid__get_fine_offset_cc
! local variable
@@ -1584,7 +3625,4 @@
REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon1
- REAL(dp) :: dl_dlon
- REAL(dp) :: dl_dlat
-
! loop indices
INTEGER(i4) :: ji
@@ -1616,62 +3654,70 @@
WHERE( dd_lon1(:,:) < 0 ) dl_lon1(:,:)=dd_lon1(:,:)+360.
- grid_get_fine_offset(:,:)=-1
-
- ! look for i-direction left offset
- IF( dl_lon1(1,1) < dl_lon0(id_imin0+1,id_jmin0) )THEN
- DO ji=1,id_rho(jp_I)+2
- dl_dlon=ABS(dl_lon1(ji+1,1)-dl_lon1(ji,1))*1.e-3
- IF( dl_lon1(ji,1) > dl_lon0(id_imin0+1,id_jmin0) + dl_dlon )THEN
- grid_get_fine_offset(1,1)=(id_rho(jp_I)+1)-ji+MOD(id_rho(jp_I),2)
- EXIT
- ENDIF
- ENDDO
+ ! init
+ grid__get_fine_offset_cc(:,:)=-1
+
+ IF( il_shape1(1) > 1 )THEN
+
+ ! look for i-direction left offset
+ IF( dl_lon1(1,1) < dl_lon0(id_imin0+1,id_jmin0) )THEN
+ DO ji=1,id_rho(jp_I)+2
+ IF( dl_lon1(ji,1) > dl_lon0(id_imin0+1,id_jmin0) - dp_delta )THEN
+ grid__get_fine_offset_cc(1,1)=(id_rho(jp_I)+1)-ji
+ EXIT
+ ENDIF
+ ENDDO
+ ELSE
+ CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//&
+ & " not match fine grid lower left corner.")
+ ENDIF
+
+ ! look for i-direction right offset
+ IF( dl_lon1(il_shape1(1),1) > dl_lon0(id_imax0-1,id_jmin0) )THEN
+ DO ji=1,id_rho(jp_I)+2
+ ii=il_shape1(1)-ji+1
+ IF( dl_lon1(ii,1) < dl_lon0(id_imax0-1,id_jmin0) + dp_delta )THEN
+ grid__get_fine_offset_cc(1,2)=(id_rho(jp_I)+1)-ji
+ EXIT
+ ENDIF
+ ENDDO
+ ELSE
+ CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//&
+ & " not match fine grid lower right corner.")
+ ENDIF
+
ELSE
- CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//&
- & " not match fine grid lower left corner.")
- ENDIF
-
- ! look for i-direction right offset
- IF( dl_lon1(il_shape1(1),1) > dl_lon0(id_imax0-1,id_jmin0) )THEN
- DO ji=1,id_rho(jp_I)+2
- ii=il_shape1(1)-ji+1
- dl_dlon=ABS(dl_lon1(ii,1)-dl_lon1(ii-1,1))*1.e-3
- IF( dl_lon1(ii,1) < dl_lon0(id_imax0-1,id_jmin0) - dl_dlon )THEN
- grid_get_fine_offset(1,2)=(id_rho(jp_I)+1)-ji+MOD(id_rho(jp_I),2)
- EXIT
- ENDIF
- ENDDO
+ grid__get_fine_offset_cc(1,:)=((id_rho(jp_I)-1)/2)
+ ENDIF
+
+ IF( il_shape1(2) > 1 )THEN
+
+ ! look for j-direction lower offset
+ IF( dd_lat1(1,1) < dd_lat0(id_imin0,id_jmin0+1) )THEN
+ DO jj=1,id_rho(jp_J)+2
+ IF( dd_lat1(1,jj) > dd_lat0(id_imin0,id_jmin0+1) - dp_delta )THEN
+ grid__get_fine_offset_cc(2,1)=(id_rho(jp_J)+1)-jj
+ EXIT
+ ENDIF
+ ENDDO
+ ELSE
+ CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//&
+ & " not match fine grid upper left corner.")
+ ENDIF
+
+ ! look for j-direction upper offset
+ IF( dd_lat1(1,il_shape1(2)) > dd_lat0(id_imin0,id_jmax0-1) )THEN
+ DO jj=1,id_rho(jp_J)+2
+ ij=il_shape1(2)-jj+1
+ IF( dd_lat1(1,ij) < dd_lat0(id_imin0,id_jmax0-1) + dp_delta )THEN
+ grid__get_fine_offset_cc(2,2)=(id_rho(jp_J)+1)-jj
+ EXIT
+ ENDIF
+ ENDDO
+ ELSE
+ CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//&
+ & " not match fine grid upper right corner.")
+ ENDIF
ELSE
- CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//&
- & " not match fine grid lower right corner.")
- ENDIF
-
- ! look for j-direction lower offset
- IF( dd_lat1(1,1) < dd_lat0(id_imin0,id_jmin0+1) )THEN
- DO jj=1,id_rho(jp_J)+2
- dl_dlat=ABS(dd_lat1(1,jj+1)-dd_lat1(1,jj))*1.e-3
- IF( dd_lat1(1,jj) > dd_lat0(id_imin0,id_jmin0+1) + dl_dlat )THEN
- grid_get_fine_offset(2,1)=(id_rho(jp_J)+1)-jj+MOD(id_rho(jp_J),2)
- EXIT
- ENDIF
- ENDDO
- ELSE
- CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//&
- & " not match fine grid upper left corner.")
- ENDIF
-
- ! look for j-direction upper offset
- IF( dd_lat1(1,il_shape1(2)) > dd_lat0(id_imin0,id_jmax0-1) )THEN
- DO jj=1,id_rho(jp_J)+2
- ij=il_shape1(2)-jj+1
- dl_dlat=ABS(dd_lat1(1,ij)-dd_lat1(1,ij-1))*1.e-3
- IF( dd_lat1(1,ij) < dd_lat0(id_imin0,id_jmax0-1) - dl_dlat )THEN
- grid_get_fine_offset(2,2)=(id_rho(jp_J)+1)-jj+MOD(id_rho(jp_J),2)
- EXIT
- ENDIF
- ENDDO
- ELSE
- CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//&
- & " not match fine grid upper right corner.")
+ grid__get_fine_offset_cc(2,:)=((id_rho(jp_J)-1)/2)
ENDIF
@@ -1679,137 +3725,23 @@
DEALLOCATE( dl_lon1 )
- END FUNCTION grid_get_fine_offset
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function check if ghost cell are used or not, and return ghost
- !> cell factor (0,1) in i- and j-direction.
+ END FUNCTION grid__get_fine_offset_cc
+ !-------------------------------------------------------------------
+ !> @brief This subroutine check fine and coarse grid coincidence.
!
!> @details
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_lon : grid longitude sturcture
- !> @param[in] td_lat : grid latitude structure
- !-------------------------------------------------------------------
- !> @code
- FUNCTION grid__get_ghost_ll( td_lon, td_lat )
- IMPLICIT NONE
- ! Argument
- TYPE(TVAR), INTENT(IN) :: td_lon
- TYPE(TVAR), INTENT(IN) :: td_lat
-
- ! function
- INTEGER(i4), DIMENSION(2) :: grid__get_ghost_ll
-
- ! local variable
- INTEGER(i4) :: il_ew
- ! loop indices
- !----------------------------------------------------------------
- ! init
- grid__get_ghost_ll(:)=0
-
- IF( grid_is_global(td_lon, td_lat) )THEN
- grid__get_ghost_ll(:)=0
- ELSE
- grid__get_ghost_ll(2)=1
-
- il_ew=td_lon%i_ew
- IF( il_ew < 0 )THEN
- grid__get_ghost_ll(1)=1
- ELSE
- grid__get_ghost_ll(1)=0
- ENDIF
- ENDIF
-
- END FUNCTION grid__get_ghost_ll
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function check if ghost cell are used or not, and return ghost
- !> cell factor (0,1) in i- and j-direction.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file sturcture
- !-------------------------------------------------------------------
- !> @code
- FUNCTION grid__get_ghost_f( td_file )
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(IN) :: td_file
-
- ! function
- INTEGER(i4), DIMENSION(2) :: grid__get_ghost_f
-
- ! local variable
- TYPE(TVAR) :: tl_lon
- TYPE(TVAR) :: tl_lat
-
- INTEGER(i4) :: il_lonid
- INTEGER(i4) :: il_latid
- ! loop indices
- INTEGER(i4) :: ji
- !----------------------------------------------------------------
- ! init
- grid__get_ghost_f(:)=0
-
- IF( td_file%i_id == 0 )THEN
- CALL logger_error("GRID GET GHOST: file "//&
- & TRIM(td_file%c_name)//" not opened." )
-
- ELSE
-
- IF( ASSOCIATED(td_file%t_var) )THEN
- ! read coarse longitue and latitude
- il_lonid=var_get_id(td_file%t_var(:),'longitude')
- il_latid=var_get_id(td_file%t_var(:),'latitude')
-
- print *,'file ',trim(td_file%c_name),td_file%i_ew
- DO ji=1,td_file%i_nvar
- print *,ji,trim(td_file%t_var(ji)%c_name),': ',td_file%t_var(ji)%i_ew
- ENDDO
- print *,'lonid ',il_lonid
- print *,'latid ',il_latid
- IF( il_lonid /=0 .AND. il_latid /= 0 )THEN
- tl_lon=iom_read_var(td_file,il_lonid)
- print *,'lon ',tl_lon%i_ew
- tl_lat=iom_read_var(td_file,il_latid)
- print *,'lat ',tl_lat%i_ew
- ! get ghost cell factor on coarse grid
- grid__get_ghost_f(:)=grid_get_ghost( tl_lon, tl_lat )
- ELSE
- CALL logger_error("GRID GET GHOST: can not find "//&
- & "longitude or latitude "//&
- & "in file "//TRIM(td_file%c_name))
- ENDIF
- ELSE
- CALL logger_error("GRID GET GHOST: no variable "//&
- & "associated to file "//TRIM(td_file%c_name))
- ENDIF
-
- ENDIF
-
- END FUNCTION grid__get_ghost_f
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine check fine and coarse grid coincidence
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_coord0 : coarse grid coordinate file structure
- !> @param[in] td_coord1 : fine grid coordinate file structure
- !> @param[in] id_imin0 : coarse grid lower left corner i-indice of fine grid domain
- !> @param[in] id_imax0 : coarse grid upper right corner i-indice of fine grid domain
- !> @param[in] id_jmin0 : coarse grid lower left corner j-indice of fine grid domain
- !> @param[in] id_jmax0 : coarse grid upper right corner j-indice of fine grid domain
- !> @param[in] id_rho : table of refinement factor
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !
+ !> @param[in] td_coord0 coarse grid coordinate file structure
+ !> @param[in] td_coord1 fine grid coordinate file structure
+ !> @param[in] id_imin0 coarse grid lower left corner i-indice of fine grid domain
+ !> @param[in] id_imax0 coarse grid upper right corner i-indice of fine grid domain
+ !> @param[in] id_jmin0 coarse grid lower left corner j-indice of fine grid domain
+ !> @param[in] id_jmax0 coarse grid upper right corner j-indice of fine grid domain
+ !> @param[in] id_rho array of refinement factor (default 1)
+ !-------------------------------------------------------------------
SUBROUTINE grid_check_coincidence( td_coord0, td_coord1, &
& id_imin0, id_imax0, &
@@ -1819,10 +3751,10 @@
! Argument
- TYPE(TFILE), INTENT(IN) :: td_coord0
- TYPE(TFILE), INTENT(IN) :: td_coord1
- INTEGER(i4), INTENT(IN) :: id_imin0
- INTEGER(i4), INTENT(IN) :: id_imax0
- INTEGER(i4), INTENT(IN) :: id_jmin0
- INTEGER(i4), INTENT(IN) :: id_jmax0
+ TYPE(TMPP) , INTENT(IN) :: td_coord0
+ TYPE(TMPP) , INTENT(IN) :: td_coord1
+ INTEGER(i4) , INTENT(IN) :: id_imin0
+ INTEGER(i4) , INTENT(IN) :: id_imax0
+ INTEGER(i4) , INTENT(IN) :: id_jmin0
+ INTEGER(i4) , INTENT(IN) :: id_jmax0
INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_rho
@@ -1852,7 +3784,4 @@
REAL(dp) :: dl_lat1p
- REAL(dp) :: dl_dlon
- REAL(dp) :: dl_dlat
-
LOGICAL :: ll_coincidence
@@ -1862,7 +3791,6 @@
TYPE(TVAR) :: tl_lat1
- TYPE(TFILE) :: tl_coord0
-
- TYPE(TMPP) :: tl_mppcoord0
+ TYPE(TMPP) :: tl_coord0
+ TYPE(TMPP) :: tl_coord1
TYPE(TDOM) :: tl_dom0
@@ -1875,42 +3803,41 @@
ll_coincidence=.TRUE.
- ! read coarse longitue and latitude on domain
- tl_coord0=td_coord0
- CALL iom_open(tl_coord0)
-
- !2-1 compute domain
+ ! copy structure
+ tl_coord0=mpp_copy(td_coord0)
+
+ ! compute domain
tl_dom0=dom_init( tl_coord0, &
& id_imin0, id_imax0,&
& id_jmin0, id_jmax0 )
- !2-2 close file
- CALL iom_close(tl_coord0)
-
- !2-3 read variables on domain (ugly way to do it, have to work on it)
- !2-3-1 init mpp structure
- tl_mppcoord0=mpp_init(tl_coord0)
-
- CALL file_clean(tl_coord0)
-
- !2-3-2 get processor to be used
- CALL mpp_get_use( tl_mppcoord0, tl_dom0 )
-
- !2-3-3 open mpp files
- CALL iom_mpp_open(tl_mppcoord0)
-
- !2-3-4 read variable value on domain
- tl_lon0=iom_mpp_read_var(tl_mppcoord0,'longitude',td_dom=tl_dom0)
- tl_lat0=iom_mpp_read_var(tl_mppcoord0,'latitude' ,td_dom=tl_dom0)
-
- !2-3-5 close mpp files
- CALL iom_mpp_close(tl_mppcoord0)
-
- !2-3-6 clean structure
- CALL mpp_clean(tl_mppcoord0)
+ ! open mpp files
+ CALL iom_dom_open(tl_coord0, tl_dom0)
+
+ ! read variable value on domain
+ tl_lon0=iom_dom_read_var(tl_coord0,'longitude',tl_dom0)
+ tl_lat0=iom_dom_read_var(tl_coord0,'latitude' ,tl_dom0)
+
+ ! close mpp files
+ CALL iom_dom_close(tl_coord0)
+
+ ! clean structure
+ CALL mpp_clean(tl_coord0)
+ CALL dom_clean(tl_dom0)
+
+ ! copy structure
+ tl_coord1=mpp_copy(td_coord1)
+
+ ! open mpp files
+ CALL iom_mpp_open(tl_coord1)
! read fine longitue and latitude
- tl_lon1=iom_read_var(td_coord1,'longitude')
- tl_lat1=iom_read_var(td_coord1,'latitude')
+ tl_lon1=iom_mpp_read_var(tl_coord1,'longitude')
+ tl_lat1=iom_mpp_read_var(tl_coord1,'latitude')
+ ! close mpp files
+ CALL iom_dom_close(tl_coord1)
+ ! clean structure
+ CALL mpp_clean(tl_coord1)
+
CALL logger_debug("GRID CHECK COINCIDENCE:"//&
& " fine grid "//TRIM(td_coord1%c_name) )
@@ -1918,6 +3845,6 @@
& " coarse grid "//TRIM(td_coord0%c_name) )
- !1- check domain
- !1-1 check global grid
+ ! check domain
+ ! check global grid
IF( .NOT. grid_is_global(tl_lon0, tl_lat0) )THEN
IF( grid_is_global(tl_lon1, tl_lat1) )THEN
@@ -1929,7 +3856,7 @@
ELSE
- !1-2 ew overlap
il_ew1=tl_lon1%i_ew
IF( il_ew1 >= 0 )THEN
+ ! ew overlap
il_ew0=tl_lon0%i_ew
@@ -1940,19 +3867,18 @@
ENDIF
- il_jmin1=1+ig_ghost
- il_jmax1=tl_lon1%t_dim(2)%i_len-ig_ghost
+ il_jmin1=1+ip_ghost
+ il_jmax1=tl_lon1%t_dim(2)%i_len-ip_ghost
ll_coincidence=grid__check_lat(&
& tl_lat0%d_value(1,:,1,1),&
- & tl_lat1%d_value(1,il_jmin1:il_jmax1,1,1),&
- & id_rho(jp_J) )
+ & tl_lat1%d_value(1,il_jmin1:il_jmax1,1,1))
ELSE
- !1-3 other case
- il_imin1=1+ig_ghost
- il_jmin1=1+ig_ghost
-
- il_imax1=tl_lon1%t_dim(1)%i_len-ig_ghost
- il_jmax1=tl_lon1%t_dim(2)%i_len-ig_ghost
+ ! other case
+ il_imin1=1+ip_ghost
+ il_jmin1=1+ip_ghost
+
+ il_imax1=tl_lon1%t_dim(1)%i_len-ip_ghost
+ il_jmax1=tl_lon1%t_dim(2)%i_len-ip_ghost
ll_coincidence=grid__check_corner(&
@@ -1967,5 +3893,5 @@
ENDIF
-
+
ENDIF
@@ -1977,9 +3903,9 @@
ENDIF
- !2- check refinement factor
+ ! check refinement factor
! select point in middle of fine grid
il_imid1=INT(tl_lon1%t_dim(1)%i_len*0.5)
il_jmid1=INT(tl_lon1%t_dim(2)%i_len*0.5)
-
+
dl_lon1=tl_lon1%d_value(il_imid1, il_jmid1,1,1)
dl_lat1=tl_lat1%d_value(il_imid1, il_jmid1,1,1)
@@ -2000,5 +3926,5 @@
! look for closest fine grid point from selected coarse grid point
il_iind(:)=MAXLOC( tl_lon1%d_value(:,:,1,1), &
- & tl_lon1%d_value(:,:,1,1) <= dl_lon0)
+ & tl_lon1%d_value(:,:,1,1) <= dl_lon0 )
il_jind(:)=MAXLOC( tl_lat1%d_value(:,:,1,1), &
@@ -2016,12 +3942,8 @@
dl_lat1=tl_lat1%d_value(il_indF(1),il_indF(2),1,1)
- !2-1 check i-direction refinement factor
+ ! check i-direction refinement factor
DO ji=1,MIN(3,il_imid1)
IF( il_indF(1)+ji*id_rho(jp_I)+1 > tl_lon1%t_dim(1)%i_len )THEN
- CALL logger_debug("GRID CHECK COINCIDENCE: tl_lon1%t_dim(1)%i_len "//TRIM(fct_str(tl_lon1%t_dim(1)%i_len)))
- CALL logger_debug("GRID CHECK COINCIDENCE: il_indF(1)+ji*id_rhoi+1 "//TRIM(fct_str(il_indF(1)+ji*id_rho(jp_I)+1)))
- CALL logger_debug("GRID CHECK COINCIDENCE: il_indF(1) "//TRIM(fct_str(il_indF(1))))
- CALL logger_debug("GRID CHECK COINCIDENCE: id_rhoi "//TRIM(fct_str(id_rho(jp_I))))
CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//&
& " to check i-direction refinement factor ")
@@ -2032,6 +3954,4 @@
dl_lon1p=tl_lon1%d_value(il_indF(1)+ji*id_rho(jp_I)+1,il_indF(2),1,1)
-
- dl_dlon=ABS(dl_lon1p-dl_lon1)*1.e-3
SELECT CASE(MOD(id_rho(jp_I),2))
@@ -2049,5 +3969,5 @@
CASE DEFAULT
- IF( ABS(dl_lon1 - dl_lon0) > dl_dlon )THEN
+ IF( ABS(dl_lon1 - dl_lon0) > dp_delta )THEN
ll_coincidence=.FALSE.
CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//&
@@ -2062,5 +3982,5 @@
ENDDO
- !2-2 check j-direction refinement factor
+ ! check j-direction refinement factor
DO jj=1,MIN(3,il_jmid1)
@@ -2074,6 +3994,4 @@
dl_lat1p=tl_lat1%d_value(il_indF(1),il_indF(2)+jj*id_rho(jp_J)+1,1,1)
-
- dl_dlat=ABS(dl_lat1p-dl_lat1)*1.e-3
SELECT CASE(MOD(id_rho(jp_J),2))
@@ -2091,5 +4009,5 @@
CASE DEFAULT
- IF( ABS(dl_lat1-dl_lat0) > dl_dlat )THEN
+ IF( ABS(dl_lat1-dl_lat0) > dp_delta )THEN
ll_coincidence=.FALSE.
CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//&
@@ -2104,4 +4022,10 @@
ENDDO
+ ! clean
+ CALL var_clean(tl_lon1)
+ CALL var_clean(tl_lat1)
+ CALL var_clean(tl_lon0)
+ CALL var_clean(tl_lat0)
+
IF( .NOT. ll_coincidence )THEN
CALL logger_fatal("GRID CHECK COINCIDENCE: no coincidence "//&
@@ -2111,5 +4035,4 @@
END SUBROUTINE grid_check_coincidence
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function check that fine grid is
@@ -2118,17 +4041,13 @@
!> @details
!>
- !> @note deltalon and delatlat are used only to avoid issue due to
- !> cubic interpolation approximation on the firsts grid points
- !
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_lon0 : table of coarse grid longitude
- !> @param[in] dd_lat0 : table of coarse grid latitude
- !> @param[in] dd_lon1 : table of fine grid longitude
- !> @param[in] dd_lat1 : table of fine grid latitude
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] dd_lon0 array of coarse grid longitude
+ !> @param[in] dd_lat0 array of coarse grid latitude
+ !> @param[in] dd_lon1 array of fine grid longitude
+ !> @param[in] dd_lat1 array of fine grid latitude
!> @return logical, fine grid is inside coarse grid
!-------------------------------------------------------------------
- !> @code
FUNCTION grid__check_corner(dd_lon0, dd_lat0, &
& dd_lon1, dd_lat1 )
@@ -2162,7 +4081,4 @@
REAL(dp) :: dl_lon1
REAL(dp) :: dl_lat1
-
- REAL(dp) :: dl_dlon
- REAL(dp) :: dl_dlat
! loop indices
!----------------------------------------------------------------
@@ -2182,15 +4098,13 @@
! check lower left corner
- dl_lon0 = dd_lon0(il_imin0, il_jmin0 )
- dl_lat0 = dd_lat0(il_imin0, il_jmin0 )
+ dl_lon0 = dd_lon0(il_imin0, il_jmin0)
+ dl_lat0 = dd_lat0(il_imin0, il_jmin0)
dl_lon1 = dd_lon1(il_imin1, il_jmin1)
dl_lat1 = dd_lat1(il_imin1, il_jmin1)
- dl_dlon=ABS(dd_lon1(il_imin1+1,il_jmin1 )-dl_lon1)*1.e-3
- dl_dlat=ABS(dd_lat1(il_imin1 ,il_jmin1+1)-dl_lat1)*1.e-3
-
- IF( (ABS(dl_lon1-dl_lon0)>dl_dlon) .AND. (dl_lon1 < dl_lon0 ) .OR. &
- & (ABS(dl_lat1-dl_lat0)>dl_dlat) .AND. (dl_lat1 < dl_lat0 ) )THEN
+
+ IF( (ABS(dl_lon1-dl_lon0)>dp_delta) .AND. (dl_lon1 < dl_lon0 ) .OR. &
+ & (ABS(dl_lat1-dl_lat0)>dp_delta) .AND. (dl_lat1 < dl_lat0 ) )THEN
CALL logger_error("GRID CHECK COINCIDENCE: fine grid lower left "//&
@@ -2207,15 +4121,13 @@
! check upper left corner
- dl_lon0 = dd_lon0(il_imin0, il_jmax0 )
- dl_lat0 = dd_lat0(il_imin0, il_jmax0 )
+ dl_lon0 = dd_lon0(il_imin0, il_jmax0)
+ dl_lat0 = dd_lat0(il_imin0, il_jmax0)
dl_lon1 = dd_lon1(il_imin1, il_jmax1)
dl_lat1 = dd_lat1(il_imin1, il_jmax1)
- dl_dlon=ABS(dd_lon1(il_imin1+1,il_jmax1 )-dl_lon1)*1.e-3
- dl_dlat=ABS(dd_lat1(il_imin1 ,il_jmax1-1)-dl_lat1)*1.e-3
-
- IF( (ABS(dl_lon1-dl_lon0)>dl_dlon) .AND. (dl_lon1 < dl_lon0) .OR. &
- & (ABS(dl_lat1-dl_lat0)>dl_dlat) .AND. (dl_lat1 > dl_lat0) )THEN
+
+ IF( (ABS(dl_lon1-dl_lon0)>dp_delta) .AND. (dl_lon1 < dl_lon0) .OR. &
+ & (ABS(dl_lat1-dl_lat0)>dp_delta) .AND. (dl_lat1 > dl_lat0) )THEN
CALL logger_error("GRID CHECK COINCIDENCE: fine grid upper left "//&
@@ -2232,18 +4144,16 @@
! check lower right corner
- dl_lon0 = dd_lon0(il_imax0, il_jmin0 )
- dl_lat0 = dd_lat0(il_imax0, il_jmin0 )
+ dl_lon0 = dd_lon0(il_imax0, il_jmin0)
+ dl_lat0 = dd_lat0(il_imax0, il_jmin0)
dl_lon1 = dd_lon1(il_imax1, il_jmin1)
dl_lat1 = dd_lat1(il_imax1, il_jmin1)
- dl_dlon=ABS(dd_lon1(il_imax1-1,il_jmin1 )-dl_lon1)*1.e-3
- dl_dlat=ABS(dd_lat1(il_imax1 ,il_jmin1+1)-dl_lat1)*1.e-3
-
- IF( (ABS(dl_lon1-dl_lon0)>dl_dlon) .AND. (dl_lon1 > dl_lon0) .OR. &
- & (ABS(dl_lat1-dl_lat0)>dl_dlat) .AND. (dl_lat1 < dl_lat0) )THEN
+
+ IF( (ABS(dl_lon1-dl_lon0)>dp_delta) .AND. (dl_lon1 > dl_lon0) .OR. &
+ & (ABS(dl_lat1-dl_lat0)>dp_delta) .AND. (dl_lat1 < dl_lat0) )THEN
CALL logger_error("GRID CHECK COINCIDENCE: fine grid lower right "//&
- & "corner not north west west of coarse grid (imax,jmin) ")
+ & "corner not north west of coarse grid (imax,jmin) ")
CALL logger_debug(" fine grid lower right ( "//&
& TRIM(fct_str(dl_lon1))//","//&
@@ -2257,15 +4167,12 @@
! check upper right corner
- dl_lon0 = dd_lon0(il_imax0, il_jmax0 )
- dl_lat0 = dd_lat0(il_imax0, il_jmax0 )
+ dl_lon0 = dd_lon0(il_imax0, il_jmax0)
+ dl_lat0 = dd_lat0(il_imax0, il_jmax0)
dl_lon1 = dd_lon1(il_imax1, il_jmax1)
dl_lat1 = dd_lat1(il_imax1, il_jmax1)
- dl_dlon=ABS(dd_lon1(il_imax1-1,il_jmax1 )-dl_lon1)*1.e-3
- dl_dlat=ABS(dd_lat1(il_imax1 ,il_jmax1-1)-dl_lat1)*1.e-3
-
- IF( (ABS(dl_lon1-dl_lon0)>dl_dlon) .AND. (dl_lon1 > dl_lon0) .OR. &
- & (ABS(dl_lat1-dl_lat0)>dl_dlat) .AND. (dl_lat1 > dl_lat0) )THEN
+ IF( (ABS(dl_lon1-dl_lon0)>dp_delta) .AND. (dl_lon1 > dl_lon0) .OR. &
+ & (ABS(dl_lat1-dl_lat0)>dp_delta) .AND. (dl_lat1 > dl_lat0) )THEN
CALL logger_error("GRID CHECK COINCIDENCE: fine grid upper right "//&
@@ -2288,5 +4195,4 @@
END FUNCTION grid__check_corner
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function check that fine grid latitude are
@@ -2296,16 +4202,14 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] dd_lat0 : table of coarse grid latitude
- !> @param[in] dd_lat1 : table of fine grid latitude
- !-------------------------------------------------------------------
- !> @code
- FUNCTION grid__check_lat(dd_lat0, dd_lat1, id_rhoj)
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] dd_lat0 array of coarse grid latitude
+ !> @param[in] dd_lat1 array of fine grid latitude
+ !-------------------------------------------------------------------
+ FUNCTION grid__check_lat(dd_lat0, dd_lat1)
IMPLICIT NONE
! Argument
REAL(dp), DIMENSION(:), INTENT(IN) :: dd_lat0
REAL(dp), DIMENSION(:), INTENT(IN) :: dd_lat1
- INTEGER(i4) , INTENT(IN) :: id_rhoj
! function
@@ -2321,6 +4225,4 @@
INTEGER(i4) :: il_jmin1
INTEGER(i4) :: il_jmax1
-
- REAL(dp) :: dl_dlat
! loop indices
!----------------------------------------------------------------
@@ -2333,12 +4235,9 @@
!1- check if fine grid inside coarse grid domain
- il_jmin0=1+1 ; il_jmax0=il_shape0(1)-1
-
- il_jmin1=1+id_rhoj ; il_jmax1=il_shape1(1)-id_rhoj
-
- dl_dlat=ABS(dd_lat1(il_jmin1+1)-dd_lat1(il_jmin1))*1.e-3
+ il_jmin0=1 ; il_jmax0=il_shape0(1)
+ il_jmin1=1 ; il_jmax1=il_shape1(1)
! check lower left fine grid
- IF( ABS(dd_lat1(il_jmin1)-dd_lat0(il_jmin0)) > dl_dlat .AND. &
+ IF( ABS(dd_lat1(il_jmin1)-dd_lat0(il_jmin0)) > dp_delta .AND. &
& dd_lat1(il_jmin1) < dd_lat0(il_jmin0) )THEN
@@ -2353,8 +4252,6 @@
ENDIF
- dl_dlat=ABS(dd_lat1(il_jmax1-1)-dd_lat1(il_jmax1))*1.e-3
-
! check upper left fine grid
- IF( ABS(dd_lat1(il_jmax1)-dd_lat0(il_jmax0)) > dl_dlat .AND. &
+ IF( ABS(dd_lat1(il_jmax1)-dd_lat0(il_jmax0)) > dp_delta .AND. &
& dd_lat1(il_jmax1) > dd_lat0(il_jmax0) )THEN
@@ -2370,5 +4267,4 @@
END FUNCTION grid__check_lat
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -2376,17 +4272,14 @@
!>
!> @author J.Paul
- !> - Nov, 2013-Initial version
- !
- !> @param[inout] td_var : table of variable structure
- !> @param[in] id_ighost : i-direction ghost cell factor
- !> @param[in] id_jghost : j-direction ghost cell factor
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE grid_add_ghost(td_var, id_ighost, id_jghost)
+ !> - November, 2013-Initial version
+ !
+ !> @param[inout] td_var array of variable structure
+ !> @param[in] id_ghost array of ghost cell factor
+ !-------------------------------------------------------------------
+ SUBROUTINE grid_add_ghost(td_var, id_ghost)
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_var
- INTEGER(i4), INTENT(IN ) :: id_ighost
- INTEGER(i4), INTENT(IN ) :: id_jghost
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
+ INTEGER(i4), DIMENSION(2,2), INTENT(IN ) :: id_ghost
! local variable
@@ -2409,18 +4302,20 @@
! copy variable
- tl_var=td_var
+ tl_var=var_copy(td_var)
CALL var_del_value(td_var)
! compute indice to fill center
- il_imin=1+id_ighost*ig_ghost
- il_jmin=1+id_jghost*ig_ghost
-
- il_imax=il_imin+tl_var%t_dim(1)%i_len-1
- il_jmax=il_jmin+tl_var%t_dim(2)%i_len-1
+ il_imin=1+id_ghost(jp_I,1)*ip_ghost
+ il_jmin=1+id_ghost(jp_J,1)*ip_ghost
+
+ il_imax=tl_var%t_dim(1)%i_len+id_ghost(jp_I,1)*ip_ghost
+ il_jmax=tl_var%t_dim(2)%i_len+id_ghost(jp_J,1)*ip_ghost
! compute new dimension
- td_var%t_dim(1)%i_len = tl_var%t_dim(1)%i_len + 2*id_ighost*ig_ghost
- td_var%t_dim(2)%i_len = tl_var%t_dim(2)%i_len + 2*id_jghost*ig_ghost
+ td_var%t_dim(1)%i_len = tl_var%t_dim(1)%i_len + &
+ & SUM(id_ghost(jp_I,:))*ip_ghost
+ td_var%t_dim(2)%i_len = tl_var%t_dim(2)%i_len + &
+ & SUM(id_ghost(jp_J,:))*ip_ghost
ALLOCATE(dl_value(td_var%t_dim(1)%i_len, &
@@ -2448,5 +4343,4 @@
END SUBROUTINE grid_add_ghost
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -2454,17 +4348,14 @@
!>
!> @author J.Paul
- !> - Nov, 2013-Initial version
- !
- !> @param[inout] td_var : table of variable structure
- !> @param[in] id_ighost : i-direction ghost cell factor
- !> @param[in] id_jghost : j-direction ghost cell factor
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE grid_del_ghost(td_var, id_ighost, id_jghost)
+ !> - November, 2013-Initial version
+ !
+ !> @param[inout] td_var array of variable structure
+ !> @param[in] id_ghost array of ghost cell factor
+ !-------------------------------------------------------------------
+ SUBROUTINE grid_del_ghost(td_var, id_ghost)
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_var
- INTEGER(i4), INTENT(IN ) :: id_ighost
- INTEGER(i4), INTENT(IN ) :: id_jghost
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
+ INTEGER(i4), DIMENSION(2,2), INTENT(IN ) :: id_ghost
! local variable
@@ -2483,22 +4374,22 @@
IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
- CALL logger_warn( "DEL GHOST: dimension change in variable "//&
+ CALL logger_warn( "GRID DEL GHOST: dimension change in variable "//&
& TRIM(td_var%c_name) )
! copy variable
- tl_var=td_var
+ tl_var=var_copy(td_var)
CALL var_del_value(td_var)
! compute indice to get center
- il_imin=1+id_ighost*ig_ghost
- il_jmin=1+id_jghost*ig_ghost
-
- il_imax=tl_var%t_dim(1)%i_len-id_ighost*ig_ghost
- il_jmax=tl_var%t_dim(2)%i_len-id_jghost*ig_ghost
+ il_imin=1+id_ghost(jp_I,1)*ip_ghost
+ il_jmin=1+id_ghost(jp_J,1)*ip_ghost
+
+ il_imax=tl_var%t_dim(1)%i_len-id_ghost(jp_I,2)*ip_ghost
+ il_jmax=tl_var%t_dim(2)%i_len-id_ghost(jp_J,2)*ip_ghost
! compute new dimension
- td_var%t_dim(1)%i_len = tl_var%t_dim(1)%i_len - 2*id_ighost*ig_ghost
- td_var%t_dim(2)%i_len = tl_var%t_dim(2)%i_len - 2*id_jghost*ig_ghost
+ td_var%t_dim(1)%i_len = il_imax - il_imin +1
+ td_var%t_dim(2)%i_len = il_jmax - il_jmin +1
ALLOCATE(dl_value(td_var%t_dim(1)%i_len, &
@@ -2526,87 +4417,220 @@
END SUBROUTINE grid_del_ghost
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill small closed sea with fill value.
+ !-------------------------------------------------------------------
+ !> @brief This function check if ghost cell are used or not, and return ghost
+ !> cell factor (0,1) in horizontal plan.
!
!> @details
- !> the minimum size (nbumber of point) of closed sea to be kept could be
- !> sepcify with id_minsize.
- !> By default only the biggest sea is preserve.
- !
+ !> check if domain is global, and if there is an East-West overlap.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] id_mask : domain mask (from grid_split_domain)
- !> @param[in] id_minsize : minimum size of sea to be kept
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE grid_fill_small_dom(td_var, id_mask, id_minsize)
+ !> - September, 2014- Initial Version
+ !
+ !> @param[in] td_var variable sturcture
+ !> @return array of ghost cell factor
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_ghost_var( td_var )
IMPLICIT NONE
- ! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_var
- INTEGER(i4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_mask
- INTEGER(i4), INTENT(IN ), OPTIONAL :: id_minsize
+ ! Argument
+ TYPE(TVAR), INTENT(IN) :: td_var
+
+ ! function
+ INTEGER(i4), DIMENSION(2,2) :: grid__get_ghost_var
! local variable
- INTEGER(i4) :: il_ndom
- INTEGER(i4) :: il_minsize
- INTEGER(i4), DIMENSION(2) :: il_shape
- INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
! loop indices
- INTEGER(i4) :: ji
- INTEGER(i4) :: jk
- INTEGER(i4) :: jl
!----------------------------------------------------------------
-
- il_shape(:)=SHAPE(id_mask(:,:))
- IF( ANY(il_shape(:) /= td_var%t_dim(1:2)%i_len) )THEN
- CALL logger_error("GRID FILL SMALL DOM: variable and mask "//&
- & "dimension differ")
+ ! init
+ grid__get_ghost_var(:,:)=0
+
+ IF( .NOT. ALL(td_var%t_dim(1:2)%l_use) )THEN
+ CALL logger_error("GRID GET GHOST: "//TRIM(td_var%c_name)//" is not a suitable"//&
+ & " variable to look for ghost cell (not 2D).")
ELSE
-
- il_ndom=MINVAL(id_mask(:,:))
-
- ALLOCATE( il_tmp(il_shape(1),il_shape(2)) )
- il_tmp(:,:)=0
- DO ji=-1,il_ndom,-1
- WHERE( id_mask(:,:)==ji )
- il_tmp(:,:)=SUM(id_mask(:,:),id_mask(:,:)==ji)/ji
- END WHERE
- ENDDO
-
- il_minsize=MAXVAL(il_tmp(:,:))
- IF( PRESENT(id_minsize) ) il_minsize=id_minsize
-
- DO jl=1,td_var%t_dim(4)%i_len
- DO jk=1,td_var%t_dim(3)%i_len
- WHERE( il_tmp(:,:) < il_minsize )
- td_var%d_value(:,:,jk,jl)=td_var%d_fill
- END WHERE
- ENDDO
- ENDDO
-
- DEALLOCATE( il_tmp )
-
- ENDIF
-
- END SUBROUTINE grid_fill_small_dom
- !> @endcode
+ IF( .NOT. ASSOCIATED(td_var%d_value) )THEN
+ CALL logger_error("GRID GET GHOST: no value associated to "//TRIM(td_var%c_name)//&
+ & ". can't look for ghost cell.")
+ ELSE
+ il_dim(:)=td_var%t_dim(:)%i_len
+
+ IF(ALL(td_var%d_value( 1 , : ,1,1)/=td_var%d_fill).AND.&
+ & ALL(td_var%d_value(il_dim(1), : ,1,1)/=td_var%d_fill).AND.&
+ & ALL(td_var%d_value( : , 1 ,1,1)/=td_var%d_fill).AND.&
+ & ALL(td_var%d_value( : ,il_dim(2),1,1)/=td_var%d_fill))THEN
+ ! no boundary closed
+ CALL logger_warn("GRID GET GHOST: can't determined ghost cell. "//&
+ & "there is no boundary closed for variable "//&
+ & TRIM(td_var%c_name))
+
+ ELSE
+ ! check periodicity
+ IF(ANY(td_var%d_value( 1 ,:,1,1)/=td_var%d_fill).OR.&
+ & ANY(td_var%d_value(il_dim(1),:,1,1)/=td_var%d_fill))THEN
+ ! East-West cyclic (1,4,6)
+ CALL logger_info("GRID GET GHOST: East West cyclic")
+ grid__get_ghost_var(jp_I,:)=0
+
+ IF( ANY(td_var%d_value(:, 1, 1, 1) /= td_var%d_fill) )THEN
+ ! South boundary not closed
+
+ CALL logger_debug("GRID GET GHOST: East_West cyclic")
+ CALL logger_debug("GRID GET GHOST: South boundary not closed")
+ CALL logger_error("GRID GET GHOST: should have been an "//&
+ & "impossible case")
+
+ ELSE
+ ! South boundary closed (1,4,6)
+ CALL logger_info("GRID GET GHOST: South boundary closed")
+ grid__get_ghost_var(jp_J,1)=1
+
+ IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill) )THEN
+ ! North boundary not closed (4,6)
+ CALL logger_info("GRID GET GHOST: North boundary not closed")
+ grid__get_ghost_var(jp_J,2)=0
+ ELSE
+ ! North boundary closed
+ CALL logger_info("GRID GET GHOST: North boundary closed")
+ grid__get_ghost_var(jp_J,2)=1
+ ENDIF
+
+ ENDIF
+
+ ELSE
+ ! East-West boundaries closed (0,2,3,5)
+ CALL logger_info("GRID GET GHOST: East West boundaries closed")
+ grid__get_ghost_var(jp_I,:)=1
+
+ IF( ANY(td_var%d_value(:, 1, 1, 1) /= td_var%d_fill) )THEN
+ ! South boundary not closed (2)
+ CALL logger_info("GRID GET GHOST: South boundary not closed")
+ grid__get_ghost_var(jp_J,1)=0
+
+ IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill))THEN
+ ! North boundary not closed
+ CALL logger_debug("GRID GET GHOST: East West boundaries "//&
+ & "closed")
+ CALL logger_debug("GRID GET GHOST: South boundary not closed")
+ CALL logger_debug("GRID GET GHOST: North boundary not closed")
+ CALL logger_error("GRID GET GHOST: should have been "//&
+ & "an impossible case")
+ ELSE
+ ! North boundary closed
+ grid__get_ghost_var(jp_J,2)=1
+ ENDIF
+
+ ELSE
+ ! South boundary closed (0,3,5)
+ CALL logger_info("GRID GET GHOST: South boundary closed")
+ grid__get_ghost_var(jp_J,1)=1
+
+ IF(ANY(td_var%d_value(:,il_dim(2),1,1)/=td_var%d_fill))THEN
+ ! North boundary not closed (3,5)
+ CALL logger_info("GRID GET GHOST: North boundary not closed")
+ grid__get_ghost_var(jp_J,2)=0
+ ELSE
+ ! North boundary closed
+ CALL logger_info("GRID GET GHOST: North boundary closed")
+ grid__get_ghost_var(jp_J,2)=1
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+ ENDIF
+
+ END FUNCTION grid__get_ghost_var
+ !-------------------------------------------------------------------
+ !> @brief This function check if ghost cell are used or not, and return ghost
+ !> cell factor (0,1) in i- and j-direction.
+ !
+ !> @details
+ !> get longitude an latitude array, then
+ !> check if domain is global, and if there is an East-West overlap
+ !>
+ !> @author J.Paul
+ !> - September, 2014 - Initial Version
+ !> @date October, 2014
+ !> - work on mpp file structure instead of file structure
+ !
+ !> @param[in] td_file file sturcture
+ !> @return array of ghost cell factor
+ !-------------------------------------------------------------------
+ FUNCTION grid__get_ghost_mpp( td_mpp )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), INTENT(IN) :: td_mpp
+
+ ! function
+ INTEGER(i4), DIMENSION(2,2) :: grid__get_ghost_mpp
+
+ ! local variable
+ !TYPE(TVAR) :: tl_lon
+ !TYPE(TVAR) :: tl_lat
+
+ TYPE(TMPP) :: tl_mpp
+
+ !INTEGER(i4) :: il_lonid
+ !INTEGER(i4) :: il_latid
+ ! loop indices
+ !----------------------------------------------------------------
+ ! init
+ grid__get_ghost_mpp(:,:)=0
+
+ IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
+ CALL logger_error("GRID GET GHOST: decomposition of mpp file "//&
+ & TRIM(td_mpp%c_name)//" not defined." )
+
+ ELSE
+
+ ! copy structure
+ tl_mpp=mpp_copy(td_mpp)
+
+ IF( tl_mpp%i_perio < 0 )THEN
+ ! compute NEMO periodicity index
+ CALL grid_get_info(tl_mpp)
+ ENDIF
+
+ SELECT CASE(tl_mpp%i_perio)
+ CASE(0)
+ grid__get_ghost_mpp(:,:)=1
+ CASE(1)
+ grid__get_ghost_mpp(jp_J,:)=1
+ CASE(2)
+ grid__get_ghost_mpp(jp_I,:)=1
+ grid__get_ghost_mpp(jp_J,2)=1
+ CASE(3,5)
+ grid__get_ghost_mpp(jp_I,:)=1
+ grid__get_ghost_mpp(jp_J,1)=1
+ CASE(4,6)
+ grid__get_ghost_mpp(jp_J,1)=1
+ CASE DEFAULT
+ END SELECT
+
+ ! clean
+ CALL mpp_clean(tl_mpp)
+
+ ENDIF
+
+ END FUNCTION grid__get_ghost_mpp
!-------------------------------------------------------------------
!> @brief This subroutine compute closed sea domain.
!
!> @details
- !> to each domain is associated a negative value id (from -1 to ...)
- !
+ !> to each domain is associated a negative value id (from -1 to ...)
+ !> optionaly you could specify which level use (default 1)
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : variable strucutre
- !> @param[in] id_level : level
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_var variable strucutre
+ !> @param[in] id_level level
!> @return domain mask
!-------------------------------------------------------------------
- !> @code
FUNCTION grid_split_domain(td_var, id_level)
IMPLICIT NONE
@@ -2692,46 +4716,70 @@
END FUNCTION grid_split_domain
- !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This function
-! !
-! !> @details
-! !
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !-------------------------------------------------------------------
-! !> @code
-! FUNCTION grid_()
-! IMPLICIT NONE
-! ! Argument
-! ! function
-! ! local variable
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END FUNCTION grid_
-! !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This subroutine
-! !
-! !> @details
-! !
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !-------------------------------------------------------------------
-! !> @code
-! SUBROUTINE grid_()
-! IMPLICIT NONE
-! ! Argument
-! ! local variable
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END SUBROUTINE grid_
-! !> @endcode
+ !-------------------------------------------------------------------
+ !> @brief This subroutine fill small closed sea with fill value.
+ !>
+ !> @details
+ !> the minimum size (nbumber of point) of closed sea to be kept could be
+ !> sepcify with id_minsize.
+ !> By default only the biggest sea is preserve.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_var variable structure
+ !> @param[in] id_mask domain mask (from grid_split_domain)
+ !> @param[in] id_minsize minimum size of sea to be kept
+ !-------------------------------------------------------------------
+ SUBROUTINE grid_fill_small_dom(td_var, id_mask, id_minsize)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
+ INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_mask
+ INTEGER(i4), INTENT(IN ), OPTIONAL :: id_minsize
+
+ ! local variable
+ INTEGER(i4) :: il_ndom
+ INTEGER(i4) :: il_minsize
+ INTEGER(i4), DIMENSION(2) :: il_shape
+ INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jk
+ INTEGER(i4) :: jl
+ !----------------------------------------------------------------
+
+ il_shape(:)=SHAPE(id_mask(:,:))
+ IF( ANY(il_shape(:) /= td_var%t_dim(1:2)%i_len) )THEN
+ CALL logger_error("GRID FILL SMALL DOM: variable and mask "//&
+ & "dimension differ")
+ ELSE
+
+ il_ndom=MINVAL(id_mask(:,:))
+
+ ALLOCATE( il_tmp(il_shape(1),il_shape(2)) )
+ il_tmp(:,:)=0
+ DO ji=-1,il_ndom,-1
+ WHERE( id_mask(:,:)==ji )
+ il_tmp(:,:)=SUM(id_mask(:,:),id_mask(:,:)==ji)/ji
+ END WHERE
+ ENDDO
+
+ il_minsize=MAXVAL(il_tmp(:,:))
+ IF( PRESENT(id_minsize) ) il_minsize=id_minsize
+
+ DO jl=1,td_var%t_dim(4)%i_len
+ DO jk=1,td_var%t_dim(3)%i_len
+ WHERE( il_tmp(:,:) < il_minsize )
+ td_var%d_value(:,:,jk,jl)=td_var%d_fill
+ END WHERE
+ ENDDO
+ ENDDO
+
+ DEALLOCATE( il_tmp )
+
+ ENDIF
+
+ END SUBROUTINE grid_fill_small_dom
END MODULE grid
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp.f90 (revision 5214)
@@ -8,19 +8,73 @@
!> @brief
!> This module manage interpolation on regular grid.
-!> @note It is used to work on ORCA grid, as we work only with grid indices.
+!>
+!> @details Interpolation method to be used is specify inside variable
+!> strcuture, as array of string character.
+!> - td_var\%c_interp(1) string character is the interpolation name choose between:
+!> - 'nearest'
+!> - 'cubic '
+!> - 'linear '
+!> - td_var\%c_interp(2) string character is an operation to be used
+!> on interpolated value.
+!> operation have to be mulitplication '*' or division '/'.
+!> coefficient have to be refinement factor following i-direction 'rhoi',
+!> j-direction 'rhoj', or k-direction 'rhok'.
+!>
+!> Examples: '*rhoi', '/rhoj'.
+!>
+!> @note Those informations are read from namelist or variable configuration file (default).
+!> Interplation method could be specify for each variable in namelist _namvar_,
+!> defining string character _cn\_varinfo_.
+!> Example:
+!> - cn_varinfo='varname1:cubic/rhoi', 'varname2:linear'
+!>
+!> to create mixed grid (with coarse grid point needed to compute
+!> interpolation):
+!> @code
+!> CALL interp_create_mixed_grid( td_var, td_mix [,id_rho] )
+!> @endcode
+!> - td_var is coarse grid variable (should be extrapolated)
+!> - td_mix is mixed grid variable structure [output]
+!> - id_rho is array of refinment factor [optional]
+!>
+!> to detected point to be interpolated:
+!> @code
+!> il_detect(:,:,:)=interp_detect( td_mix [,id_rho] )
+!> @endcode
+!> - il_detect(:,:,:) is 3D array of detected point to be interpolated
+!> - td_mix is mixed grid variable
+!> - id_rho is array of refinement factor [optional]
+!>
+!> to interpolate variable value:
+!> @code
+!> CALL interp_fill_value( td_var [,id_rho] [,id_offset] )
+!> @endcode
+!> - td_var is variable structure
+!> - id_rho is array of refinement factor [optional]
+!> - id_offset is array of offset between fine and coarse grid [optional]
+!>
+!> to clean mixed grid (remove points added on mixed grid to compute interpolation):
+!> @code
+!> CALL interp_clean_mixed_grid( td_mix, td_var, id_rho )
+!> @endcode
+!> - td_mix is mixed grid variable structure
+!> - td_var is variable structure [output]
+!> - id_rho is array of refinement factor [optional]
+!> - id_offset is array of offset between fine and coarse grid [optional]
+!>
+!> @note It use to work on ORCA grid, as we work only with grid indices.
!>
!> @warning due to the use of second derivative when using cubic interpolation
-!> you should add 2 extrabands
+!> you should add at least 2 extrabands.
!>
-!> @details
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
+!> @date November, 2013 - Initial Version
+!> @date September, 2014
+!> - add header
+!> - use interpolation method modules
+!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!> @todo
-!> - interp 3D
-!> - see issue when fill value is zero for check cubic_fill..
!----------------------------------------------------------------------
MODULE interp
@@ -29,22 +83,17 @@
USE global ! global variable
USE kind ! F90 kind parameter
- USE logger ! log file manager
+ USE logger ! log file manager
USE fct ! basic useful function
-! USE date ! date manager
+ USE date ! date manager
USE att ! attribute manager
USE dim ! dimension manager
USE var ! variable manager
-! USE file ! file manager
-! USE iom ! I/O manager
-! USE dom ! domain manager
USE grid ! grid manager
USE extrap ! extrapolation manager
-! USE interp ! interpolation manager
-! USE filter ! filter manager
-! USE mpp ! MPP manager
-! USE iom_mpp ! MPP I/O manager
+ USE interp_cubic ! cubic interpolation manager
+ USE interp_linear ! linear interpolation manager
+ USE interp_nearest ! nearest interpolation manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
@@ -53,34 +102,16 @@
! function and subroutine
PUBLIC :: interp_detect !< detected point to be interpolated
- PUBLIC :: interp_fill_value !< interpolate value over detectected point
+ PUBLIC :: interp_fill_value !< interpolate value
PUBLIC :: interp_create_mixed_grid !< create mixed grid
PUBLIC :: interp_clean_mixed_grid !< clean mixed grid
- PRIVATE :: interp__detect !< detected point to be interpolated
- PRIVATE :: interp__detect_wrapper !< detected point to be interpolated
- PRIVATE :: interp__fill_value_wrapper !< interpolate value over detectected point
- PRIVATE :: interp__fill_value !< interpolate value over detectected point
- PRIVATE :: interp__clean_even_grid !< clean even mixed grid
- PRIVATE :: interp__del_offset !< remove offset from interpolated grid
- PRIVATE :: interp__check_method !< check if interpolation method available
-! PRIVATE :: interp__3D !< interpolate 3D grid
- PRIVATE :: interp__2D !< interpolate 2D grid
- PRIVATE :: interp__1D !< interpolate 1D grid
- PRIVATE :: interp__2D_cubic_coef !< compute coefficient for bicubic interpolation
- PRIVATE :: interp__2D_cubic_fill !< compute bicubic interpolation
- PRIVATE :: interp__2D_linear_coef !< compute coefficient for bilinear interpolation
- PRIVATE :: interp__2D_linear_fill !< compute bilinear interpolation
- PRIVATE :: interp__2D_nearest_fill !< compute nearest interpolation
- PRIVATE :: interp__1D_cubic_coef !< compute coefficient for cubic interpolation
- PRIVATE :: interp__1D_cubic_fill !< compute cubic interpolation
- PRIVATE :: interp__1D_linear_coef !< compute coefficient for linear interpolation
- PRIVATE :: interp__1D_linear_fill !< compute linear interpolation
- PRIVATE :: interp__1D_nearest_fill !< compute nearest interpolation
-! PRIVATE :: interp__longitude
+ PRIVATE :: interp__detect ! detected point to be interpolated
+ PRIVATE :: interp__detect_wrapper ! detected point to be interpolated
+ PRIVATE :: interp__fill_value_wrapper ! interpolate value over detectected point
+ PRIVATE :: interp__fill_value ! interpolate value over detectected point
+ PRIVATE :: interp__clean_even_grid ! clean even mixed grid
+ PRIVATE :: interp__check_method ! check if interpolation method available
TYPE TINTERP
- !CHARACTER(LEN=lc) :: c_name = 'unknown' !< interpolation method name
- !CHARACTER(LEN=lc) :: c_factor = 'unknown' !< interpolation factor
- !CHARACTER(LEN=lc) :: c_divisor = 'unknown' !< interpolation divisor
CHARACTER(LEN=lc) :: c_name = '' !< interpolation method name
CHARACTER(LEN=lc) :: c_factor = '' !< interpolation factor
@@ -89,9 +120,9 @@
INTERFACE interp_detect
- MODULE PROCEDURE interp__detect_wrapper !< detected point to be interpolated
+ MODULE PROCEDURE interp__detect_wrapper
END INTERFACE interp_detect
INTERFACE interp_fill_value
- MODULE PROCEDURE interp__fill_value_wrapper !< detected point to be interpolated
+ MODULE PROCEDURE interp__fill_value_wrapper
END INTERFACE interp_fill_value
@@ -99,16 +130,16 @@
!-------------------------------------------------------------------
!> @brief
- !> This function check if interpolation method available.
+ !> This function check if interpolation method is available.
!>
!> @details
+ !> check if name of interpolation method is present in global list of string
+ !> character cp_interp_list (see global.f90).
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
- !> @param[in] cd_method : interpolation method
+ !> @param[in] cd_method interpolation method
!> @return
- !> @todo see extrap_detect
- !-------------------------------------------------------------------
- !> @code
+ !-------------------------------------------------------------------
FUNCTION interp__check_method( cd_method )
IMPLICIT NONE
@@ -130,6 +161,6 @@
interp__check_method=.FALSE.
- DO ji=1,ig_ninterp
- cl_interp=fct_lower(cg_interp_list(ji))
+ DO ji=1,ip_ninterp
+ cl_interp=fct_lower(cp_interp_list(ji))
IF( TRIM(cl_interp) == TRIM(cl_method) )THEN
interp__check_method=.TRUE.
@@ -139,5 +170,4 @@
END FUNCTION interp__check_method
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -149,11 +179,10 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mix : mixed grid variable (to interpolate)
- !> @param[in] id_rho : table of refinement factor
- !> @return table of detected point to be interpolated
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] td_mix mixed grid variable (to interpolate)
+ !> @param[in] id_rho array of refinement factor
+ !> @return 3D array of detected point to be interpolated
+ !-------------------------------------------------------------------
FUNCTION interp__detect_wrapper( td_mix, id_rho )
IMPLICIT NONE
@@ -168,5 +197,4 @@
! local variable
-
! loop indices
!----------------------------------------------------------------
@@ -208,5 +236,4 @@
END FUNCTION interp__detect_wrapper
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -217,11 +244,10 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
+ !> - November, 2013- Initial Version
!
- !> @param[in] td_mix : mixed grid variable (to interpolate)
- !> @param[in] id_rho : table of refinement factor
- !> @return table of detected point to be interpolated
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] td_mix mixed grid variable (to interpolate)
+ !> @param[in] id_rho array of refinement factor
+ !> @return 3D array of detected point to be interpolated
+ !-------------------------------------------------------------------
FUNCTION interp__detect( td_mix, id_rho )
IMPLICIT NONE
@@ -253,5 +279,5 @@
ALLOCATE( il_rho(ip_maxdim) )
il_rho(:)=1
- IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:)
+ IF( PRESENT(id_rho) ) il_rho(1:SIZE(id_rho(:)))=id_rho(:)
! special case for even refinement on ARAKAWA-C grid
@@ -289,4 +315,5 @@
il_dim(:)=td_mix%t_dim(1:3)%i_len
+ ! init
interp__detect(:,:,:)=1
@@ -297,26 +324,32 @@
! do not compute point near fill value
- FORALL( ji=1:il_dim(1):il_rho(jp_I), &
- & jj=1:il_dim(2):il_rho(jp_J), &
- & jk=1:il_dim(3):il_rho(jp_K), &
- & td_mix%d_value(ji,jj,jk,1) == td_mix%d_fill )
-
- ! i-direction
- interp__detect(MAX(1,ji-il_xextra):MIN(ji+il_xextra,il_dim(1)),&
- & MAX(1,jj-(il_rho(jp_J)-1)):MIN(jj+(il_rho(jp_J)-1),il_dim(2)),&
- & MAX(1,jk-(il_rho(jp_K)-1)):MIN(jk+(il_rho(jp_K)-1),il_dim(3)) )=0
- ! j-direction
- interp__detect(MAX(1,ji-(il_rho(jp_I)-1)):MIN(ji+(il_rho(jp_I)-1),il_dim(1)),&
- & MAX(1,jj-il_yextra):MIN(jj+il_yextra,il_dim(2)),&
- & MAX(1,jk-(il_rho(jp_K)-1)):MIN(jk+(il_rho(jp_K)-1),il_dim(3)) )=0
- ! k-direction
- interp__detect(MAX(1,ji-(il_rho(jp_I)-1)):MIN(ji+(il_rho(jp_I)-1),il_dim(1)),&
- & MAX(1,jj-(il_rho(jp_J)-1)):MIN(jj+(il_rho(jp_J)-1),il_dim(2)),&
- & MAX(1,jk-il_zextra):MIN(jk+il_zextra,il_dim(3)) )=0
-
- END FORALL
+ DO jk=1,il_dim(3),il_rho(jp_K)
+ DO jj=1,il_dim(2),il_rho(jp_J)
+ DO ji=1,il_dim(1),il_rho(jp_I)
+
+ IF( td_mix%d_value(ji,jj,jk,1) == td_mix%d_fill )THEN
+
+ ! i-direction
+ interp__detect(MAX(1,ji-il_xextra):MIN(ji+il_xextra,il_dim(1)),&
+ & MAX(1,jj-(il_rho(jp_J)-1)):MIN(jj+(il_rho(jp_J)-1),il_dim(2)),&
+ & MAX(1,jk-(il_rho(jp_K)-1)):MIN(jk+(il_rho(jp_K)-1),il_dim(3)) )=0
+ ! j-direction
+ interp__detect(MAX(1,ji-(il_rho(jp_I)-1)):MIN(ji+(il_rho(jp_I)-1),il_dim(1)),&
+ & MAX(1,jj-il_yextra):MIN(jj+il_yextra,il_dim(2)),&
+ & MAX(1,jk-(il_rho(jp_K)-1)):MIN(jk+(il_rho(jp_K)-1),il_dim(3)) )=0
+ ! k-direction
+ interp__detect(MAX(1,ji-(il_rho(jp_I)-1)):MIN(ji+(il_rho(jp_I)-1),il_dim(1)),&
+ & MAX(1,jj-(il_rho(jp_J)-1)):MIN(jj+(il_rho(jp_J)-1),il_dim(2)),&
+ & MAX(1,jk-il_zextra):MIN(jk+il_zextra,il_dim(3)) )=0
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+ ENDDO
+
+ DEALLOCATE( il_rho )
END FUNCTION interp__detect
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -330,13 +363,10 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : coarse grid variable (should be extrapolated)
- !> @param[out] td_mix : mixed grid variable
- !> @param[in] id_rho : table of refinment factor
- !>
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] td_var coarse grid variable (should be extrapolated)
+ !> @param[out] td_mix mixed grid variable
+ !> @param[in] id_rho array of refinment factor (default 1)
+ !-------------------------------------------------------------------
SUBROUTINE interp_create_mixed_grid( td_var, td_mix, id_rho )
IMPLICIT NONE
@@ -359,5 +389,5 @@
ALLOCATE(il_rho(ip_maxdim))
il_rho(:)=1
- IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:)
+ IF( PRESENT(id_rho) ) il_rho(1:SIZE(id_rho(:)))=id_rho(:)
! special case for even refinement on ARAKAWA-C grid
@@ -381,5 +411,5 @@
! copy variable
- td_mix=td_var
+ td_mix=var_copy(td_var)
! compute new dimension length
@@ -408,6 +438,7 @@
& td_var%d_value(:,:,:,:)
+ DEALLOCATE(il_rho)
+
END SUBROUTINE interp_create_mixed_grid
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -418,16 +449,13 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mix : mixed grid variable
- !> @param[in] id_rho : table of refinment factor
- !>
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_mix mixed grid variable
+ !> @param[in] id_rho array of refinment factor
+ !-------------------------------------------------------------------
SUBROUTINE interp__clean_even_grid( td_mix, id_rho )
IMPLICIT NONE
! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_mix
+ TYPE(TVAR) , INTENT(INOUT) :: td_mix
INTEGER(I4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_rho
@@ -468,9 +496,9 @@
END SELECT
- ! copy variable
- tl_mix=td_mix
-
! remove some point only if refinement in some direction is even
IF( ANY(ll_even(:)) )THEN
+
+ ! copy variable
+ tl_mix=var_copy(td_mix)
ALLOCATE( ll_mask( tl_mix%t_dim(1)%i_len, &
@@ -554,5 +582,8 @@
td_mix%d_value(:,:,:,:)=RESHAPE( dl_vect(:), &
- & SHAPE=td_mix%t_dim(:)%i_len )
+ & SHAPE=(/td_mix%t_dim(1)%i_len, &
+ & td_mix%t_dim(2)%i_len, &
+ & td_mix%t_dim(3)%i_len, &
+ & td_mix%t_dim(4)%i_len/) )
DEALLOCATE( dl_vect )
@@ -562,35 +593,38 @@
DEALLOCATE( ll_mask )
+ ! clean
+ CALL var_clean(tl_mix)
+
ENDIF
- CALL var_clean(tl_mix)
+ ! clean
+ DEALLOCATE(il_rho)
END SUBROUTINE interp__clean_even_grid
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine save interpolated value over domain.
- !> And so remove points added on mixed grid
- !> to compute interpolation
+ !> This subroutine remove points added on mixed grid
+ !> to compute interpolation. And save interpolated value over domain.
!>
!> @details
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : table of mixed grid variable (to interpolate)
- !> @param[in] id_rho : table of refinement factor
- !> @return
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - use offset to save useful domain
+ !>
+ !> @param[in] td_mix mixed grid variable structure
+ !> @param[out] td_var variable structure
+ !> @param[in] id_rho array of refinement factor (default 1)
+ !> @param[in] id_offset 2D array of offset between fine and coarse grid
+ !-------------------------------------------------------------------
SUBROUTINE interp_clean_mixed_grid( td_mix, td_var, &
- & id_rho, &
- & id_offset )
+ & id_rho, id_offset )
IMPLICIT NONE
! Argument
TYPE(TVAR) , INTENT(IN ) :: td_mix
TYPE(TVAR) , INTENT( OUT) :: td_var
- INTEGER(I4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho
- INTEGER(I4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset
+ INTEGER(I4), DIMENSION(:) , INTENT(IN ) :: id_rho
+ INTEGER(I4), DIMENSION(2,2), INTENT(IN ) :: id_offset
! local variable
@@ -605,6 +639,4 @@
INTEGER(i4) :: il_jmax1
- INTEGER(i4), DIMENSION(2,2) :: il_offset
-
REAL(dp), DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value
@@ -613,15 +645,6 @@
! loop indices
!----------------------------------------------------------------
- il_offset(:,:)=0
- IF( PRESENT(id_offset) )THEN
- IF( ANY( SHAPE(id_offset(:,:)) /= SHAPE(il_offset(:,:)) ) )THEN
- CALL logger_error("INTERP CLEAN MIXED GRID: invalid dimension of"//&
- & " offset table")
- ELSE
- il_offset(:,:)=id_offset(:,:)
- ENDIF
- ENDIF
! copy mixed variable in temporary structure
- tl_mix=td_mix
+ tl_mix=var_copy(td_mix)
! remove unusefull points over mixed grid for even refinement
@@ -629,131 +652,62 @@
! copy cleaned mixed variable
- td_var=tl_mix
- IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
-
- ! delete table of value
- CALL var_del_value(td_var)
-
- ! compute domain indices
- il_imin0=1 ; il_imax0=td_var%t_dim(1)%i_len
- il_jmin0=1 ; il_jmax0=td_var%t_dim(2)%i_len
-
- il_imin1=il_imin0+il_offset(1,1)
- il_jmin1=il_jmin0+il_offset(2,1)
-
- il_imax1=il_imax0-il_offset(1,2)
- il_jmax1=il_jmax0-il_offset(2,2)
-
- SELECT CASE(TRIM(td_var%c_point))
- CASE('U')
- il_imin1=il_imin0+(il_offset(1,1)-1)
- il_imax1=il_imax0-(il_offset(1,2)+1)
- CASE('V')
- il_jmin1=il_jmin0+(il_offset(2,1)-1)
- il_jmax1=il_jmax0-(il_offset(2,2)+1)
- CASE('F')
- il_imin1=il_imin0+(il_offset(1,1)-1)
- il_imax1=il_imax0-(il_offset(1,2)+1)
-
- il_jmin1=il_jmin0+(il_offset(2,1)-1)
- il_jmax1=il_jmax0-(il_offset(2,2)+1)
- END SELECT
-
- ! compute new dimension
- td_var%t_dim(1)%i_len=il_imax1-il_imin1+1
- td_var%t_dim(2)%i_len=il_jmax1-il_jmin1+1
+ td_var=var_copy(tl_mix)
+
+ ! delete array of value
+ CALL var_del_value(td_var)
+
+ ! compute domain indices in i-direction
+ il_imin0=1 ; il_imax0=td_var%t_dim(1)%i_len
- ALLOCATE(dl_value(td_var%t_dim(1)%i_len, &
- & td_var%t_dim(2)%i_len, &
- & td_var%t_dim(3)%i_len, &
- & td_var%t_dim(4)%i_len) )
-
- dl_value( 1:td_var%t_dim(1)%i_len, &
- & :,:,:) = tl_mix%d_value( il_imin1:il_imax1, &
- & il_jmin1:il_jmax1, &
- & :, : )
-
- ! add variable value
- CALL var_add_value(td_var,dl_value(:,:,:,:))
-
- ! save variable type
- td_var%i_type=tl_mix%i_type
-
- DEALLOCATE(dl_value)
+ IF( td_var%t_dim(1)%l_use )THEN
+ il_imin1=il_imin0+id_offset(Jp_I,1)
+ il_imax1=il_imax0-id_offset(Jp_I,2)
+ ELSE
+
+ il_imin1=il_imin0
+ il_imax1=il_imax0
ENDIF
-
+
+ ! compute domain indices in j-direction
+ il_jmin0=1 ; il_jmax0=td_var%t_dim(2)%i_len
+
+ IF( td_var%t_dim(2)%l_use )THEN
+ il_jmin1=il_jmin0+id_offset(Jp_J,1)
+ il_jmax1=il_jmax0-id_offset(Jp_J,2)
+ ELSE
+
+ il_jmin1=il_jmin0
+ il_jmax1=il_jmax0
+
+ ENDIF
+
+ ! compute new dimension
+ td_var%t_dim(1)%i_len=il_imax1-il_imin1+1
+ td_var%t_dim(2)%i_len=il_jmax1-il_jmin1+1
+
+ ALLOCATE(dl_value(td_var%t_dim(1)%i_len, &
+ & td_var%t_dim(2)%i_len, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len) )
+
+ dl_value( 1:td_var%t_dim(1)%i_len, &
+ & 1:td_var%t_dim(2)%i_len, &
+ & :,:) = tl_mix%d_value( il_imin1:il_imax1, &
+ & il_jmin1:il_jmax1, &
+ & :, : )
+
+ ! add variable value
+ CALL var_add_value(td_var,dl_value(:,:,:,:))
+
+ DEALLOCATE(dl_value)
+
+ ! clean
CALL var_clean(tl_mix)
END SUBROUTINE interp_clean_mixed_grid
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine save interpolated value over domain.
- !> And so remove points added on mixed grid
- !> to compute interpolation
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : table of mixed grid variable (to interpolate)
- !> @param[in] id_offset : table of offset
- !> @return
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE interp__del_offset( td_var, id_offset )
- IMPLICIT NONE
- ! Argument
- TYPE(TVAR) , INTENT(INOUT) :: td_var
- INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_offset
-
- ! local variable
- INTEGER(i4) :: il_imin1
- INTEGER(i4) :: il_jmin1
- INTEGER(i4) :: il_imax1
- INTEGER(i4) :: il_jmax1
-
- REAL(dp), DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value
-
- ! loop indices
- !----------------------------------------------------------------
-
- IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
-
- il_imin1=1+id_offset(1,1)
- il_jmin1=1+id_offset(2,1)
-
- il_imax1=td_var%t_dim(1)%i_len-id_offset(2,1)
- il_jmax1=td_var%t_dim(2)%i_len-id_offset(2,2)
-
- ! compute new dimension
- td_var%t_dim(1)%i_len=il_imax1-il_imin1+1
- td_var%t_dim(2)%i_len=il_jmax1-il_jmin1+1
- ALLOCATE( dl_value( td_var%t_dim(1)%i_len, &
- & td_var%t_dim(2)%i_len, &
- & td_var%t_dim(3)%i_len, &
- & td_var%t_dim(4)%i_len) )
-
- dl_value(:,:,:,:)=td_var%d_value( il_imin1:il_imax1, &
- & il_jmin1:il_jmax1, &
- & :,: )
-
- ! delete table of value
- CALL var_del_value(td_var)
-
- ! add variable value
- CALL var_add_value(td_var,dl_value(:,:,:,:))
-
- DEALLOCATE(dl_value)
-
- ENDIF
-
- END SUBROUTINE interp__del_offset
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine interpolate detected point.
+ !> This subroutine interpolate variable value.
!>
!> @details
@@ -762,10 +716,10 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : variable to be interpolated
- !> @param[in] id_rho : table of refinement factor
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_var variable structure
+ !> @param[in] id_rho array of refinement factor
+ !> @param[in] id_offset 2D array of offset between fine and coarse grid
+ !-------------------------------------------------------------------
SUBROUTINE interp__fill_value_wrapper( td_var, &
& id_rho, &
@@ -774,30 +728,18 @@
! Argument
TYPE(TVAR) , INTENT(INOUT) :: td_var
- INTEGER(I4), DIMENSION(:), INTENT(IN ), OPTIONAL :: id_rho
+ INTEGER(I4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho
INTEGER(I4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset
! local variable
- CHARACTER(LEN=lc) :: cl_method
- INTEGER(i4) , DIMENSION(:), ALLOCATABLE :: il_rho
- INTEGER(i4) , DIMENSION(2,2) :: il_offset
+ CHARACTER(LEN=lc) :: cl_method
+ INTEGER(i4) , DIMENSION(:), ALLOCATABLE :: il_rho
+ INTEGER(i4) , DIMENSION(2,2) :: il_offset
! loop indices
!----------------------------------------------------------------
- SELECT CASE(TRIM(td_var%c_interp(1)))
- CASE('cubic','linear','nearest')
- cl_method=TRIM(td_var%c_interp(1))
- CASE DEFAULT
- CALL logger_warn("INTERP FILL: interpolation method unknown."//&
- & " use linear interpolation")
- cl_method='linear'
-
- ! update variable structure value
- td_var%c_interp(1)='linear'
- END SELECT
-
ALLOCATE( il_rho(ip_maxdim) )
il_rho(:)=1
- IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:)
+ IF( PRESENT(id_rho) ) il_rho(1:SIZE(id_rho(:)))=id_rho(:)
IF( ANY(il_rho(:) < 0) )THEN
CALL logger_error("INTERP FILL VALUE: invalid "//&
@@ -808,5 +750,5 @@
IF( PRESENT(id_offset) )THEN
IF( ANY(SHAPE(id_offset(:,:)) /= (/2,2/)) )THEN
- CALL logger_error("INTERP FILL VALUE: invalid table of offset")
+ CALL logger_error("INTERP FILL VALUE: invalid array of offset")
ELSE
il_offset(:,:)=id_offset(:,:)
@@ -817,4 +759,15 @@
& (il_rho(jp_J) /= 1 .AND. td_var%t_dim(2)%l_use) .OR. &
& (il_rho(jp_K) /= 1 .AND. td_var%t_dim(3)%l_use) )THEN
+
+ SELECT CASE(TRIM(td_var%c_interp(1)))
+ CASE('cubic','linear','nearest')
+ cl_method=TRIM(td_var%c_interp(1))
+ CASE DEFAULT
+ CALL logger_warn("INTERP FILL VALUE: interpolation method unknown."//&
+ & " use linear interpolation")
+ cl_method='linear'
+ ! update variable structure value
+ td_var%c_interp(1)='linear'
+ END SELECT
CALL logger_info("INTERP FILL: interpolate "//TRIM(td_var%c_name)//&
@@ -826,6 +779,5 @@
CALL interp__fill_value( td_var, cl_method, &
- & il_rho(:), &
- & il_offset(:,:) )
+ & il_rho(:), il_offset(:,:) )
SELECT CASE(TRIM(td_var%c_interp(2)))
@@ -864,26 +816,27 @@
END SELECT
+ ELSE
+ td_var%c_interp(:)=''
ENDIF
+ DEALLOCATE(il_rho)
+
END SUBROUTINE interp__fill_value_wrapper
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine interpolate value over mixed grid.
!>
- !> @details
- !>
- !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable
- !> @param[in] cd_method : interpolation method
- !> @param[in] id_rho : table of refinment factor
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - use interpolation method modules
+ !>
+ !> @param[inout] td_var variable structure
+ !> @param[in] cd_method interpolation method
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] id_offset 2D array of offset between fine and coarse grid
+ !-------------------------------------------------------------------
SUBROUTINE interp__fill_value( td_var, cd_method, &
- & id_rho, &
- & id_offset )
+ & id_rho, id_offset )
IMPLICIT NONE
! Argument
@@ -891,5 +844,5 @@
CHARACTER(LEN=*) , INTENT(IN ) :: cd_method
INTEGER(I4) , DIMENSION(:) , INTENT(IN ) :: id_rho
- INTEGER(I4) , DIMENSION(:,:), INTENT(IN ) :: id_offset
+ INTEGER(I4) , DIMENSION(2,2), INTENT(IN ) :: id_offset
! local variable
@@ -908,10 +861,6 @@
TYPE(TATT) :: tl_att
-
+
! loop indices
- INTEGER(i4) :: ji
- INTEGER(i4) :: jj
- INTEGER(i4) :: jk
- INTEGER(i4) :: jl
!----------------------------------------------------------------
@@ -935,4 +884,7 @@
tl_att=att_init('interpolation',cl_interp)
CALL var_move_att(tl_mix, tl_att)
+
+ ! clean
+ CALL att_clean(tl_att)
! special case for even refinement on ARAKAWA-C grid
@@ -972,79 +924,20 @@
!3- interpolate
- DO jl=1,tl_mix%t_dim(4)%i_len
- IF( il_rho(jp_K) /= 1 )THEN
-! CALL interp__3D(tl_mix%d_value(:,:,:,jl), tl_mix%d_fill, &
-! & il_detect(:,:,:), cd_method, &
-! & il_rhoi, il_rhoj, il_rhok, &
-! & ll_even(:), ll_discont )
- CALL logger_error("INTERP FILL: can not interpolate "//&
- & "vertically for now ")
- ENDIF
-
- IF( ANY(il_detect(:,:,:)==1) )THEN
- ! I-J plan
- DO jk=1,tl_mix%t_dim(3)%i_len
- CALL interp__2D(tl_mix%d_value(:,:,jk,jl), tl_mix%d_fill, &
- & il_detect(:,:,jk), cd_method, &
- & il_rho(jp_I), il_rho(jp_J), &
- & ll_even(1:2), ll_discont)
- ENDDO
- IF( ALL(il_detect(:,:,:)==0) ) CYCLE
- IF( il_rho(jp_K) /= 1 )THEN
- ! I-K plan
- DO jj=1,tl_mix%t_dim(2)%i_len
- CALL interp__2D(tl_mix%d_value(:,jj,:,jl), tl_mix%d_fill, &
- & il_detect(:,jj,:), cd_method, &
- & il_rho(jp_J), il_rho(jp_K), &
- & ll_even(1:3:2), ll_discont )
- ENDDO
- IF( ALL(il_detect(:,:,:)==0) ) CYCLE
- ! J-K plan
- DO ji=1,tl_mix%t_dim(1)%i_len
- CALL interp__2D(tl_mix%d_value(ji,:,:,jl), tl_mix%d_fill, &
- & il_detect(ji,:,:), cd_method, &
- & il_rho(jp_J), il_rho(jp_K), &
- & ll_even(2:3), ll_discont )
- ENDDO
-
- ENDIF
- IF( ANY(il_detect(:,:,:)==1) )THEN
- ! I direction
- DO jk=1,tl_mix%t_dim(3)%i_len
- DO jj=1,tl_mix%t_dim(2)%i_len
- CALL interp__1D( tl_mix%d_value(:,jj,jk,jl), &
- & tl_mix%d_fill, &
- & il_detect(:,jj,jk), cd_method, &
- & il_rho(jp_I), &
- & ll_even(1), ll_discont )
- ENDDO
- ENDDO
- IF( ALL(il_detect(:,:,:)==0) ) CYCLE
- ! J direction
- DO jk=1,tl_mix%t_dim(3)%i_len
- DO ji=1,tl_mix%t_dim(1)%i_len
- CALL interp__1D( tl_mix%d_value(ji,:,jk,jl), &
- & tl_mix%d_fill, &
- & il_detect(ji,:,jk), cd_method, &
- & il_rho(jp_J), &
- & ll_even(2), ll_discont )
- ENDDO
- ENDDO
- IF( il_rho(jp_K) /= 1 )THEN
- IF( ALL(il_detect(:,:,:)==0) ) CYCLE
- ! K direction
- DO jj=1,tl_mix%t_dim(2)%i_len
- DO ji=1,tl_mix%t_dim(1)%i_len
- CALL interp__1D( tl_mix%d_value(ji,jj,:,jl), &
- & tl_mix%d_fill, &
- & il_detect(ji,jj,:), cd_method, &
- & il_rho(jp_K), &
- & ll_even(3), ll_discont )
- ENDDO
- ENDDO
- ENDIF
- ENDIF
- ENDIF
- ENDDO
+ CALL logger_debug("INTERP 2D: interpolation method "//TRIM(cd_method)//&
+ & " discont "//TRIM(fct_str(ll_discont)) )
+ SELECT CASE(TRIM(cd_method))
+ CASE('cubic')
+ CALL interp_cubic_fill(tl_mix%d_value(:,:,:,:), tl_mix%d_fill, &
+ & il_detect(:,:,:), &
+ & il_rho(:), ll_even(:), ll_discont )
+ CASE('nearest')
+ CALL interp_nearest_fill(tl_mix%d_value(:,:,:,:), &
+ & il_detect(:,:,:), &
+ & il_rho(:) )
+ CASE DEFAULT ! linear
+ CALL interp_linear_fill(tl_mix%d_value(:,:,:,:), tl_mix%d_fill, &
+ & il_detect(:,:,:), &
+ & il_rho(:), ll_even(:), ll_discont )
+ END SELECT
IF( ANY(il_detect(:,:,:)==1) )THEN
@@ -1056,1267 +949,10 @@
!4- save useful domain (remove offset)
CALL interp_clean_mixed_grid( tl_mix, td_var, &
- & id_rho(:), &
- & id_offset(:,:) )
+ & id_rho(:), id_offset(:,:) )
! clean variable structure
+ DEALLOCATE(il_rho)
CALL var_clean(tl_mix)
END SUBROUTINE interp__fill_value
- !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief
-! !> This subroutine
-! !>
-! !> @details
-! !>
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !> @param[out]
-! !-------------------------------------------------------------------
-! !> @code
-! SUBROUTINE interp__3D( dd_value, dd_fill, &
-! & id_detect, cd_method, &
-! & id_rhoi, id_rhoj, id_rhok, &
-! & ld_even, ld_discont )
-! IMPLICIT NONE
-! ! Argument
-! REAL(dp) , DIMENSION(:,:,:), INTENT(INOUT) :: dd_value
-! REAL(dp) , INTENT(IN ) :: dd_fill
-! INTEGER(I4) , DIMENSION(:,:,:), INTENT(INOUT) :: id_detect
-! CHARACTER(LEN=*) , INTENT(IN ) :: cd_method
-! INTEGER(I4) , INTENT(IN ) :: id_rhoi
-! INTEGER(I4) , INTENT(IN ) :: id_rhoj
-! INTEGER(I4) , INTENT(IN ) :: id_rhok
-! LOGICAL , DIMENSION(:) , INTENT(IN ) :: ld_even
-! LOGICAL , INTENT(IN ), OPTIONAL :: ld_discont
-!
-! ! local variable
-! INTEGER(i4), DIMENSION(3) :: il_shape
-! INTEGER(i4), DIMENSION(3) :: il_dim
-!
-! REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_coarse
-! REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_dfdx
-! REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_dfdy
-! REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_d2fdxy
-!
-! LOGICAL :: ll_discont
-!
-! ! loop indices
-!! INTEGER(i4) :: ji
-!! INTEGER(i4) :: jj
-!! INTEGER(i4) :: ii
-!! INTEGER(i4) :: ij
-! !----------------------------------------------------------------
-! ll_discont=.FALSE.
-! IF( PRESENT(ld_discont) ) ll_discont=ld_discont
-!
-! il_shape(:)=SHAPE(dd_value)
-! il_dim(:)=(il_shape(:)-1)/2
-!
-! ALLOCATE( dl_coarse(il_dim(1),il_dim(2),il_dim(3)) )
-! ! value on coarse grid
-! dl_coarse(:,:,:)=dd_value( 1:il_shape(1):id_rhoi, &
-! & 1:il_shape(2):id_rhoj, &
-! & 1:il_shape(3):id_rhok )
-! SELECT CASE(TRIM(cd_method))
-!
-! CASE('cubic')
-!
-! ALLOCATE( dl_dfdx( il_dim(1),il_dim(2),il_dim(3)), &
-! & dl_dfdy( il_dim(1),il_dim(2),il_dim(3)), &
-! & dl_d2fdxy(il_dim(1),il_dim(2),il_dim(3)) )
-!
-!! ! compute derivative on coarse grid
-!! dl_dfdx(:,:)=extrap_deriv_2D(dl_coarse(:,:,:), dd_fill, 'I')
-!! dl_dfdy(:,:)=extrap_deriv_2D(dl_coarse(:,:,:), dd_fill, 'J')
-!!
-!! ! compute cross derivative on coarse grid
-!! dl_d2fdxy(:,:)=extrap_deriv_2D(dl_dfdx(:,:,:), dd_fill, 'J')
-!!
-!! DO jj=1,il_shape(2)-1,id_rhoj
-!! ij=((jj-1)/id_rhoj)+1
-!! DO ji=1,il_shape(1)-1,id_rhoi
-!! ii=((ji-1)/id_rhoi)+1
-!!
-!! IF( ANY(dl_coarse(ii:ii+1,ij:ij+1)==dd_fill ) ) CYCLE
-!! ! compute bicubic coefficient
-!! dl_coef(:)=interp__2D_cubic_coef(dl_coarse(ii:ii+1,ij:ij+1),&
-!! & dl_dfdx( ii:ii+1,ij:ij+1),&
-!! & dl_dfdy( ii:ii+1,ij:ij+1),&
-!! & dl_d2fdxy(ii:ii+1,ij:ij+1) )
-!!
-!! ! compute value on detetected point
-!! CALL interp__2D_cubic_fill(dl_coef(:), &
-!! & dd_value( ji:ji+id_rhoi, &
-!! & jj:jj+id_rhoj ), &
-!! & id_detect(ji:ji+id_rhoi, &
-!! & jj:jj+id_rhoj ) )
-!!
-!! ENDDO
-!! ENDDO
-!
-! DEALLOCATE( dl_dfdx, &
-! & dl_dfdy, &
-! & dl_d2fdxy )
-!
-! CASE('nearest')
-!
-! CASE DEFAULT ! linear
-!
-!! DO jj=1,il_shape(2)-1,id_rhoj
-!! ij=((jj-1)/id_rhoj)+1
-!! DO ji=1,il_shape(1)-1,id_rhoi
-!! ii=((ji-1)/id_rhoi)+1
-!!
-!! IF( ANY(dl_coarse(ii:ii+1,ij:ij+1)==dd_fill ) ) CYCLE
-!! ! compute bilinear coefficient
-!! dl_coef(:)=interp__2D_linear_coef(dl_coarse(ii:ii+1,ij:ij+1))
-!!
-!! ! compute value on detetected point
-!! CALL interp__2D_linear_fill(dl_coef(:), &
-!! & dd_value( ji:ji+id_rhoi, &
-!! & jj:jj+id_rhoj ), &
-!! & id_detect(ji:ji+id_rhoi, &
-!! & jj:jj+id_rhoj ) )
-!!
-!! ENDDO
-!! ENDDO
-!
-! END SELECT
-!
-! DEALLOCATE( dl_coarse )
-!
-! END SUBROUTINE interp__3D
-! !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE interp__2D( dd_value, dd_fill, &
- & id_detect, cd_method, &
- & id_rhoi, id_rhoj, &
- & ld_even, ld_discont )
-
- IMPLICIT NONE
- ! Argument
- REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value
- REAL(dp) , INTENT(IN ) :: dd_fill
- INTEGER(I4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect
- CHARACTER(LEN=*) , INTENT(IN ) :: cd_method
- INTEGER(I4) , INTENT(IN ) :: id_rhoi
- INTEGER(I4) , INTENT(IN ) :: id_rhoj
- LOGICAL , DIMENSION(:) , INTENT(IN ) :: ld_even
- LOGICAL , INTENT(IN ), OPTIONAL :: ld_discont
-
- ! local variable
- INTEGER(I4) :: il_xextra
- INTEGER(I4) :: il_yextra
- INTEGER(i4), DIMENSION(2) :: il_shape
- INTEGER(i4), DIMENSION(2) :: il_dim
-
- REAL(dp) :: dl_min
- REAL(dp) :: dl_max
- REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_coef
- REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_coarse
- REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_tmp
- REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_dfdx
- REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_dfdy
- REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_d2fdxy
-
- LOGICAL :: ll_discont
- ! loop indices
- INTEGER(i4) :: ji
- INTEGER(i4) :: jj
- INTEGER(i4) :: ii
- INTEGER(i4) :: ij
-
- !----------------------------------------------------------------
- ll_discont=.FALSE.
- IF( PRESENT(ld_discont) ) ll_discont=ld_discont
-
- CALL logger_debug("INTERP 2D: interpolation method "//TRIM(cd_method)//&
- & " discont "//TRIM(fct_str(ll_discont)) )
-
- il_shape(:)=SHAPE(dd_value)
-
- ! compute coarse grid dimension
- il_xextra=id_rhoi-1
- il_dim(1)=(il_shape(1)+il_xextra)/id_rhoi
-
- il_yextra=id_rhoj-1
- il_dim(2)=(il_shape(2)+il_yextra)/id_rhoj
-
- ALLOCATE( dl_coarse(il_dim(1),il_dim(2)) )
-
- ! value on coarse grid
- dl_coarse(:,:)=dd_value( 1:il_shape(1):id_rhoi, &
- & 1:il_shape(2):id_rhoj )
-
- SELECT CASE(TRIM(cd_method))
-
- CASE('cubic')
-
- ALLOCATE( dl_dfdx( il_dim(1),il_dim(2)), &
- & dl_dfdy( il_dim(1),il_dim(2)), &
- & dl_d2fdxy(il_dim(1),il_dim(2)) )
-
- ! compute derivative on coarse grid
- dl_dfdx(:,:)=extrap_deriv_2D(dl_coarse(:,:), dd_fill, 'I', ll_discont)
- dl_dfdy(:,:)=extrap_deriv_2D(dl_coarse(:,:), dd_fill, 'J', ll_discont)
-
- ! compute cross derivative on coarse grid
- dl_d2fdxy(:,:)=extrap_deriv_2D(dl_dfdx(:,:), dd_fill, 'J', ll_discont)
-
- ALLOCATE( dl_tmp(2,2) )
- ALLOCATE( dl_coef(16) )
-
- DO jj=1,il_shape(2)-1,id_rhoj
- ij=((jj-1)/id_rhoj)+1
- DO ji=1,il_shape(1)-1,id_rhoi
- ii=((ji-1)/id_rhoi)+1
-
- IF( ANY(dl_coarse(ii:ii+1,ij:ij+1)==dd_fill) .OR. &
- & ANY( dl_dfdx(ii:ii+1,ij:ij+1)==dd_fill) .OR. &
- & ANY( dl_dfdy(ii:ii+1,ij:ij+1)==dd_fill) .OR. &
- & ANY(dl_d2fdxy(ii:ii+1,ij:ij+1)==dd_fill) ) CYCLE
-
- dl_tmp(:,:)=dl_coarse(ii:ii+1,ij:ij+1)
- IF( ll_discont )THEN
-
- dl_min=MINVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill )
- dl_max=MAXVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill )
- IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
- WHERE( dl_tmp(:,:) < 0_dp )
- dl_tmp(:,:) = dl_tmp(:,:)+360._dp
- END WHERE
- ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
- WHERE( dl_tmp(:,:) > 180_dp )
- dl_tmp(:,:) = dl_tmp(:,:)-180._dp
- END WHERE
- ENDIF
- ENDIF
-
- ! compute bicubic coefficient
- dl_coef(:)=interp__2D_cubic_coef(dl_tmp(:,:),&
- & dl_dfdx( ii:ii+1,ij:ij+1),&
- & dl_dfdy( ii:ii+1,ij:ij+1),&
- & dl_d2fdxy( ii:ii+1,ij:ij+1),&
- & dd_fill )
-
- ! compute value on detetected point
- CALL interp__2D_cubic_fill(dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ), &
- & id_detect(ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ), &
- & dl_coef(:), dd_fill, &
- & ld_even(:), id_rhoi, id_rhoj )
-
- IF( ll_discont )THEN
- WHERE( dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ) >= 180._dp .AND. &
- & dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ) /= dd_fill )
- dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ) = &
- & dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ) - 360._dp
- END WHERE
- ENDIF
-
- ENDDO
- ENDDO
-
- DEALLOCATE(dl_coef)
- DEALLOCATE(dl_tmp )
-
- DEALLOCATE(dl_dfdx, &
- & dl_dfdy, &
- & dl_d2fdxy )
-
- CASE('nearest')
-
- DO jj=1,il_shape(2)-1,id_rhoj
- ij=((jj-1)/id_rhoj)+1
- DO ji=1,il_shape(1)-1,id_rhoi
- ii=((ji-1)/id_rhoi)+1
-
- ! compute value on detetected point
- CALL interp__2D_nearest_fill(dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ), &
- & id_detect(ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ) )
-
- ENDDO
- ENDDO
-
- CASE DEFAULT ! linear
-
- ALLOCATE( dl_coef(4) )
- ALLOCATE( dl_tmp(2,2) )
-
- DO jj=1,il_shape(2)-1,id_rhoj
- ij=((jj-1)/id_rhoj)+1
- DO ji=1,il_shape(1)-1,id_rhoi
- ii=((ji-1)/id_rhoi)+1
-
- IF( ANY(dl_coarse(ii:ii+1,ij:ij+1)==dd_fill ) ) CYCLE
-
- dl_tmp(:,:)=dl_coarse(ii:ii+1,ij:ij+1)
- IF( ll_discont )THEN
-
- dl_min=MINVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill )
- dl_max=MAXVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill )
- IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
- WHERE( dl_tmp(:,:) < 0_dp )
- dl_tmp(:,:) = dl_tmp(:,:)+360._dp
- END WHERE
- ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
- WHERE( dl_tmp(:,:) > 180_dp )
- dl_tmp(:,:) = dl_tmp(:,:)-180._dp
- END WHERE
- ENDIF
- ENDIF
-
- ! compute bilinear coefficient
- dl_coef(:)=interp__2D_linear_coef(dl_tmp(:,:), dd_fill)
-
- ! compute value on detetected point
- CALL interp__2D_linear_fill(dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ), &
- & id_detect(ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ), &
- & dl_coef(:), dd_fill, &
- & ld_even(:), id_rhoi, id_rhoj )
-
- IF( ll_discont )THEN
- WHERE( dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ) >= 180._dp .AND. &
- & dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ) /= dd_fill )
- dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ) = &
- & dd_value( ji:ji+id_rhoi, &
- & jj:jj+id_rhoj ) - 360._dp
- END WHERE
- ENDIF
-
- ENDDO
- ENDDO
-
- DEALLOCATE(dl_coef)
- DEALLOCATE(dl_tmp )
-
- END SELECT
-
- DEALLOCATE( dl_coarse )
-
- END SUBROUTINE interp__2D
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE interp__1D( dd_value, dd_fill, &
- & id_detect, cd_method, &
- & id_rhoi, &
- & ld_even, ld_discont )
- IMPLICIT NONE
- ! Argument
- REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_value
- REAL(dp) , INTENT(IN ) :: dd_fill
- INTEGER(I4) , DIMENSION(:), INTENT(INOUT) :: id_detect
- CHARACTER(LEN=*) , INTENT(IN ) :: cd_method
- INTEGER(I4) , INTENT(IN ) :: id_rhoi
- LOGICAL , INTENT(IN ) :: ld_even
- LOGICAL , INTENT(IN ), OPTIONAL :: ld_discont
-
- ! local variable
- INTEGER(i4), DIMENSION(1) :: il_shape
- INTEGER(i4), DIMENSION(1) :: il_dim
- INTEGER(I4) :: il_xextra
-
- REAL(dp) :: dl_min
- REAL(dp) :: dl_max
- REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_coarse
- REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_tmp
- REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_dfdx
-
- REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_coef
-
- LOGICAL :: ll_discont
-
- ! loop indices
- INTEGER(i4) :: ji
- INTEGER(i4) :: ii
- !----------------------------------------------------------------
- ll_discont=.FALSE.
- IF( PRESENT(ld_discont) ) ll_discont=ld_discont
-
- CALL logger_debug("INTERP 1D: interpolation method "//TRIM(cd_method)//&
- & " discont "//TRIM(fct_str(ll_discont)) )
-
- il_shape(:)=SHAPE(dd_value)
-
- il_xextra=id_rhoi-1
- il_dim(1)=(il_shape(1)+il_xextra)/id_rhoi
-
- ALLOCATE( dl_coarse(il_dim(1)) )
- ! value on coarse grid
- dl_coarse(:)=dd_value( 1:il_shape(1):id_rhoi )
-
- SELECT CASE(TRIM(cd_method))
-
- CASE('cubic')
-
- ALLOCATE( dl_dfdx( il_dim(1)) )
-
- ! compute derivative on coarse grid
- dl_dfdx(:)=extrap_deriv_1D(dl_coarse(:), dd_fill, ll_discont)
-
- ALLOCATE( dl_coef(4))
- ALLOCATE( dl_tmp(2) )
-
- DO ji=1,il_shape(1)-1,id_rhoi
- ii=((ji-1)/id_rhoi)+1
-
- IF( ANY( dl_tmp(:)==dd_fill ) .OR. &
- & ANY(dl_dfdx(:)==dd_fill ) ) CYCLE
-
- dl_tmp(:)=dl_coarse(ii:ii+1)
- IF( ll_discont )THEN
-
- dl_min=MINVAL( dl_tmp(:), dl_tmp(:)/=dd_fill )
- dl_max=MAXVAL( dl_tmp(:), dl_tmp(:)/=dd_fill )
- IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
- WHERE( dl_tmp(:) < 0_dp )
- dl_tmp(:) = dl_tmp(:)+360._dp
- END WHERE
- ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
- WHERE( dl_tmp(:) > 180_dp )
- dl_tmp(:) = dl_tmp(:)-180._dp
- END WHERE
- ENDIF
- ENDIF
-
- ! compute bicubic coefficient
- dl_coef(:)=interp__1D_cubic_coef(dl_tmp(:),&
- & dl_dfdx( ii:ii+1), &
- & dd_fill )
-
- ! compute value on detetected point
- CALL interp__1D_cubic_fill(dd_value( ji:ji+id_rhoi),&
- & id_detect(ji:ji+id_rhoi),&
- & dl_coef(:), dd_fill, &
- & ld_even, id_rhoi )
-
- IF( ll_discont )THEN
- WHERE( dd_value( ji:ji+id_rhoi ) >= 180._dp .AND. &
- & dd_value( ji:ji+id_rhoi ) /= dd_fill )
- dd_value( ji:ji+id_rhoi ) = &
- & dd_value( ji:ji+id_rhoi ) - 360._dp
- END WHERE
- ENDIF
-
- ENDDO
-
- DEALLOCATE(dl_coef)
- DEALLOCATE(dl_tmp )
-
- CASE('nearest')
-
- DO ji=1,il_shape(1)-1,id_rhoi
- ii=((ji-1)/id_rhoi)+1
-
- ! compute value on detetected point
- CALL interp__1D_nearest_fill(dd_value( ji:ji+id_rhoi), &
- & id_detect(ji:ji+id_rhoi) )
-
- ENDDO
-
- CASE DEFAULT ! linear
-
- ALLOCATE(dl_coef(2))
- ALLOCATE( dl_tmp(2) )
-
- DO ji=1,il_shape(1)-1,id_rhoi
- ii=((ji-1)/id_rhoi)+1
-
- IF( ANY(dl_coarse(ii:ii+1)==dd_fill ) ) CYCLE
-
- dl_tmp(:)=dl_coarse(ii:ii+1)
- IF( ll_discont )THEN
-
- dl_min=MINVAL( dl_tmp(:), dl_tmp(:)/=dd_fill )
- dl_max=MAXVAL( dl_tmp(:), dl_tmp(:)/=dd_fill )
- IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
- WHERE( dl_tmp(:) < 0_dp )
- dl_tmp(:) = dl_tmp(:)+360._dp
- END WHERE
- ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
- WHERE( dl_tmp(:) > 180_dp )
- dl_tmp(:) = dl_tmp(:)-180._dp
- END WHERE
- ENDIF
- ENDIF
-
- ! compute bilinear coefficient
- dl_coef(:)=interp__1D_linear_coef(dl_tmp(:), dd_fill)
-
- ! compute value on detetected point
- CALL interp__1D_linear_fill( dd_value( ji:ji+id_rhoi),&
- & id_detect(ji:ji+id_rhoi),&
- & dl_coef(:), dd_fill, &
- & ld_even, id_rhoi )
-
- IF( ll_discont )THEN
- WHERE( dd_value( ji:ji+id_rhoi ) >= 180._dp .AND. &
- & dd_value( ji:ji+id_rhoi ) /= dd_fill )
- dd_value( ji:ji+id_rhoi ) = &
- & dd_value( ji:ji+id_rhoi ) - 360._dp
- END WHERE
- ENDIF
-
- ENDDO
-
- DEALLOCATE(dl_coef)
-
- END SELECT
-
- DEALLOCATE( dl_coarse )
-
- END SUBROUTINE interp__1D
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- FUNCTION interp__2D_cubic_coef( dd_value, &
- & dd_dfdx, &
- & dd_dfdy, &
- & dd_d2fdxy,&
- & dd_fill )
- IMPLICIT NONE
- ! Argument
- REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_value
- REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_dfdx
- REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_dfdy
- REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_d2fdxy
- REAL(dp) , INTENT(IN) :: dd_fill
-
- ! function
- REAL(dp), DIMENSION(16) :: interp__2D_cubic_coef
-
- ! local variable
- REAL(dp), DIMENSION(16,16), PARAMETER :: dp_matrix = RESHAPE( &
- & (/ 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,&
- 0 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,&
- -3 , 3 , 0 , 0 ,-2 ,-1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,&
- 2 ,-2 , 0 , 0 , 1 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,&
- 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,&
- 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 0 , 0 ,&
- 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,-3 , 3 , 0 , 0 ,-2 ,-1 , 0 , 0 ,&
- 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 2 ,-2 , 0 , 0 , 1 , 1 , 0 , 0 ,&
- -3 , 0 , 3 , 0 , 0 , 0 , 0 , 0 ,-2 , 0 ,-1 , 0 , 0 , 0 , 0 , 0 ,&
- 0 , 0 , 0 , 0 ,-3 , 0 , 3 , 0 , 0 , 0 , 0 , 0 ,-2 , 0 ,-1 , 0 ,&
- 9 ,-9 ,-9 , 9 , 6 , 3 ,-6 ,-3 , 6 ,-6 , 3 ,-3 , 4 , 2 , 2 , 1 ,&
- -6 , 6 , 6 ,-6 ,-3 ,-3 , 3 , 3 ,-4 , 4 ,-2 , 2 ,-2 ,-2 ,-1 ,-1 ,&
- 2 , 0 ,-2 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 ,&
- 0 , 0 , 0 , 0 , 2 , 0 ,-2 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 1 , 0 ,&
- -6 , 6 , 6 ,-6 ,-4 ,-2 , 4 , 2 ,-3 , 3 ,-3 , 3 ,-2 ,-1 ,-2 ,-1 ,&
- 4 ,-4 ,-4 , 4 , 2 , 2 ,-2 ,-2 , 2 ,-2 , 2 ,-2 , 1 , 1 , 1 , 1 /), &
- & (/ 16, 16 /) )
-
- REAL(dp), DIMENSION(16) :: dl_vect
-
- !----------------------------------------------------------------
- ! init
- interp__2D_cubic_coef(:)=dd_fill
-
- IF( ANY(SHAPE( dd_value(:,:))/= 2) .OR. &
- & ANY(SHAPE( dd_dfdx(:,:))/= 2) .OR. &
- & ANY(SHAPE( dd_dfdy(:,:))/= 2) .OR. &
- & ANY(SHAPE(dd_d2fdxy(:,:))/= 2) )THEN
-
- CALL logger_error("INTERP CUBIC COEF: invalid dimension of "//&
- & "input tables. shape should be (/2,2/)")
-
- ELSEIF( ANY( dd_value(:,:) == dd_fill) .OR. &
- & ANY( dd_dfdx(:,:) == dd_fill) .OR. &
- & ANY( dd_dfdy(:,:) == dd_fill) .OR. &
- & ANY(dd_d2fdxy(:,:) == dd_fill) )THEN
-
- CALL logger_warn("INTERP CUBIC COEF: fill value detected. "//&
- & "can not compute coefficient ")
-
- ELSE
-
- dl_vect( 1: 4)=PACK(dd_value(:,:),.TRUE. )
- dl_vect( 5: 8)=PACK(dd_dfdx(:,:),.TRUE. )
- dl_vect( 9:12)=PACK(dd_dfdy(:,:),.TRUE. )
- dl_vect(13:16)=PACK(dd_d2fdxy(:,:),.TRUE. )
-
- interp__2D_cubic_coef(:)=MATMUL(TRANSPOSE(dp_matrix(:,:)),dl_vect(:))
-
- ENDIF
- END FUNCTION interp__2D_cubic_coef
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE interp__2D_cubic_fill( dd_value, id_detect, dd_coef, dd_fill, &
- & ld_even, id_rhoi, id_rhoj )
- IMPLICIT NONE
- ! Argument
- REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value
- INTEGER(i4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect
- REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_coef
- REAL(dp) , INTENT(IN ) :: dd_fill
- LOGICAL , DIMENSION(:), INTENT(IN ) :: ld_even
- INTEGER(I4) , INTENT(IN ) :: id_rhoi
- INTEGER(I4) , INTENT(IN ) :: id_rhoj
-
- ! local variable
- INTEGER(i4), DIMENSION(2) :: il_shape
-
- REAL(dp) , DIMENSION(16) :: dl_vect
- REAL(dp) :: dl_dx
- REAL(dp) :: dl_dy
- REAL(dp) :: dl_x
- REAL(dp) :: dl_x2
- REAL(dp) :: dl_x3
- REAL(dp) :: dl_y
- REAL(dp) :: dl_y2
- REAL(dp) :: dl_y3
-
- ! loop indices
- INTEGER(i4) :: ji
- INTEGER(i4) :: jj
- !----------------------------------------------------------------
-
- IF( SIZE(dd_coef(:)) /= 16 )THEN
- CALL logger_error("INTERP CUBIC FILL: invalid dimension of "//&
- & "coef table. shape should be (/16/)")
- ELSEIF( ANY( dd_coef(:)==dd_fill ) )THEN
- CALL logger_error("INTERP CUBIC FILL: fill value detected in coef . "//&
- & "can not compute interpolation.")
- ELSE
-
- il_shape(:)=SHAPE(dd_value(:,:))
-
- dl_dx=1./REAL(id_rhoi)
- dl_dy=1./REAL(id_rhoj)
-
- DO jj=1,il_shape(2)
-
- IF( ld_even(2) )THEN
- dl_y=(jj-1)*dl_dy - dl_dy*0.5
- ELSE ! odd refinement
- dl_y=(jj-1)*dl_dy
- ENDIF
- dl_y2=dl_y*dl_y
- dl_y3=dl_y2*dl_y
-
- DO ji=1,il_shape(1)
-
- IF(id_detect(ji,jj)==1)THEN
-
- IF( ld_even(1) )THEN
- dl_x=(ji-1)*dl_dx - dl_dx*0.5
- ELSE ! odd refinement
- dl_x=(ji-1)*dl_dx
- ENDIF
- dl_x2=dl_x*dl_x
- dl_x3=dl_x2*dl_x
-
- dl_vect(:)=(/1._dp, dl_x , dl_x2 , dl_x3 , &
- & dl_y , dl_x*dl_y , dl_x2*dl_y , dl_x3*dl_y , &
- & dl_y2, dl_x*dl_y2, dl_x2*dl_y2, dl_x3*dl_y2, &
- & dl_y3, dl_x*dl_y3, dl_x2*dl_y3, dl_x3*dl_y3 /)
-
- dd_value(ji,jj)=DOT_PRODUCT(dd_coef(:),dl_vect(:))
- id_detect(ji,jj)=0
-
- ENDIF
-
- ENDDO
- ENDDO
-
- ENDIF
-
- END SUBROUTINE interp__2D_cubic_fill
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- FUNCTION interp__2D_linear_coef( dd_value, dd_fill )
- IMPLICIT NONE
- ! Argument
- REAL(dp), DIMENSION(:,:) , INTENT(IN) :: dd_value
- REAL(dp) , INTENT(IN) :: dd_fill
-
- ! function
- REAL(dp), DIMENSION(4) :: interp__2D_linear_coef
-
- ! local variable
-
- REAL(dp), DIMENSION(4,4), PARAMETER :: dp_matrix = RESHAPE( &
- & (/ 1 , 0 , 0 , 0 ,&
- -1 , 1 , 0 , 0 ,&
- -1 , 0 , 1 , 0 ,&
- 1 ,-1 ,-1 , 1 /), &
- & (/ 4, 4 /) )
-
- REAL(dp), DIMENSION(4) :: dl_vect
-
- !----------------------------------------------------------------
-
- IF( ANY(SHAPE(dd_value(:,:))/= 2) )THEN
- CALL logger_error("INTERP LINEAR COEF: invalid dimension of "//&
- & "input tables. shape should be (/2,2/)")
- ELSEIF( ANY(dd_value(:,:)==dd_fill) )THEN
- CALL logger_error("INTERP LINEAR COEF: fill value detected. "//&
- & "can not compute coefficient.")
- ELSE
-
- dl_vect( 1: 4)=PACK(dd_value(:,:),.TRUE. )
-
- interp__2D_linear_coef(:)=MATMUL(TRANSPOSE(dp_matrix(:,:)),dl_vect(:))
-
- ENDIF
- END FUNCTION interp__2D_linear_coef
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE interp__2D_linear_fill( dd_value, id_detect, dd_coef, dd_fill, &
- & ld_even, id_rhoi, id_rhoj )
- IMPLICIT NONE
- ! Argument
- REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value
- INTEGER(i4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect
- REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_coef
- REAL(dp) , INTENT(IN ) :: dd_fill
- LOGICAL , DIMENSION(:), INTENT(IN ) :: ld_even
- INTEGER(I4) , INTENT(IN ) :: id_rhoi
- INTEGER(I4) , INTENT(IN ) :: id_rhoj
-
- ! local variable
- INTEGER(i4), DIMENSION(2) :: il_shape
-
- REAL(dp) , DIMENSION(4) :: dl_vect
- REAL(dp) :: dl_dx
- REAL(dp) :: dl_dy
- REAL(dp) :: dl_x
- REAL(dp) :: dl_y
-
- ! loop indices
- INTEGER(i4) :: ji
- INTEGER(i4) :: jj
- !----------------------------------------------------------------
-
- IF( SIZE(dd_coef(:)) /= 4 )THEN
- CALL logger_error("INTERP LINEAR FILL: invalid dimension of "//&
- & "coef table. shape should be (/4/)")
- ELSEIF( ANY( dd_coef(:)==dd_fill ) )THEN
- CALL logger_error("INTERP LINEAR FILL: fill value detected in coef. "//&
- & "can not compute interpolation.")
- ELSE
-
- il_shape(:)=SHAPE(dd_value(:,:))
-
- dl_dx=1./REAL(id_rhoi)
- dl_dy=1./REAL(id_rhoj)
-
- DO jj=1,il_shape(2)
-
- IF( ld_even(2) )THEN
- dl_y=(jj-1)*dl_dy - dl_dy*0.5
- ELSE ! odd refinement
- dl_y=(jj-1)*dl_dy
- ENDIF
-
- DO ji=1,il_shape(1)
-
- IF(id_detect(ji,jj)==1)THEN
-
- IF( ld_even(1) )THEN
- dl_x=(ji-1)*dl_dx - dl_dx*0.5
- ELSE ! odd refinement
- dl_x=(ji-1)*dl_dx
- ENDIF
-
- dl_vect(:)=(/1._dp, dl_x, dl_y, dl_x*dl_y /)
-
- dd_value(ji,jj)=DOT_PRODUCT(dd_coef(:),dl_vect(:))
- id_detect(ji,jj)=0
-
- ENDIF
-
- ENDDO
- ENDDO
-
- ENDIF
-
- END SUBROUTINE interp__2D_linear_fill
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE interp__2D_nearest_fill( dd_value, id_detect )
- IMPLICIT NONE
- ! Argument
- REAL(dp) , DIMENSION(:,:) , INTENT(INOUT) :: dd_value
- INTEGER(i4), DIMENSION(:,:) , INTENT(INOUT) :: id_detect
-
- ! local variable
- INTEGER(i4), DIMENSION(2) :: il_shape
-
- INTEGER(i4) :: il_i1
- INTEGER(i4) :: il_i2
- INTEGER(i4) :: il_j1
- INTEGER(i4) :: il_j2
-
- INTEGER(i4) :: il_half1
- INTEGER(i4) :: il_half2
-
- ! loop indices
- INTEGER(i4) :: ji
- INTEGER(i4) :: jj
- !----------------------------------------------------------------
-
- il_shape(:)=SHAPE(dd_value(:,:))
-
- il_i1=1
- il_i2=il_shape(1)
-
- il_j1=1
- il_j2=il_shape(2)
-
- il_half1=CEILING(il_shape(1)*0.5)
- il_half2=CEILING(il_shape(2)*0.5)
-
- DO jj=1,il_half2
-
- DO ji=1,il_half1
-
- ! lower left point
- IF(id_detect(ji,jj)==1)THEN
-
- dd_value( ji,jj)=dd_value(il_i1,il_j1)
- id_detect(ji,jj)=0
-
- ENDIF
-
- ! lower right point
- IF(id_detect(il_shape(1)-ji+1,jj)==1)THEN
-
- dd_value( il_shape(1)-ji+1,jj)=dd_value(il_i2,il_j1)
- id_detect(il_shape(1)-ji+1,jj)=0
-
- ENDIF
-
- ! upper left point
- IF(id_detect(ji,il_shape(2)-jj+1)==1)THEN
-
- dd_value( ji,il_shape(2)-jj+1)=dd_value(il_i1,il_j2)
- id_detect(ji,il_shape(2)-jj+1)=0
-
- ENDIF
-
- ! upper right point
- IF(id_detect(il_shape(1)-ji+1,il_shape(2)-jj+1)==1)THEN
-
- dd_value( il_shape(1)-ji+1,il_shape(2)-jj+1)=dd_value(il_i2,il_j2)
- id_detect(il_shape(1)-ji+1,il_shape(2)-jj+1)=0
-
- ENDIF
-
- ENDDO
-
- ENDDO
-
- END SUBROUTINE interp__2D_nearest_fill
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- FUNCTION interp__1D_cubic_coef( dd_value, &
- & dd_dfdx, &
- & dd_fill )
- IMPLICIT NONE
- ! Argument
- REAL(dp), DIMENSION(:) , INTENT(IN) :: dd_value
- REAL(dp), DIMENSION(:) , INTENT(IN) :: dd_dfdx
- REAL(dp) , INTENT(IN) :: dd_fill
-
- ! function
- REAL(dp), DIMENSION(4) :: interp__1D_cubic_coef
-
- ! local variable
-
- REAL(dp), DIMENSION(4,4), PARAMETER :: dp_matrix = RESHAPE( &
- & (/ 1 , 0 , 0 , 0 ,&
- -1 , 1 , 0 , 0 ,&
- -3 , 3 ,-2 ,-1 ,&
- 2 ,-2 , 1 , 1 /), &
- & (/ 4, 4 /) )
-
- REAL(dp), DIMENSION(4) :: dl_vect
-
- !----------------------------------------------------------------
- IF( SIZE(dd_value(:))/= 2 .OR. &
- & SIZE(dd_dfdx(:) )/= 2 )THEN
-
- CALL logger_error("INTERP CUBIC COEF: invalid dimension of "//&
- & "input tables. shape should be (/2,2/)")
-
- ELSEIF( ANY(dd_value(:)==dd_fill) .OR. &
- & ANY( dd_dfdx(:)==dd_fill) )THEN
- CALL logger_error("INTERP CUBIC COEF: fill value detected. "//&
- & "can not compute coefficient.")
- ELSE
-
- dl_vect( 1: 2)=PACK(dd_value(:),.TRUE. )
- dl_vect( 3: 4)=PACK(dd_dfdx(:),.TRUE. )
-
- interp__1D_cubic_coef(:)=MATMUL(TRANSPOSE(dp_matrix(:,:)),dl_vect(:))
-
- ENDIF
-
- END FUNCTION interp__1D_cubic_coef
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE interp__1D_cubic_fill( dd_value, id_detect, dd_coef, dd_fill, &
- & ld_even, id_rhoi )
- IMPLICIT NONE
- ! Argument
- REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_value
- INTEGER(i4) , DIMENSION(:), INTENT(INOUT) :: id_detect
- REAL(dp) , DIMENSION(:), INTENT(IN ) :: dd_coef
- REAL(dp) , INTENT(IN ) :: dd_fill
- LOGICAL , INTENT(IN ) :: ld_even
- INTEGER(I4) , INTENT(IN ) :: id_rhoi
-
- ! local variable
- INTEGER(i4), DIMENSION(1) :: il_shape
-
- REAL(dp) , DIMENSION(4) :: dl_vect
- REAL(dp) :: dl_dx
- REAL(dp) :: dl_x
- REAL(dp) :: dl_x2
- REAL(dp) :: dl_x3
-
- ! loop indices
- INTEGER(i4) :: ji
- !----------------------------------------------------------------
-
- IF( SIZE(dd_coef(:)) /= 4 )THEN
- CALL logger_error("INTERP CUBIC FILL: invalid dimension of "//&
- & "coef table. shape should be (/4/)")
- !ELSEIF( ANY(dd_value(:)==dd_fill .AND. id_detect(:)==0 ) .OR. &
- ELSEIF( ANY( dd_coef(:)==dd_fill ) )THEN
- CALL logger_error("INTERP CUBIC FILL: fill value detected. "//&
- & "can not compute interpolation")
- ELSE
-
- il_shape(:)=SHAPE(dd_value(:))
-
- dl_dx=1./REAL(id_rhoi)
-
- DO ji=1,il_shape(1)
-
- IF(id_detect(ji)==1)THEN
-
- IF( ld_even )THEN
- dl_x=(ji-1)*dl_dx - dl_dx*0.5
- ELSE ! odd refinement
- dl_x=(ji-1)*dl_dx
- ENDIF
- dl_x2=dl_x*dl_x
- dl_x3=dl_x2*dl_x
-
- dl_vect(:)=(/1._dp, dl_x, dl_x2, dl_x3 /)
-
- dd_value(ji)=DOT_PRODUCT(dd_coef(:),dl_vect(:))
- id_detect(ji)=0
-
- ENDIF
-
- ENDDO
-
- ENDIF
-
- END SUBROUTINE interp__1D_cubic_fill
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- FUNCTION interp__1D_linear_coef( dd_value, dd_fill )
- IMPLICIT NONE
- ! Argument
- REAL(dp), DIMENSION(:) , INTENT(IN) :: dd_value
- REAL(dp) , INTENT(IN) :: dd_fill
-
- ! function
- REAL(dp), DIMENSION(2) :: interp__1D_linear_coef
-
- ! local variable
-
- REAL(dp), DIMENSION(2,2), PARAMETER :: dp_matrix = RESHAPE( &
- & (/ 1 , 0 ,&
- -1 , 1 /), &
- & (/ 2, 2 /) )
-
- REAL(dp), DIMENSION(2) :: dl_vect
-
- !----------------------------------------------------------------
-
- IF( ANY(SHAPE(dd_value(:))/= 2) )THEN
- CALL logger_error("INTERP LINEAR COEF: invalid dimension of "//&
- & "input tables. shape should be (/2/)")
- ELSEIF( ANY(dd_value(:)==dd_fill) )THEN
- CALL logger_error("INTERP LINEAR COEF: fill value detected. "//&
- & "can not compute coefficient.")
- ELSE
-
- dl_vect( 1: 2)=PACK(dd_value(:),.TRUE. )
-
- interp__1D_linear_coef(:)=MATMUL(TRANSPOSE(dp_matrix(:,:)),dl_vect(:))
-
- ENDIF
-
- END FUNCTION interp__1D_linear_coef
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE interp__1D_linear_fill( dd_value, id_detect, dd_coef, dd_fill, &
- & ld_even, id_rhoi )
- IMPLICIT NONE
- ! Argument
- REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_value
- INTEGER(i4) , DIMENSION(:), INTENT(INOUT) :: id_detect
- REAL(dp) , DIMENSION(:), INTENT(IN ) :: dd_coef
- REAL(dp) , INTENT(IN ) :: dd_fill
- LOGICAL , INTENT(IN ) :: ld_even
- INTEGER(I4) , INTENT(IN ) :: id_rhoi
-
- ! local variable
- INTEGER(i4), DIMENSION(1) :: il_shape
-
- REAL(dp) , DIMENSION(2) :: dl_vect
- REAL(dp) :: dl_dx
- REAL(dp) :: dl_x
-
- ! loop indices
- INTEGER(i4) :: ji
- !----------------------------------------------------------------
-
- IF( SIZE(dd_coef(:)) /= 2 )THEN
- CALL logger_error("INTERP LINEAR FILL: invalid dimension of "//&
- & "coef table. shape should be (/2/)")
- !ELSEIF( ANY(dd_value(:)==dd_fill .AND. id_detect(:)==0 ) .OR. &
- ELSEIF( ANY( dd_coef(:)==dd_fill ) )THEN
- CALL logger_error("INTERP LINEAR FILL: fill value detected. "//&
- & "can not compute interpolation")
- ELSE
-
- il_shape(:)=SHAPE(dd_value)
-
- dl_dx=1./REAL(id_rhoi)
-
- DO ji=1,il_shape(1)
-
- IF(id_detect(ji)==1)THEN
-
- IF( ld_even )THEN
- dl_x=(ji-1)*dl_dx - dl_dx*0.5
- ELSE ! odd refinement
- dl_x=(ji-1)*dl_dx
- ENDIF
-
- dl_vect(:)=(/1._dp, dl_x /)
-
- dd_value(ji)=DOT_PRODUCT(dd_coef(:),dl_vect(:))
- id_detect(ji)=0
-
- ENDIF
-
- ENDDO
-
- ENDIF
-
- END SUBROUTINE interp__1D_linear_fill
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief
- !> This subroutine
- !>
- !> @details
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
- !> @param[out]
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE interp__1D_nearest_fill( dd_value, id_detect )
- IMPLICIT NONE
- ! Argument
- REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_value
- INTEGER(i4), DIMENSION(:), INTENT(INOUT) :: id_detect
-
- ! local variable
- INTEGER(i4), DIMENSION(1) :: il_shape
-
- INTEGER(i4) :: il_i1
- INTEGER(i4) :: il_i2
-
- INTEGER(i4) :: il_half1
-
- ! loop indices
- INTEGER(i4) :: ji
- !----------------------------------------------------------------
-
- il_shape(:)=SHAPE(dd_value)
-
- il_i1=1
- il_i2=il_shape(1)
-
- il_half1=CEILING(il_shape(1)*0.5)
-
- DO ji=1,il_half1
-
- ! lower left point
- IF(id_detect(ji)==1)THEN
-
- dd_value( ji)=dd_value(il_i1)
- id_detect(ji)=0
-
- ENDIF
-
- ! lower right point
- IF(id_detect(il_shape(1)-ji+1)==1)THEN
-
- dd_value( il_shape(1)-ji+1)=dd_value(il_i2)
- id_detect(il_shape(1)-ji+1)=0
-
- ENDIF
-
- ENDDO
-
- END SUBROUTINE interp__1D_nearest_fill
- !> @endcode
END MODULE interp
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp_cubic.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp_cubic.f90 (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp_cubic.f90 (revision 5214)
@@ -0,0 +1,783 @@
+!----------------------------------------------------------------------
+! NEMO system team, System and Interface for oceanic RElocable Nesting
+!----------------------------------------------------------------------
+!
+! MODULE: interp
+!
+! DESCRIPTION:
+!> @brief
+!> This module manage cubic interpolation on regular grid.
+!>
+!>
+!> @details
+!> to compute cubic interpolation:
+!> @code
+!> CALL interp_cubic_fill(dd_value, dd_fill, id_detect, id_rho, ld_even [,ld_discont] )
+!> @endcode
+!> - dd_value is 2D array of variable value
+!> - dd_fill is the FillValue of variable
+!> - id_detect is 2D array of point to be interpolated (see interp module)
+!> - id_rho is array of refinment factor
+!> - ld_even indicates even refinment or not
+!> - ld_discont indicates longitudinal discontinuity (-180°/180°, 0°/360°) or not
+!>
+!> @author
+!> J.Paul
+! REVISION HISTORY:
+!> @date September, 2014 -Initial version
+!>
+!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+!----------------------------------------------------------------------
+MODULE interp_cubic
+
+ USE netcdf ! nf90 library
+ USE global ! global variable
+ USE kind ! F90 kind parameter
+ USE logger ! log file manager
+ USE fct ! basic useful function
+ USE extrap ! extrapolation manager
+
+ IMPLICIT NONE
+ ! NOTE_avoid_public_variables_if_possible
+
+ ! type and variable
+
+ ! function and subroutine
+ PUBLIC :: interp_cubic_fill !< compute interpolation using cubic method
+
+ PRIVATE :: interp_cubic__2D !< compute bicubic interpolation on 2D gid
+ PRIVATE :: interp_cubic__1D !< compute cubic interpolation on 1D gid
+ PRIVATE :: interp_cubic__2D_coef !< compute coefficient for bicubic interpolation
+ PRIVATE :: interp_cubic__2D_fill !< fill value using bicubic interpolation
+ PRIVATE :: interp_cubic__1D_coef !< compute coefficient for cubic interpolation
+ PRIVATE :: interp_cubic__1D_fill !< fill value using cubic interpolation
+ PRIVATE :: interp_cubic__get_weight2D !< compute interpoaltion weight for 2D array
+ PRIVATE :: interp_cubic__get_weight1D !< compute interpoaltion weight for 1D array
+
+CONTAINS
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute horizontal cubic interpolation on 4D array of value.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 2D array of variable value
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[inout] id_detect 2D array of point to be interpolated
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_cubic_fill(dd_value, dd_fill, id_detect, &
+ & id_rho, ld_even, ld_discont )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value
+ REAL(dp) , INTENT(IN ) :: dd_fill
+ INTEGER(I4) , DIMENSION(:,:,:) , INTENT(INOUT) :: id_detect
+ INTEGER(I4) , DIMENSION(:) , INTENT(IN ) :: id_rho
+ LOGICAL , DIMENSION(:) , INTENT(IN ) :: ld_even
+ LOGICAL , INTENT(IN ), OPTIONAL :: ld_discont
+
+ ! local variable
+ INTEGER(i4), DIMENSION(4) :: il_shape
+
+ LOGICAL :: ll_discont
+
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_IJ
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_I
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_J
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ INTEGER(i4) :: jk
+ INTEGER(i4) :: jl
+ !----------------------------------------------------------------
+ ll_discont=.FALSE.
+ IF( PRESENT(ld_discont) ) ll_discont=ld_discont
+
+ il_shape(:)=SHAPE(dd_value)
+
+ ! compute vect2D
+ ALLOCATE(dl_weight_IJ(16,((id_rho(jp_I)+1)*(id_rho(jp_J)+1))) )
+ CALL interp_cubic__get_weight2D(dl_weight_IJ(:,:), &
+ & id_rho(:), ld_even(:))
+
+ ALLOCATE( dl_weight_I( 4,((id_rho(jp_I)+1) )) )
+ ALLOCATE( dl_weight_J( 4,( (id_rho(jp_J)+1))) )
+ CALL interp_cubic__get_weight1D(dl_weight_I(:,:), &
+ & id_rho(jp_I), ld_even(jp_I))
+ CALL interp_cubic__get_weight1D(dl_weight_J(:,:), &
+ & id_rho(jp_J), ld_even(jp_J))
+
+ DO jl=1,il_shape(4)
+ ! loop on vertical level
+ DO jk=1,il_shape(3)
+
+ ! I-J plan
+ CALL interp_cubic__2D(dd_value(:,:,jk,jl), dd_fill, &
+ & id_detect(:,:,jk), &
+ & dl_weight_IJ(:,:), &
+ & id_rho(jp_I), id_rho(jp_J), &
+ & ll_discont)
+ IF( ANY(id_detect(:,:,jk)==1) )THEN
+ ! I direction
+ DO jj=1,il_shape(2)
+ CALL interp_cubic__1D( dd_value(:,jj,jk,jl), dd_fill, &
+ & id_detect(:,jj,jk), &
+ & dl_weight_I(:,:), &
+ & id_rho(jp_I), ll_discont )
+ ENDDO
+ IF( ALL(id_detect(:,:,jk)==0) )THEN
+ CYCLE
+ ELSE
+ ! J direction
+ DO ji=1,il_shape(1)
+ CALL interp_cubic__1D( dd_value(ji,:,jk,jl), dd_fill, &
+ & id_detect(ji,:,jk), &
+ & dl_weight_J(:,:), &
+ & id_rho(jp_J), ll_discont )
+ ENDDO
+ ENDIF
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ DEALLOCATE(dl_weight_IJ)
+ DEALLOCATE(dl_weight_I)
+ DEALLOCATE(dl_weight_J)
+
+ END SUBROUTINE interp_cubic_fill
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute cubic interpolation on 2D array of value.
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 2D array of variable value
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[inout] id_detect 2D array of point to be interpolated
+ !> @param[in] id_rhoi refinment factor in i-direction
+ !> @param[in] id_rhoj refinment factor in j-direction
+ !> @param[in] id_rhok refinment factor in k-direction
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_cubic__2D( dd_value, dd_fill, &
+ & id_detect, &
+ & dd_weight, &
+ & id_rhoi, id_rhoj, &
+ & ld_discont )
+
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value
+ REAL(dp) , INTENT(IN ) :: dd_fill
+ INTEGER(I4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect
+ REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight
+ INTEGER(I4) , INTENT(IN ) :: id_rhoi
+ INTEGER(I4) , INTENT(IN ) :: id_rhoj
+ LOGICAL , INTENT(IN ) :: ld_discont
+
+ ! local variable
+ INTEGER(I4) :: il_xextra
+ INTEGER(I4) :: il_yextra
+ INTEGER(i4), DIMENSION(2) :: il_shape
+ INTEGER(i4), DIMENSION(2) :: il_dim
+
+ REAL(dp) :: dl_min
+ REAL(dp) :: dl_max
+ REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_coef
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_coarse
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_tmp
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_dfdx
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_dfdy
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_d2fdxy
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ INTEGER(i4) :: ii
+ INTEGER(i4) :: ij
+
+ !----------------------------------------------------------------
+
+ IF( ANY(id_detect(:,:)==1) )THEN
+ il_shape(:)=SHAPE(dd_value)
+
+ ! compute coarse grid dimension
+ il_xextra=id_rhoi-1
+ il_dim(1)=(il_shape(1)+il_xextra)/id_rhoi
+
+ il_yextra=id_rhoj-1
+ il_dim(2)=(il_shape(2)+il_yextra)/id_rhoj
+
+ ALLOCATE( dl_coarse(il_dim(1),il_dim(2)) )
+
+ ! value on coarse grid
+ dl_coarse(:,:)=dd_value( 1:il_shape(1):id_rhoi, &
+ & 1:il_shape(2):id_rhoj )
+
+ ALLOCATE( dl_dfdx( il_dim(1),il_dim(2)), &
+ & dl_dfdy( il_dim(1),il_dim(2)), &
+ & dl_d2fdxy(il_dim(1),il_dim(2)) )
+
+ ! compute derivative on coarse grid
+ dl_dfdx(:,:)=extrap_deriv_2D(dl_coarse(:,:), dd_fill, 'I', ld_discont)
+ dl_dfdy(:,:)=extrap_deriv_2D(dl_coarse(:,:), dd_fill, 'J', ld_discont)
+
+ ! compute cross derivative on coarse grid
+ dl_d2fdxy(:,:)=extrap_deriv_2D(dl_dfdx(:,:), dd_fill, 'J', ld_discont)
+
+ ALLOCATE( dl_tmp(2,2) )
+ ALLOCATE( dl_coef(16) )
+
+ DO jj=1,il_shape(2)-1,id_rhoj
+ ij=((jj-1)/id_rhoj)+1
+ DO ji=1,il_shape(1)-1,id_rhoi
+ ii=((ji-1)/id_rhoi)+1
+
+ ! check if point to be interpolated
+ IF( ALL(id_detect(ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj)==0) ) CYCLE
+ ! check data needed to interpolate
+ IF( ANY(dl_coarse(ii:ii+1,ij:ij+1)==dd_fill) .OR. &
+ & ANY( dl_dfdx(ii:ii+1,ij:ij+1)==dd_fill) .OR. &
+ & ANY( dl_dfdy(ii:ii+1,ij:ij+1)==dd_fill) .OR. &
+ & ANY(dl_d2fdxy(ii:ii+1,ij:ij+1)==dd_fill) ) CYCLE
+
+ dl_tmp(:,:)=dl_coarse(ii:ii+1,ij:ij+1)
+ ! check longitude discontinuity
+ IF( ld_discont )THEN
+
+ dl_min=MINVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill )
+ dl_max=MAXVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill )
+ IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
+ WHERE( dl_tmp(:,:) < 0_dp )
+ dl_tmp(:,:) = dl_tmp(:,:)+360._dp
+ END WHERE
+ ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
+ WHERE( dl_tmp(:,:) > 180_dp )
+ dl_tmp(:,:) = dl_tmp(:,:)-180._dp
+ END WHERE
+ ENDIF
+
+ ENDIF
+
+ ! compute bicubic coefficient
+ dl_coef(:)=interp_cubic__2D_coef(dl_tmp(:,:),&
+ & dl_dfdx( ii:ii+1,ij:ij+1),&
+ & dl_dfdy( ii:ii+1,ij:ij+1),&
+ & dl_d2fdxy(ii:ii+1,ij:ij+1),&
+ & dd_fill )
+
+ ! compute value on detetected point
+ CALL interp_cubic__2D_fill(dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ), &
+ & id_detect(ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ), &
+ & dd_weight(:,:), dl_coef(:),&
+ & dd_fill, id_rhoi, id_rhoj )
+
+ IF( ld_discont )THEN
+ WHERE( dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ) >= 180._dp .AND. &
+ & dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ) /= dd_fill )
+ dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ) = &
+ & dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ) - 360._dp
+ END WHERE
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ DEALLOCATE(dl_coef)
+ DEALLOCATE(dl_tmp )
+
+ DEALLOCATE(dl_dfdx, &
+ & dl_dfdy, &
+ & dl_d2fdxy )
+
+ DEALLOCATE( dl_coarse )
+ ENDIF
+
+ END SUBROUTINE interp_cubic__2D
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute cubic interpolation on 1D array of value.
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 1D array of variable value
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[inout] id_detect 1D array of point to be interpolated
+ !> @param[in] id_rhoi refinment factor
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_cubic__1D( dd_value, dd_fill, &
+ & id_detect, &
+ & dd_weight, &
+ & id_rhoi, &
+ & ld_discont )
+
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:) , INTENT(INOUT) :: dd_value
+ REAL(dp) , INTENT(IN ) :: dd_fill
+ INTEGER(I4) , DIMENSION(:) , INTENT(INOUT) :: id_detect
+ REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight
+ INTEGER(I4) , INTENT(IN ) :: id_rhoi
+ LOGICAL , INTENT(IN ) :: ld_discont
+
+ ! local variable
+ INTEGER(I4) :: il_xextra
+ INTEGER(i4), DIMENSION(1) :: il_shape
+ INTEGER(i4), DIMENSION(1) :: il_dim
+
+ REAL(dp) :: dl_min
+ REAL(dp) :: dl_max
+ REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_coef
+ REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_coarse
+ REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_tmp
+ REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_dfdx
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: ii
+
+ !----------------------------------------------------------------
+
+ IF( ANY(id_detect(:)==1) )THEN
+ il_shape(:)=SHAPE(dd_value)
+
+ ! compute coarse grid dimension
+ il_xextra=id_rhoi-1
+ il_dim(1)=(il_shape(1)+il_xextra)/id_rhoi
+
+ ALLOCATE( dl_coarse(il_dim(1)) )
+
+ ! value on coarse grid
+ dl_coarse(:)=dd_value( 1:il_shape(1):id_rhoi )
+
+ ALLOCATE( dl_dfdx(il_dim(1)) )
+
+ ! compute derivative on coarse grid
+ dl_dfdx(:)=extrap_deriv_1D(dl_coarse(:), dd_fill, ld_discont)
+
+ ALLOCATE( dl_tmp(2) )
+ ALLOCATE( dl_coef(4) )
+
+ DO ji=1,il_shape(1)-1,id_rhoi
+ ii=((ji-1)/id_rhoi)+1
+
+ ! check if point to be interpolated
+ IF( ALL(id_detect(ji:ji+id_rhoi)==0) ) CYCLE
+ ! check data needed to interpolate
+ IF( ANY(dl_coarse(ii:ii+1)==dd_fill) .OR. &
+ & ANY( dl_dfdx(ii:ii+1)==dd_fill) ) CYCLE
+ ! check longitude discontinuity
+ dl_tmp(:)=dl_coarse(ii:ii+1)
+ IF( ld_discont )THEN
+
+ dl_min=MINVAL( dl_tmp(:), dl_tmp(:)/=dd_fill )
+ dl_max=MAXVAL( dl_tmp(:), dl_tmp(:)/=dd_fill )
+ IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
+ WHERE( dl_tmp(:) < 0_dp )
+ dl_tmp(:) = dl_tmp(:)+360._dp
+ END WHERE
+ ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
+ WHERE( dl_tmp(:) > 180_dp )
+ dl_tmp(:) = dl_tmp(:)-180._dp
+ END WHERE
+ ENDIF
+
+ ENDIF
+
+ ! compute bicubic coefficient
+ dl_coef(:)=interp_cubic__1D_coef(dl_tmp(:), &
+ & dl_dfdx(ii:ii+1),&
+ & dd_fill )
+
+ ! compute value on detetected point
+ CALL interp_cubic__1D_fill( dd_value( ji:ji+id_rhoi ), &
+ & id_detect(ji:ji+id_rhoi ), &
+ & dd_weight(:,:), dl_coef(:), &
+ & dd_fill, id_rhoi )
+
+ IF( ld_discont )THEN
+ WHERE( dd_value( ji:ji+id_rhoi ) >= 180._dp .AND. &
+ & dd_value( ji:ji+id_rhoi ) /= dd_fill )
+ dd_value(ji:ji+id_rhoi) = dd_value(ji:ji+id_rhoi) - 360._dp
+ END WHERE
+ ENDIF
+
+ ENDDO
+
+ DEALLOCATE(dl_coef)
+ DEALLOCATE(dl_tmp )
+
+ DEALLOCATE(dl_dfdx )
+ DEALLOCATE( dl_coarse )
+ ENDIF
+
+ END SUBROUTINE interp_cubic__1D
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute 2D array of coefficient for cubic interpolation.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[in] dd_value 2D array of value
+ !> @param[in] dd_dfdx 2D array of first derivative in i-direction
+ !> @param[in] dd_dfdy 2D array of first derivative in j-direction
+ !> @param[in] dd_d2fdxy 2D array of cross derivative in i-j-direction
+ !> @param[in] dd_fill FillValue of variable
+ !-------------------------------------------------------------------
+ FUNCTION interp_cubic__2D_coef( dd_value, &
+ & dd_dfdx, &
+ & dd_dfdy, &
+ & dd_d2fdxy,&
+ & dd_fill )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_value
+ REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_dfdx
+ REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_dfdy
+ REAL(dp), DIMENSION(:,:), INTENT(IN) :: dd_d2fdxy
+ REAL(dp) , INTENT(IN) :: dd_fill
+
+ ! function
+ REAL(dp), DIMENSION(16) :: interp_cubic__2D_coef
+
+ ! local variable
+ REAL(dp), DIMENSION(16,16), PARAMETER :: dl_matrix = RESHAPE( &
+ & (/ 1 , 0 ,-3 , 2 , 0 , 0 , 0 , 0 ,-3 , 0 , 9 ,-6 , 2 , 0 ,-6 , 4 ,&
+ 0 , 0 , 3 ,-2 , 0 , 0 , 0 , 0 , 0 , 0 ,-9 , 6 , 0 , 0 , 6 ,-4 ,&
+ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 3 , 0 ,-9 , 6 ,-2 , 0 , 6 ,-4 ,&
+ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 9 ,-6 , 0 , 0 ,-6 , 4 ,&
+ 0 , 1 ,-2 , 1 , 0 , 0 , 0 , 0 , 0 ,-3 , 6 ,-3 , 0 , 2 ,-4 , 2 ,&
+ 0 , 0 ,-1 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 3 ,-3 , 0 , 0 ,-2 , 2 ,&
+ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 3 ,-6 , 3 , 0 ,-2 , 4 ,-2 ,&
+ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,-3 , 3 , 0 , 0 , 2 ,-2 ,&
+ 0 , 0 , 0 , 0 , 1 , 0 ,-3 , 2 ,-2 , 0 , 6 ,-4 , 1 , 0 ,-3 , 2 ,&
+ 0 , 0 , 0 , 0 , 0 , 0 , 3 ,-2 , 0 , 0 ,-6 , 4 , 0 , 0 , 3 ,-2 ,&
+ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,-1 , 0 , 3 ,-2 , 1 , 0 ,-3 , 2 ,&
+ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,-3 , 2 , 0 , 0 , 3 ,-2 ,&
+ 0 , 0 , 0 , 0 , 0 , 1 ,-2 , 1 , 0 ,-2 , 4 ,-2 , 0 , 1 ,-2 , 1 ,&
+ 0 , 0 , 0 , 0 , 0 , 0 ,-1 , 1 , 0 , 0 , 2 ,-2 , 0 , 0 ,-1 , 1 ,&
+ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,-1 , 2 ,-1 , 0 , 1 ,-2 , 1 ,&
+ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 ,-1 , 0 , 0 ,-1 , 1 /), &
+ & (/ 16, 16 /) )
+
+ REAL(dp), DIMENSION(16) :: dl_vect
+
+ !----------------------------------------------------------------
+ ! init
+ interp_cubic__2D_coef(:)=dd_fill
+
+ dl_vect( 1: 4)=PACK(dd_value(:,:),.TRUE. )
+ dl_vect( 5: 8)=PACK(dd_dfdx(:,:),.TRUE. )
+ dl_vect( 9:12)=PACK(dd_dfdy(:,:),.TRUE. )
+ dl_vect(13:16)=PACK(dd_d2fdxy(:,:),.TRUE. )
+
+ interp_cubic__2D_coef(:)=MATMUL(dl_matrix(:,:),dl_vect(:))
+
+ END FUNCTION interp_cubic__2D_coef
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute cubic interpolation of a 2D array of value.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 2D array of mixed grid value
+ !> @param[inout] id_detect 2D array of point to be interpolated
+ !> @param[in] dd_coef 2D array of coefficient
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] id_rhoi refinement factor in i-direction
+ !> @param[in] id_rhoj refinement factor in j-direction
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_cubic__2D_fill( dd_value, id_detect, &
+ & dd_weight, dd_coef, &
+ & dd_fill, id_rhoi, id_rhoj )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value
+ INTEGER(i4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect
+ REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight
+ REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_coef
+ REAL(dp) , INTENT(IN ) :: dd_fill
+ INTEGER(I4) , INTENT(IN ) :: id_rhoi
+ INTEGER(I4) , INTENT(IN ) :: id_rhoj
+
+ ! local variable
+
+ ! loop indices
+ INTEGER(i4) :: ii
+
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ !----------------------------------------------------------------
+
+ IF( ANY( dd_coef(:)==dd_fill ) )THEN
+ CALL logger_error("INTERP CUBIC FILL: fill value detected in coef . "//&
+ & "can not compute interpolation.")
+ ELSE
+
+ ii=0
+ DO jj=1,id_rhoj+1
+ DO ji=1,id_rhoi+1
+
+ ii=ii+1
+ IF(id_detect(ji,jj)==1)THEN
+
+ dd_value(ji,jj)=DOT_PRODUCT(dd_coef(:),dd_weight(:,ii))
+ id_detect(ji,jj)=0
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+ END SUBROUTINE interp_cubic__2D_fill
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute 1D array of coefficient for cubic interpolation.
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[in] dd_value 1D array of value
+ !> @param[in] dd_dfdx 1D array of first derivative
+ !> @param[in] dd_fill FillValue of variable
+ !-------------------------------------------------------------------
+ FUNCTION interp_cubic__1D_coef( dd_value, &
+ & dd_dfdx, &
+ & dd_fill )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp), DIMENSION(:) , INTENT(IN) :: dd_value
+ REAL(dp), DIMENSION(:) , INTENT(IN) :: dd_dfdx
+ REAL(dp) , INTENT(IN) :: dd_fill
+
+ ! function
+ REAL(dp), DIMENSION(4) :: interp_cubic__1D_coef
+
+ ! local variable
+ REAL(dp), DIMENSION(4,4), PARAMETER :: dl_matrix = RESHAPE( &
+ & (/ 1 ,-1 ,-3 , 2 ,&
+ 0 , 1 , 3 ,-2 ,&
+ 0 , 0 ,-2 , 1 ,&
+ 0 , 0 ,-1 , 1 /), &
+ & (/ 4, 4 /) )
+
+ REAL(dp), DIMENSION(4) :: dl_vect
+
+ !----------------------------------------------------------------
+ ! init
+ interp_cubic__1D_coef(:)=dd_fill
+
+ dl_vect( 1: 2)=PACK(dd_value(:),.TRUE. )
+ dl_vect( 3: 4)=PACK(dd_dfdx(:),.TRUE. )
+
+ interp_cubic__1D_coef(:)=MATMUL(dl_matrix(:,:),dl_vect(:))
+
+ END FUNCTION interp_cubic__1D_coef
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute cubic interpolation of a 1D array of value.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 1D array of mixed grid value
+ !> @param[inout] id_detect 1D array of point to be interpolated
+ !> @param[in] dd_coef 1D array of coefficient
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] id_rho refinement factor
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_cubic__1D_fill( dd_value, id_detect, &
+ & dd_weight, dd_coef, &
+ & dd_fill, id_rhoi )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:) , INTENT(INOUT) :: dd_value
+ INTEGER(i4) , DIMENSION(:) , INTENT(INOUT) :: id_detect
+ REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight
+ REAL(dp) , DIMENSION(4) , INTENT(IN ) :: dd_coef
+ REAL(dp) , INTENT(IN ) :: dd_fill
+ INTEGER(I4) , INTENT(IN ) :: id_rhoi
+
+ ! local variable
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ IF( ANY( dd_coef(:)==dd_fill ) )THEN
+ CALL logger_error("INTERP CUBIC FILL: fill value detected. "//&
+ & "can not compute interpolation")
+ ELSE
+
+ DO ji=1,id_rhoi+1
+
+ IF(id_detect(ji)==1)THEN
+
+ dd_value(ji)=DOT_PRODUCT(dd_coef(:),dd_weight(:,ji))
+ id_detect(ji)=0
+
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
+ END SUBROUTINE interp_cubic__1D_fill
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute interpoaltion weight for 2D array.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[in] dd_weight interpolation weight of 2D array
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] id_rho refinement factor
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_cubic__get_weight2D(dd_weight, &
+ & id_rho, ld_even)
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_weight
+ INTEGER(I4), DIMENSION(:) , INTENT(IN ) :: id_rho
+ LOGICAL , DIMENSION(:) , INTENT(IN ) :: ld_even
+
+ ! local variable
+ REAL(dp) :: dl_dx
+ REAL(dp) :: dl_x
+ REAL(dp) :: dl_x2
+ REAL(dp) :: dl_x3
+ REAL(dp) :: dl_dy
+ REAL(dp) :: dl_y
+ REAL(dp) :: dl_y2
+ REAL(dp) :: dl_y3
+
+ ! loop indices
+ INTEGER(i4) :: ii
+
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ !----------------------------------------------------------------
+
+ IF( ld_even(jp_I) )THEN
+ dl_dx=1./REAL(id_rho(jp_I)-1)
+ ELSE ! odd refinement
+ dl_dx=1./REAL(id_rho(jp_I))
+ ENDIF
+
+ IF( ld_even(jp_J) )THEN
+ dl_dy=1./REAL(id_rho(jp_J)-1)
+ ELSE ! odd refinement
+ dl_dy=1./REAL(id_rho(jp_J))
+ ENDIF
+
+ ii=0
+ DO jj=1,id_rho(jp_J)+1
+
+ IF( ld_even(jp_J) )THEN
+ dl_y=(jj-1)*dl_dy - dl_dy*0.5
+ ELSE ! odd refinement
+ dl_y=(jj-1)*dl_dy
+ ENDIF
+ dl_y2=dl_y*dl_y
+ dl_y3=dl_y2*dl_y
+
+ DO ji=1,id_rho(jp_I)+1
+
+ ! iter
+ ii=ii+1
+
+ IF( ld_even(jp_I) )THEN
+ dl_x=(ji-1)*dl_dx - dl_dx*0.5
+ ELSE ! odd refinement
+ dl_x=(ji-1)*dl_dx
+ ENDIF
+ dl_x2=dl_x*dl_x
+ dl_x3=dl_x2*dl_x
+
+ dd_weight(:,ii)=(/1._dp, dl_x , dl_x2 , dl_x3 , &
+ & dl_y , dl_x*dl_y , dl_x2*dl_y , dl_x3*dl_y , &
+ & dl_y2, dl_x*dl_y2, dl_x2*dl_y2, dl_x3*dl_y2, &
+ & dl_y3, dl_x*dl_y3, dl_x2*dl_y3, dl_x3*dl_y3 /)
+
+ ENDDO
+ ENDDO
+
+ END SUBROUTINE interp_cubic__get_weight2D
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute interpoaltion weight for 1D array.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[in] dd_weight interpolation weight of 1D array
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] id_rho refinement factor
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_cubic__get_weight1D(dd_weight, &
+ & id_rho, ld_even)
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_weight
+ INTEGER(I4) , INTENT(IN ) :: id_rho
+ LOGICAL , INTENT(IN ) :: ld_even
+ ! local variable
+ REAL(dp) :: dl_dx
+ REAL(dp) :: dl_x
+ REAL(dp) :: dl_x2
+ REAL(dp) :: dl_x3
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ IF( ld_even )THEN
+ dl_dx=1./REAL(id_rho-1)
+ ELSE ! odd refinement
+ dl_dx=1./REAL(id_rho)
+ ENDIF
+
+ DO ji=1,id_rho+1
+ IF( ld_even )THEN
+ dl_x=(ji-1)*dl_dx - dl_dx*0.5
+ ELSE ! odd refinement
+ dl_x=(ji-1)*dl_dx
+ ENDIF
+ dl_x2=dl_x*dl_x
+ dl_x3=dl_x2*dl_x
+
+ dd_weight(:,ji)=(/1._dp, dl_x, dl_x2, dl_x3 /)
+ ENDDO
+
+ END SUBROUTINE interp_cubic__get_weight1D
+END MODULE interp_cubic
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp_linear.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp_linear.f90 (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp_linear.f90 (revision 5214)
@@ -0,0 +1,701 @@
+!----------------------------------------------------------------------
+! NEMO system team, System and Interface for oceanic RElocable Nesting
+!----------------------------------------------------------------------
+!
+! MODULE: interp
+!
+! DESCRIPTION:
+!> @brief
+!> This module manage linear interpolation on regular grid.
+!>
+!> @details
+!> to compute linear interpolation:
+!> @code
+!> CALL interp_linear_fill(dd_value, dd_fill, id_detect, id_rho, ld_even [,ld_discont] )
+!> @endcode
+!> - dd_value is 2D array of variable value
+!> - dd_fill is the FillValue of variable
+!> - id_detect is 2D array of point to be interpolated (see interp module)
+!> - id_rho is array of refinment factor
+!> - ld_even indicates even refinment or not
+!> - ld_discont indicates longitudinal discontinuity (-180°/180°, 0°/360°) or not
+!>
+!> @author
+!> J.Paul
+! REVISION HISTORY:
+!> @date September, 2014 -Initial version
+!>
+!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+!----------------------------------------------------------------------
+
+MODULE interp_linear
+
+ USE netcdf ! nf90 library
+ USE global ! global variable
+ USE kind ! F90 kind parameter
+ USE logger ! log file manager
+ USE fct ! basic useful function
+ USE extrap ! extrapolation manager
+
+ IMPLICIT NONE
+ ! NOTE_avoid_public_variables_if_possible
+
+ ! type and variable
+
+ ! function and subroutine
+ PUBLIC :: interp_linear_fill !< compute interpolation using linear method
+
+ PRIVATE :: interp_linear__2D !< compute bilinear interpolation on 2D gid
+ PRIVATE :: interp_linear__1D !< compute linear interpolation on 1D gid
+ PRIVATE :: interp_linear__2D_coef !< compute coefficient for bilinear interpolation
+ PRIVATE :: interp_linear__2D_fill !< fill value using bilinear interpolation
+ PRIVATE :: interp_linear__1D_coef !< compute coefficient for linear interpolation
+ PRIVATE :: interp_linear__1D_fill !< fill value using linear interpolation
+ PRIVATE :: interp_linear__get_weight2D !< compute interpoaltion weight for 2D array.
+ PRIVATE :: interp_linear__get_weight1D !< compute interpoaltion weight for 1D array.
+
+CONTAINS
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute horizontal linear interpolation on 4D array of value.
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 2D array of variable value
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[inout] id_detect 2D array of point to be interpolated
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_linear_fill(dd_value, dd_fill, id_detect, &
+ & id_rho, ld_even, ld_discont )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value
+ REAL(dp) , INTENT(IN ) :: dd_fill
+ INTEGER(I4) , DIMENSION(:,:,:) , INTENT(INOUT) :: id_detect
+ INTEGER(I4) , DIMENSION(:) , INTENT(IN ) :: id_rho
+ LOGICAL , DIMENSION(:) , INTENT(IN ) :: ld_even
+ LOGICAL , INTENT(IN ), OPTIONAL :: ld_discont
+
+ ! local variable
+ INTEGER(i4), DIMENSION(4) :: il_shape
+
+ LOGICAL :: ll_discont
+
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_IJ
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_I
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_weight_J
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ INTEGER(i4) :: jk
+ INTEGER(i4) :: jl
+ !----------------------------------------------------------------
+ ll_discont=.FALSE.
+ IF( PRESENT(ld_discont) ) ll_discont=ld_discont
+
+ il_shape(:)=SHAPE(dd_value)
+
+ ! compute vect2D
+ ALLOCATE(dl_weight_IJ(16,((id_rho(jp_I)+1)*(id_rho(jp_J)+1))) )
+ CALL interp_linear__get_weight2D(dl_weight_IJ(:,:), &
+ & id_rho(:), ld_even(:))
+
+ ALLOCATE( dl_weight_I( 4,((id_rho(jp_I)+1) )) )
+ ALLOCATE( dl_weight_J( 4,( (id_rho(jp_J)+1))) )
+ CALL interp_linear__get_weight1D(dl_weight_I(:,:), &
+ & id_rho(jp_I), ld_even(jp_I))
+ CALL interp_linear__get_weight1D(dl_weight_J(:,:), &
+ & id_rho(jp_J), ld_even(jp_J))
+
+ DO jl=1,il_shape(4)
+ ! loop on vertical level
+ DO jk=1,il_shape(3)
+
+ ! I-J plan
+ CALL interp_linear__2D(dd_value(:,:,jk,jl), dd_fill,&
+ & id_detect(:,:,jk), &
+ & dl_weight_IJ(:,:), &
+ & id_rho(jp_I), id_rho(jp_J), &
+ & ll_discont)
+ IF( ANY(id_detect(:,:,jk)==1) )THEN
+ ! I direction
+ DO jj=1,il_shape(2)
+ CALL interp_linear__1D( dd_value(:,jj,jk,jl), dd_fill,&
+ & id_detect(:,jj,jk), &
+ & dl_weight_I(:,:), &
+ & id_rho(jp_I), ll_discont )
+ ENDDO
+ IF( ALL(id_detect(:,:,jk)==0) )THEN
+ CYCLE
+ ELSE
+ ! J direction
+ DO ji=1,il_shape(1)
+ CALL interp_linear__1D( dd_value(ji,:,jk,jl), dd_fill,&
+ & id_detect(ji,:,jk), &
+ & dl_weight_J(:,:), &
+ & id_rho(jp_J), ll_discont )
+ ENDDO
+ ENDIF
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ DEALLOCATE(dl_weight_IJ)
+ DEALLOCATE(dl_weight_I)
+ DEALLOCATE(dl_weight_J)
+
+ END SUBROUTINE interp_linear_fill
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute linear interpolation on 2D array of value.
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 2D array of variable value
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[inout] id_detect 2D array of point to be interpolated
+ !> @param[in] id_rhoi refinment factor in i-direction
+ !> @param[in] id_rhoj refinment factor in j-direction
+ !> @param[in] id_rhok refinment factor in k-direction
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_linear__2D( dd_value, dd_fill, &
+ & id_detect, &
+ & dd_weight, &
+ & id_rhoi, id_rhoj, &
+ & ld_discont )
+
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value
+ REAL(dp) , INTENT(IN ) :: dd_fill
+ INTEGER(I4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect
+ REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight
+ INTEGER(I4) , INTENT(IN ) :: id_rhoi
+ INTEGER(I4) , INTENT(IN ) :: id_rhoj
+ LOGICAL , INTENT(IN ) :: ld_discont
+
+ ! local variable
+ INTEGER(I4) :: il_xextra
+ INTEGER(I4) :: il_yextra
+ INTEGER(i4), DIMENSION(2) :: il_shape
+ INTEGER(i4), DIMENSION(2) :: il_dim
+
+ REAL(dp) :: dl_min
+ REAL(dp) :: dl_max
+ REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_coef
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_coarse
+ REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_tmp
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ INTEGER(i4) :: ii
+ INTEGER(i4) :: ij
+
+ !----------------------------------------------------------------
+
+ IF( ANY(id_detect(:,:)==1) )THEN
+ il_shape(:)=SHAPE(dd_value)
+
+ ! compute coarse grid dimension
+ il_xextra=id_rhoi-1
+ il_dim(1)=(il_shape(1)+il_xextra)/id_rhoi
+
+ il_yextra=id_rhoj-1
+ il_dim(2)=(il_shape(2)+il_yextra)/id_rhoj
+
+ ALLOCATE( dl_coarse(il_dim(1),il_dim(2)) )
+
+ ! value on coarse grid
+ dl_coarse(:,:)=dd_value( 1:il_shape(1):id_rhoi, &
+ & 1:il_shape(2):id_rhoj )
+
+ ALLOCATE( dl_tmp(2,2) )
+ ALLOCATE( dl_coef(4) )
+
+ DO jj=1,il_shape(2)-1,id_rhoj
+ ij=((jj-1)/id_rhoj)+1
+ DO ji=1,il_shape(1)-1,id_rhoi
+ ii=((ji-1)/id_rhoi)+1
+
+ ! check if point to be interpolated
+ IF( ALL(id_detect(ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj)==0) ) CYCLE
+ ! check data to needed to interpolate
+ IF( ANY(dl_coarse(ii:ii+1,ij:ij+1)==dd_fill) ) CYCLE
+ ! check longitude discontinuity
+ dl_tmp(:,:)=dl_coarse(ii:ii+1,ij:ij+1)
+ IF( ld_discont )THEN
+
+ dl_min=MINVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill )
+ dl_max=MAXVAL( dl_tmp(:,:), dl_tmp(:,:)/=dd_fill )
+ IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
+ WHERE( dl_tmp(:,:) < 0_dp )
+ dl_tmp(:,:) = dl_tmp(:,:)+360._dp
+ END WHERE
+ ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
+ WHERE( dl_tmp(:,:) > 180_dp )
+ dl_tmp(:,:) = dl_tmp(:,:)-180._dp
+ END WHERE
+ ENDIF
+
+ ENDIF
+
+ ! compute bilinear coefficient
+ dl_coef(:)=interp_linear__2D_coef(dl_tmp(:,:),&
+ & dd_fill )
+
+ ! compute value on detetected point
+ CALL interp_linear__2D_fill(dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ), &
+ & id_detect(ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ), &
+ & dd_weight(:,:), dl_coef(:),&
+ & dd_fill, id_rhoi, id_rhoj )
+
+ IF( ld_discont )THEN
+ WHERE( dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ) >= 180._dp .AND. &
+ & dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ) /= dd_fill )
+ dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ) = &
+ & dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ) - 360._dp
+ END WHERE
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ DEALLOCATE(dl_coef)
+ DEALLOCATE(dl_tmp )
+
+ DEALLOCATE( dl_coarse )
+ ENDIF
+
+ END SUBROUTINE interp_linear__2D
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute linear interpolation on 1D array of value.
+ !>
+ !> @details
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 1D array of variable value
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[inout] id_detect 1D array of point to be interpolated
+ !> @param[in] id_rhoi refinment factor
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] ld_discont longitudinal discontinuity (-180°/180°, 0°/360°) or not
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_linear__1D( dd_value, dd_fill, &
+ & id_detect, &
+ & dd_weight, &
+ & id_rhoi, &
+ & ld_discont )
+
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:) , INTENT(INOUT) :: dd_value
+ REAL(dp) , INTENT(IN ) :: dd_fill
+ INTEGER(I4) , DIMENSION(:) , INTENT(INOUT) :: id_detect
+ REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight
+ INTEGER(I4) , INTENT(IN ) :: id_rhoi
+ LOGICAL , INTENT(IN ) :: ld_discont
+
+ ! local variable
+ INTEGER(I4) :: il_xextra
+ INTEGER(i4), DIMENSION(1) :: il_shape
+ INTEGER(i4), DIMENSION(1) :: il_dim
+
+ REAL(dp) :: dl_min
+ REAL(dp) :: dl_max
+ REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_coef
+ REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_coarse
+ REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_tmp
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: ii
+
+ !----------------------------------------------------------------
+
+ IF( ANY(id_detect(:)==1) )THEN
+ il_shape(:)=SHAPE(dd_value)
+
+ ! compute coarse grid dimension
+ il_xextra=id_rhoi-1
+ il_dim(1)=(il_shape(1)+il_xextra)/id_rhoi
+
+ ALLOCATE( dl_coarse(il_dim(1)) )
+
+ ! value on coarse grid
+ dl_coarse(:)=dd_value( 1:il_shape(1):id_rhoi )
+
+ ALLOCATE( dl_tmp(2) )
+ ALLOCATE( dl_coef(4) )
+
+ DO ji=1,il_shape(1)-1,id_rhoi
+ ii=((ji-1)/id_rhoi)+1
+
+ ! check if point to be interpolated
+ IF( ALL(id_detect(ji:ji+id_rhoi)==0) ) CYCLE
+ ! check data needed to interpolate
+ IF( ANY(dl_coarse(ii:ii+1)==dd_fill) ) CYCLE
+ ! check longitude discontinuity
+ dl_tmp(:)=dl_coarse(ii:ii+1)
+ IF( ld_discont )THEN
+
+ dl_min=MINVAL( dl_tmp(:), dl_tmp(:)/=dd_fill )
+ dl_max=MAXVAL( dl_tmp(:), dl_tmp(:)/=dd_fill )
+ IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN
+ WHERE( dl_tmp(:) < 0_dp )
+ dl_tmp(:) = dl_tmp(:)+360._dp
+ END WHERE
+ ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN
+ WHERE( dl_tmp(:) > 180_dp )
+ dl_tmp(:) = dl_tmp(:)-180._dp
+ END WHERE
+ ENDIF
+
+ ENDIF
+
+ ! compute bilinear coefficient
+ dl_coef(:)=interp_linear__1D_coef(dl_tmp(:), &
+ & dd_fill )
+
+ ! compute value on detetected point
+ CALL interp_linear__1D_fill( dd_value( ji:ji+id_rhoi ), &
+ & id_detect(ji:ji+id_rhoi ), &
+ & dd_weight(:,:), dl_coef(:),&
+ & dd_fill, id_rhoi )
+
+ IF( ld_discont )THEN
+ WHERE( dd_value( ji:ji+id_rhoi ) >= 180._dp .AND. &
+ & dd_value( ji:ji+id_rhoi ) /= dd_fill )
+ dd_value(ji:ji+id_rhoi) = dd_value(ji:ji+id_rhoi) - 360._dp
+ END WHERE
+ ENDIF
+
+ ENDDO
+
+ DEALLOCATE(dl_coef)
+ DEALLOCATE(dl_tmp )
+
+ DEALLOCATE( dl_coarse )
+ ENDIF
+
+ END SUBROUTINE interp_linear__1D
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute 2D array of coefficient for linear interpolation.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[in] dd_value 2D array of value
+ !> @param[in] dd_fill FillValue of variable
+ !-------------------------------------------------------------------
+ FUNCTION interp_linear__2D_coef( dd_value, dd_fill )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp), DIMENSION(:,:) , INTENT(IN) :: dd_value
+ REAL(dp) , INTENT(IN) :: dd_fill
+
+ ! function
+ REAL(dp), DIMENSION(4) :: interp_linear__2D_coef
+
+ ! local variable
+ REAL(dp), DIMENSION(4,4), PARAMETER :: dl_matrix = RESHAPE( &
+ & (/ 1 ,-1 ,-1 , 1 ,&
+ 0 , 1 , 0 ,-1 ,&
+ 0 , 0 , 1 ,-1 ,&
+ 0 , 0 , 0 , 1 /), &
+ & (/ 4, 4 /) )
+
+ REAL(dp), DIMENSION(4) :: dl_vect
+
+ !----------------------------------------------------------------
+ ! init
+ interp_linear__2D_coef(:)=dd_fill
+
+ dl_vect( 1: 4)=PACK(dd_value(:,:),.TRUE. )
+ interp_linear__2D_coef(:)=MATMUL(dl_matrix(:,:),dl_vect(:))
+
+ END FUNCTION interp_linear__2D_coef
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute linear interpolation of a 2D array of value.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 2D array of mixed grid value
+ !> @param[inout] id_detect 2D array of point to be interpolated
+ !> @param[in] dd_coef 2D array of coefficient
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] id_rhoi refinement factor in i-direction
+ !> @param[in] id_rhoj refinement factor in j-direction
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_linear__2D_fill( dd_value, id_detect, &
+ & dd_weight, dd_coef, &
+ & dd_fill, id_rhoi, id_rhoj )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value
+ INTEGER(i4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect
+ REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight
+ REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_coef
+ REAL(dp) , INTENT(IN ) :: dd_fill
+ INTEGER(I4) , INTENT(IN ) :: id_rhoi
+ INTEGER(I4) , INTENT(IN ) :: id_rhoj
+
+ ! local variable
+
+ ! loop indices
+ INTEGER(i4) :: ii
+
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ !----------------------------------------------------------------
+
+ IF( ANY( dd_coef(:)==dd_fill ) )THEN
+ CALL logger_error("INTERP LINEAR FILL: fill value detected in coef. "//&
+ & "can not compute interpolation.")
+ ELSE
+
+ ii=0
+ DO jj=1,id_rhoj+1
+ DO ji=1,id_rhoi+1
+
+ ii=ii+1
+ IF(id_detect(ji,jj)==1)THEN
+
+ dd_value(ji,jj)=DOT_PRODUCT(dd_coef(:),dd_weight(:,ii))
+ id_detect(ji,jj)=0
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+ END SUBROUTINE interp_linear__2D_fill
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute 1D array of coefficient for linear interpolation.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[in] dd_value 1D array of value
+ !> @param[in] dd_fill FillValue of variable
+ !-------------------------------------------------------------------
+ FUNCTION interp_linear__1D_coef( dd_value, dd_fill )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp), DIMENSION(:) , INTENT(IN) :: dd_value
+ REAL(dp) , INTENT(IN) :: dd_fill
+
+ ! function
+ REAL(dp), DIMENSION(2) :: interp_linear__1D_coef
+
+ ! local variable
+ REAL(dp), DIMENSION(2,2), PARAMETER :: dl_matrix = RESHAPE( &
+ & (/ 1 ,-1 ,&
+ 0 , 1 /), &
+ & (/ 2, 2 /) )
+
+ REAL(dp), DIMENSION(2) :: dl_vect
+
+ !----------------------------------------------------------------
+ ! init
+ interp_linear__1D_coef(:)=dd_fill
+
+ dl_vect( 1: 2)=PACK(dd_value(:),.TRUE. )
+ interp_linear__1D_coef(:)=MATMUL(dl_matrix(:,:),dl_vect(:))
+
+ END FUNCTION interp_linear__1D_coef
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute linear interpolation of a 1D array of value.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 1D array of mixed grid value
+ !> @param[inout] id_detect 1D array of point to be interpolated
+ !> @param[in] dd_coef 1D array of coefficient
+ !> @param[in] dd_fill FillValue of variable
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] id_rho refinement factor
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_linear__1D_fill( dd_value, id_detect, &
+ & dd_weight, dd_coef, &
+ & dd_fill, id_rho )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:) , INTENT(INOUT) :: dd_value
+ INTEGER(i4) , DIMENSION(:) , INTENT(INOUT) :: id_detect
+ REAL(dp) , DIMENSION(:,:), INTENT(IN ) :: dd_weight
+ REAL(dp) , DIMENSION(:) , INTENT(IN ) :: dd_coef
+ REAL(dp) , INTENT(IN ) :: dd_fill
+ INTEGER(I4) , INTENT(IN ) :: id_rho
+
+ ! local variable
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ IF( ANY( dd_coef(:)==dd_fill ) )THEN
+ CALL logger_error("INTERP LINEAR FILL: fill value detected. "//&
+ & "can not compute interpolation")
+ ELSE
+
+ DO ji=1,id_rho+1
+
+ IF(id_detect(ji)==1)THEN
+
+ dd_value(ji)=DOT_PRODUCT(dd_coef(:),dd_weight(:,ji))
+ id_detect(ji)=0
+
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
+ END SUBROUTINE interp_linear__1D_fill
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute interpoaltion weight for 2D array.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[in] dd_weight interpolation weight of 2D array
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] id_rho refinement factor
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_linear__get_weight2D(dd_weight, &
+ & id_rho, ld_even)
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_weight
+ INTEGER(I4), DIMENSION(:) , INTENT(IN ) :: id_rho
+ LOGICAL , DIMENSION(:) , INTENT(IN ) :: ld_even
+ ! local variable
+ REAL(dp) :: dl_dx
+ REAL(dp) :: dl_x
+ REAL(dp) :: dl_dy
+ REAL(dp) :: dl_y
+
+ ! loop indices
+ INTEGER(i4) :: ii
+
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ !----------------------------------------------------------------
+
+ IF( ld_even(jp_I) )THEN
+ dl_dx=1./REAL(id_rho(jp_I)-1)
+ ELSE ! odd refinement
+ dl_dx=1./REAL(id_rho(jp_I))
+ ENDIF
+
+ IF( ld_even(jp_J) )THEN
+ dl_dy=1./REAL(id_rho(jp_J)-1)
+ ELSE ! odd refinement
+ dl_dy=1./REAL(id_rho(jp_J))
+ ENDIF
+
+ ii=0
+ DO jj=1,id_rho(jp_J)+1
+
+ IF( ld_even(jp_J) )THEN
+ dl_y=(jj-1)*dl_dy - dl_dy*0.5
+ ELSE ! odd refinement
+ dl_y=(jj-1)*dl_dy
+ ENDIF
+
+ DO ji=1,id_rho(jp_I)+1
+
+ ! iter
+ ii=ii+1
+
+ IF( ld_even(jp_I) )THEN
+ dl_x=(ji-1)*dl_dx - dl_dx*0.5
+ ELSE ! odd refinement
+ dl_x=(ji-1)*dl_dx
+ ENDIF
+
+ dd_weight(:,ii)=(/1._dp, dl_x, dl_y, dl_x*dl_y /)
+
+ ENDDO
+ ENDDO
+
+ END SUBROUTINE interp_linear__get_weight2D
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute interpoaltion weight for 1D array.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[in] dd_weight interpolation weight of 1D array
+ !> @param[in] ld_even even refinment or not
+ !> @param[in] id_rho refinement factor
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_linear__get_weight1D(dd_weight, &
+ & id_rho, ld_even)
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_weight
+ INTEGER(I4) , INTENT(IN ) :: id_rho
+ LOGICAL , INTENT(IN ) :: ld_even
+
+ ! local variable
+ REAL(dp) :: dl_dx
+ REAL(dp) :: dl_x
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ IF( ld_even )THEN
+ dl_dx=1./REAL(id_rho-1)
+ ELSE ! odd refinement
+ dl_dx=1./REAL(id_rho)
+ ENDIF
+
+ DO ji=1,id_rho+1
+ IF( ld_even )THEN
+ dl_x=(ji-1)*dl_dx - dl_dx*0.5
+ ELSE ! odd refinement
+ dl_x=(ji-1)*dl_dx
+ ENDIF
+
+ dd_weight(:,ji)=(/1._dp, dl_x /)
+ ENDDO
+
+ END SUBROUTINE interp_linear__get_weight1D
+END MODULE interp_linear
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp_nearest.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp_nearest.f90 (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/interp_nearest.f90 (revision 5214)
@@ -0,0 +1,353 @@
+!----------------------------------------------------------------------
+! NEMO system team, System and Interface for oceanic RElocable Nesting
+!----------------------------------------------------------------------
+!
+! MODULE: interp
+!
+! DESCRIPTION:
+!> @brief
+!> This module manage nearest interpolation on regular grid.
+!>
+!> @details
+!> to compute nearest interpolation:
+!> @code
+!> CALL interp_nearest_fill(dd_value, dd_fill, id_detect, id_rho, ld_even [,ld_discont] )
+!> @endcode
+!> - dd_value is 2D array of variable value
+!> - dd_fill is the FillValue of variable
+!> - id_detect is 2D array of point to be interpolated (see interp module)
+!> - id_rho is array of refinment factor
+!> - ld_even indicates even refinment or not
+!> - ld_discont indicates longitudinal discontinuity (-180°/180°, 0°/360°) or not
+!>
+!> @author
+!> J.Paul
+! REVISION HISTORY:
+!> @date September, 2014 -Initial version
+!>
+!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+!----------------------------------------------------------------------
+MODULE interp_nearest
+
+ USE netcdf ! nf90 library
+ USE global ! global variable
+ USE kind ! F90 kind parameter
+ USE logger ! log file manager
+ USE fct ! basic useful function
+
+ IMPLICIT NONE
+ ! NOTE_avoid_public_variables_if_possible
+
+ ! type and variable
+
+ ! function and subroutine
+ PUBLIC :: interp_nearest_fill !< compute interpolation using nearest method
+
+ PRIVATE :: interp_nearest__2D !< compute binearest interpolation on 2D gid
+ PRIVATE :: interp_nearest__1D !< compute nearest interpolation on 1D gid
+ PRIVATE :: interp_nearest__2D_fill !< fill value using binearest interpolation
+ PRIVATE :: interp_nearest__1D_fill !< fill value using nearest interpolation
+
+CONTAINS
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute horizontal nearest interpolation on 4D array of value.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 2D array of variable value
+ !> @param[inout] id_detect 2D array of point to be interpolated
+ !> @param[in] id_rho array of refinment factor
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_nearest_fill(dd_value, id_detect, id_rho )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value
+ INTEGER(I4) , DIMENSION(:,:,:) , INTENT(INOUT) :: id_detect
+ INTEGER(I4) , DIMENSION(:) , INTENT(IN ) :: id_rho
+
+ ! local variable
+ INTEGER(i4), DIMENSION(4) :: il_shape
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ INTEGER(i4) :: jk
+ INTEGER(i4) :: jl
+ !----------------------------------------------------------------
+
+ il_shape(:)=SHAPE(dd_value)
+
+ DO jl=1,il_shape(4)
+ ! loop on vertical level
+ DO jk=1,il_shape(3)
+
+ ! I-J plan
+ CALL interp_nearest__2D(dd_value(:,:,jk,jl),&
+ & id_detect(:,:,jk), &
+ & id_rho(jp_I), id_rho(jp_J) )
+ IF( ANY(id_detect(:,:,jk)==1) )THEN
+ ! I direction
+ DO jj=1,il_shape(2)
+ CALL interp_nearest__1D( dd_value(:,jj,jk,jl),&
+ & id_detect(:,jj,jk), &
+ & id_rho(jp_I) )
+ ENDDO
+ IF( ALL(id_detect(:,:,jk)==0) )THEN
+ CYCLE
+ ELSE
+ ! J direction
+ DO ji=1,il_shape(1)
+ CALL interp_nearest__1D( dd_value(ji,:,jk,jl),&
+ & id_detect(ji,:,jk), &
+ & id_rho(jp_J) )
+ ENDDO
+ ENDIF
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ END SUBROUTINE interp_nearest_fill
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute nearest interpolation on 2D array of value.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 2D array of variable value
+ !> @param[inout] id_detect 2D array of point to be interpolated
+ !> @param[in] id_rhoi refinment factor in i-direction
+ !> @param[in] id_rhoj refinment factor in j-direction
+ !> @param[in] id_rhok refinment factor in k-direction
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_nearest__2D( dd_value, id_detect, &
+ & id_rhoi, id_rhoj )
+
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:), INTENT(INOUT) :: dd_value
+ INTEGER(I4) , DIMENSION(:,:), INTENT(INOUT) :: id_detect
+ INTEGER(I4) , INTENT(IN ) :: id_rhoi
+ INTEGER(I4) , INTENT(IN ) :: id_rhoj
+
+ ! local variable
+ INTEGER(i4), DIMENSION(2) :: il_shape
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+
+ !----------------------------------------------------------------
+
+ IF( ANY(id_detect(:,:)==1) )THEN
+
+ il_shape(:)=SHAPE(dd_value)
+
+ DO jj=1,il_shape(2)-1,id_rhoj
+ DO ji=1,il_shape(1)-1,id_rhoi
+
+ ! check if point to be interpolated
+ IF( ALL(id_detect(ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj)==0) ) CYCLE
+
+ ! compute value on detetected point
+ CALL interp_nearest__2D_fill(dd_value( ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ), &
+ & id_detect(ji:ji+id_rhoi, &
+ & jj:jj+id_rhoj ) )
+
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+ END SUBROUTINE interp_nearest__2D
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute nearest interpolation on 1D array of value.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 1D array of variable value
+ !> @param[inout] id_detect 1D array of point to be interpolated
+ !> @param[in] id_rhoi refinment factor
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_nearest__1D( dd_value, id_detect, &
+ & id_rhoi )
+
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_value
+ INTEGER(I4) , DIMENSION(:), INTENT(INOUT) :: id_detect
+ INTEGER(I4) , INTENT(IN ) :: id_rhoi
+
+ ! local variable
+ INTEGER(i4), DIMENSION(1) :: il_shape
+
+ ! loop indices
+ INTEGER(i4) :: ji
+
+ !----------------------------------------------------------------
+
+ IF( ANY(id_detect(:)==1) )THEN
+ il_shape(:)=SHAPE(dd_value)
+
+ DO ji=1,il_shape(1)-1,id_rhoi
+
+ ! check if point to be interpolated
+ IF( ALL(id_detect(ji:ji+id_rhoi)==0) ) CYCLE
+
+ ! compute value on detetected point
+ CALL interp_nearest__1D_fill( dd_value( ji:ji+id_rhoi ), &
+ & id_detect(ji:ji+id_rhoi ) )
+
+ ENDDO
+
+ ENDIF
+
+ END SUBROUTINE interp_nearest__1D
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute nearest interpolation of a 2D array of value.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 2D array of mixed grid value
+ !> @param[inout] id_detect 2D array of point to be interpolated
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_nearest__2D_fill( dd_value, id_detect )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:,:) , INTENT(INOUT) :: dd_value
+ INTEGER(i4), DIMENSION(:,:) , INTENT(INOUT) :: id_detect
+
+ ! local variable
+ INTEGER(i4), DIMENSION(2) :: il_shape
+
+ INTEGER(i4) :: il_i1
+ INTEGER(i4) :: il_i2
+ INTEGER(i4) :: il_j1
+ INTEGER(i4) :: il_j2
+
+ INTEGER(i4) :: il_half1
+ INTEGER(i4) :: il_half2
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ !----------------------------------------------------------------
+
+ il_shape(:)=SHAPE(dd_value(:,:))
+
+ il_i1=1
+ il_i2=il_shape(1)
+
+ il_j1=1
+ il_j2=il_shape(2)
+
+ il_half1=CEILING(il_shape(1)*0.5)
+ il_half2=CEILING(il_shape(2)*0.5)
+
+ DO jj=1,il_half2
+
+ DO ji=1,il_half1
+
+ ! lower left point
+ IF(id_detect(ji,jj)==1)THEN
+
+ dd_value( ji,jj)=dd_value(il_i1,il_j1)
+ id_detect(ji,jj)=0
+
+ ENDIF
+
+ ! lower right point
+ IF(id_detect(il_shape(1)-ji+1,jj)==1)THEN
+
+ dd_value( il_shape(1)-ji+1,jj)=dd_value(il_i2,il_j1)
+ id_detect(il_shape(1)-ji+1,jj)=0
+
+ ENDIF
+
+ ! upper left point
+ IF(id_detect(ji,il_shape(2)-jj+1)==1)THEN
+
+ dd_value( ji,il_shape(2)-jj+1)=dd_value(il_i1,il_j2)
+ id_detect(ji,il_shape(2)-jj+1)=0
+
+ ENDIF
+
+ ! upper right point
+ IF(id_detect(il_shape(1)-ji+1,il_shape(2)-jj+1)==1)THEN
+
+ dd_value( il_shape(1)-ji+1,il_shape(2)-jj+1)=dd_value(il_i2,il_j2)
+ id_detect(il_shape(1)-ji+1,il_shape(2)-jj+1)=0
+
+ ENDIF
+
+ ENDDO
+
+ ENDDO
+
+ END SUBROUTINE interp_nearest__2D_fill
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine compute nearest interpolation of a 1D array of value.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[inout] dd_value 1D array of mixed grid value
+ !> @param[inout] id_detect 1D array of point to be interpolated
+ !-------------------------------------------------------------------
+ SUBROUTINE interp_nearest__1D_fill( dd_value, id_detect )
+ IMPLICIT NONE
+ ! Argument
+ REAL(dp) , DIMENSION(:), INTENT(INOUT) :: dd_value
+ INTEGER(i4), DIMENSION(:), INTENT(INOUT) :: id_detect
+
+ ! local variable
+ INTEGER(i4), DIMENSION(1) :: il_shape
+
+ INTEGER(i4) :: il_i1
+ INTEGER(i4) :: il_i2
+
+ INTEGER(i4) :: il_half1
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ il_shape(:)=SHAPE(dd_value)
+
+ il_i1=1
+ il_i2=il_shape(1)
+
+ il_half1=CEILING(il_shape(1)*0.5)
+
+ DO ji=1,il_half1
+
+ ! lower left point
+ IF(id_detect(ji)==1)THEN
+
+ dd_value( ji)=dd_value(il_i1)
+ id_detect(ji)=0
+
+ ENDIF
+
+ ! lower right point
+ IF(id_detect(il_shape(1)-ji+1)==1)THEN
+
+ dd_value( il_shape(1)-ji+1)=dd_value(il_i2)
+ id_detect(il_shape(1)-ji+1)=0
+
+ ENDIF
+
+ ENDDO
+
+ END SUBROUTINE interp_nearest__1D_fill
+END MODULE interp_nearest
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom.f90 (revision 5214)
@@ -6,67 +6,93 @@
!
! DESCRIPTION:
-!> @brief Input/Output manager : Library to read input files
+!> @brief Input/Output manager : Library to read input files
!>
!> @details
+!> to open file:
+!> @code
+!> CALL iom_open(td_file)
+!> @endcode
+!> - td_file is file structure
+!>
+!> to create file:
+!> @code
+!> CALL iom_create(td_file)
+!> @endcode
+!> - td_file is file structure
!>
-!> to open file:
-!> CALL iom_open(td_file)
-!> - td_file is file structure
-!>
!> to write in file:
+!> @code
!> CALL iom_write_file(td_file)
+!> @endcode
!>
!> to close file:
+!> @code
!> CALL iom_close(tl_file)
+!> @endcode
!>
!> to read one dimension in file:
-!> tl_dim = iom_read_dim(tl_file, id_dimid)
+!> @code
+!> tl_dim = iom_read_dim(tl_file, id_dimid)
+!> @endcode
!> or
-!> tl_dim = iom_read_dim(tl_file, cd_name)
+!> @code
+!> tl_dim = iom_read_dim(tl_file, cd_name)
+!> @endcode
!> - id_dimid is dimension id
!> - cd_name is dimension name
!>
!> to read variable or global attribute in file:
-!> tl_att = iom_read_att(tl_file, id_varid, id_attid)
-!> or
-!> tl_att = iom_read_att(tl_file, id_varid, cd_attname)
-!> or
-!> tl_att = iom_read_att(tl_file, cd_varname, cd_attid, [cd_stdname])
-!> or
-!> tl_att = iom_read_att(tl_file, cd_varname, cd_attname, cd_stdname)
+!> @code
+!> tl_att = iom_read_att(tl_file, id_varid, id_attid)
+!> @endcode
+!> or
+!> @code
+!> tl_att = iom_read_att(tl_file, id_varid, cd_attname)
+!> @endcode
+!> or
+!> @code
+!> tl_att = iom_read_att(tl_file, cd_varname, id_attid)
+!> @endcode
+!> or
+!> @code
+!> tl_att = iom_read_att(tl_file, cd_varname, cd_attname)
+!> @endcode
!> - id_varid is variable id
!> - id_attid is attribute id
!> - cd_attname is attribute name
-!> - cd_varname is variable name
-!> - cd_stdname is variable standard name (optional)
+!> - cd_varname is variable name or standard name
!>
!> to read one variable in file:
-!> tl_var = iom_read_var(td_file, id_varid, [id_start, id_count])
-!> or
-!> tl_var = iom_read_var(td_file, cd_name, [id_start, [id_count,]] [cd_stdname])
+!> @code
+!> tl_var = iom_read_var(td_file, id_varid, [id_start, id_count])
+!> @endcode
+!> or
+!> @code
+!> tl_var = iom_read_var(td_file, cd_name, [id_start, [id_count,]])
+!> @endcode
!> - id_varid is variabale id
-!> - cd_name is variabale name
-!> - id_start is a integer(4) 1D table of index from which the data
-!> values will be read (optional)
-!> - id_count is a integer(4) 1D table of the number of indices selected
-!> along each dimension (optional)
-!> - cd_stdname is variable standard name (optional)
+!> - cd_name is variabale name or standard name.
+!> - id_start is a integer(4) 1D array of index from which the data
+!> values will be read [optional]
+!> - id_count is a integer(4) 1D array of the number of indices selected
+!> along each dimension [optional]
!>
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
-!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+!> @date November, 2013 - Initial Version
+!>
!> @todo
!> - see lbc_lnk
!> - see goup netcdf4
-!> - add iom_fill_var_value : complete tl_file avec valeur de la variable
+!>
+!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
!----------------------------------------------------------------------
MODULE iom
USE netcdf ! nf90 library
+ USE global ! global parameter
USE kind ! F90 kind parameter
USE fct ! basic useful function
- USE logger ! log file manager
+ USE logger ! log file manager
USE dim ! dimension manager
USE att ! attribute manager
@@ -76,5 +102,4 @@
USE iom_rstdimg ! restart dimg I/O manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
@@ -86,21 +111,16 @@
PUBLIC :: iom_read_att !< read one attribute in an opened file
PUBLIC :: iom_read_var !< read one variable in an opened file
- PUBLIC :: iom_fill_var !< fill variable value
PUBLIC :: iom_write_file !< write file structure contents in an opened file
- ! PUBLIC :: iom_get_mpp ! get sub domain decomposition
-
- !< read variable or global attribute in an opened file
- PRIVATE :: iom__read_var_name_att_id !< given variable name or standard name and attribute id.
- PRIVATE :: iom__read_var_id_att_id !< given variable id and attribute id.
- PRIVATE :: iom__read_var_name_att_name !< given variable name or standard name, and attribute name.
- PRIVATE :: iom__read_var_id_att_name !< given variable id and attribute name.
-
- PRIVATE :: iom__read_dim_id !< read one dimension in an opened file, given dimension id.
- PRIVATE :: iom__read_dim_name !< read one dimension in an opened netcdf file, given dimension name.
- PRIVATE :: iom__read_var_id !< read variable value in an opened file, given variable id.
- PRIVATE :: iom__read_var_name !< read variable value in an opened file, given variable name or standard name.
- PRIVATE :: iom__fill_var_id !< fill variable value in an opened file, given variable id
- PRIVATE :: iom__fill_var_name !< fill variable value in an opened file, given variable name
- PRIVATE :: iom__fill_var_all !< fill all variable value in an opened file
+
+ ! read variable or global attribute in an opened file
+ PRIVATE :: iom__read_att_varname_id ! given variable name or standard name and attribute id.
+ PRIVATE :: iom__read_att_varid_id ! given variable id and attribute id.
+ PRIVATE :: iom__read_att_varname_name ! given variable name or standard name, and attribute name.
+ PRIVATE :: iom__read_att_varid_name ! given variable id and attribute name.
+
+ PRIVATE :: iom__read_dim_id ! read one dimension in an opened file, given dimension id.
+ PRIVATE :: iom__read_dim_name ! read one dimension in an opened netcdf file, given dimension name.
+ PRIVATE :: iom__read_var_id ! read variable value in an opened file, given variable id.
+ PRIVATE :: iom__read_var_name ! read variable value in an opened file, given variable name or standard name.
INTERFACE iom_read_var
@@ -109,10 +129,4 @@
END INTERFACE iom_read_var
- INTERFACE iom_fill_var
- MODULE PROCEDURE iom__fill_var_id
- MODULE PROCEDURE iom__fill_var_name
- MODULE PROCEDURE iom__fill_var_all
- END INTERFACE
-
INTERFACE iom_read_dim
MODULE PROCEDURE iom__read_dim_id
@@ -121,16 +135,17 @@
INTERFACE iom_read_att !< read variable or global attribute in an opened file
- MODULE PROCEDURE iom__read_var_name_att_id !< given variable name or standard name and attribute id.
- MODULE PROCEDURE iom__read_var_id_att_id !< given variable id and attribute id.
- MODULE PROCEDURE iom__read_var_name_att_name !< given variable name or standard name, and attribute name.
- MODULE PROCEDURE iom__read_var_id_att_name !< given variable id and attribute name.
+ MODULE PROCEDURE iom__read_att_varname_id !< given variable name or standard name and attribute id.
+ MODULE PROCEDURE iom__read_att_varid_id !< given variable id and attribute id.
+ MODULE PROCEDURE iom__read_att_varname_name !< given variable name or standard name, and attribute name.
+ MODULE PROCEDURE iom__read_att_varid_name !< given variable id and attribute name.
END INTERFACE iom_read_att
CONTAINS
!-------------------------------------------------------------------
- !> @brief This function open a file in read or write mode
+ !> @brief This function open a file in read or write mode
+ !> @details
!> If try to open a file in write mode that did not exist, create it.
!>
- !> If file already exist, get information about:
+ !> If file exist, get information about:
!> - the number of variables
!> - the number of dimensions
@@ -141,9 +156,8 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_open(td_file)
IMPLICIT NONE
@@ -163,19 +177,17 @@
CALL iom_rstdimg_open(td_file)
CASE DEFAULT
- CALL logger_error("OPEN: unknow type : "//TRIM(td_file%c_name))
+ CALL logger_error("IOM OPEN: unknow type : "//TRIM(td_file%c_name))
END SELECT
END SUBROUTINE iom_open
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function create a file
+ !-------------------------------------------------------------------
+ !> @brief This function create a file.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_create(td_file)
IMPLICIT NONE
@@ -202,19 +214,17 @@
CALL iom_rstdimg_open(td_file)
CASE DEFAULT
- CALL logger_error( "CREATE: can't create file "//&
+ CALL logger_error( "IOM CREATE: can't create file "//&
& TRIM(td_file%c_name)//": type unknown " )
END SELECT
END SUBROUTINE iom_create
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine close file
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_close(td_file)
IMPLICIT NONE
@@ -230,30 +240,26 @@
CALL iom_rstdimg_close(td_file)
CASE DEFAULT
- CALL logger_error( " CLOSE: can't close file "//&
+ CALL logger_error( "IOM CLOSE: can't close file "//&
& TRIM(td_file%c_name)//": type unknown " )
END SELECT
END SUBROUTINE iom_close
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read attribute (of variable or global) in an opened
!> file, given variable name or standard name and attribute id.
- !> to get global attribute use 'GLOBAL' as variable name
- !>
- !> To check only standard name of the variable, put variable name to ''
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] cd_varname : variable name. use 'GLOBAL' to read global
+ !> @details
+ !> - to get global attribute use 'GLOBAL' as variable name.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] cd_varname variable name. use 'GLOBAL' to read global
!> attribute in a file
- !> @param[in] id_attid : attribute id
- !> @param[in] cd_stdname : variable standard name
+ !> @param[in] id_attid attribute id
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION iom__read_var_name_att_id( td_file, cd_varname, &
- & id_attid)
+ TYPE(TATT) FUNCTION iom__read_att_varname_id( td_file, cd_varname, &
+ & id_attid)
IMPLICIT NONE
! Argument
@@ -277,17 +283,16 @@
SELECT CASE(TRIM(td_file%c_type))
CASE('cdf')
- iom__read_var_name_att_id=iom_read_att( td_file, il_varid, &
+ iom__read_att_varname_id=iom_read_att( td_file, il_varid, &
& id_attid)
CASE('dimg')
- CALL logger_warn( " READ ATT: can't read attribute "//&
+ CALL logger_warn( " IOM READ ATT: can't read attribute "//&
& "in dimg file : "//TRIM(td_file%c_name) )
CASE DEFAULT
- CALL logger_error( " READ ATT: can't read attribute in file "//&
- & TRIM(td_file%c_name)//" : type unknown " )
+ CALL logger_error( " IOM READ ATT: can't read attribute "//&
+ & " in file "//TRIM(td_file%c_name)//" : type unknown " )
END SELECT
ENDIF
- END FUNCTION iom__read_var_name_att_id
- !> @endcode
+ END FUNCTION iom__read_att_varname_id
!-------------------------------------------------------------------
!> @brief This function read attribute (of variable or global) in an opened
@@ -295,14 +300,13 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_varid : variable id. use NF90_GLOBAL to read global
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_varid variable id. use NF90_GLOBAL to read global
!> attribute in a file
- !> @param[in] id_attid : attribute id
+ !> @param[in] id_attid attribute id
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION iom__read_var_id_att_id( td_file, id_varid, &
+ TYPE(TATT) FUNCTION iom__read_att_varid_id( td_file, id_varid, &
& id_attid)
IMPLICIT NONE
@@ -316,34 +320,31 @@
SELECT CASE(TRIM(td_file%c_type))
CASE('cdf')
- iom__read_var_id_att_id=iom_cdf_read_att( td_file, id_varid, &
+ iom__read_att_varid_id=iom_cdf_read_att( td_file, id_varid, &
& id_attid)
CASE('dimg')
- CALL logger_warn( " READ ATT: can't read attribute in dimg file "//&
+ CALL logger_warn( " IOM READ ATT: can't read attribute in dimg file "//&
& TRIM(td_file%c_name) )
CASE DEFAULT
- CALL logger_error( " READ ATT: can't read attribute in file "//&
- & TRIM(td_file%c_name)//" : type unknown " )
- END SELECT
-
- END FUNCTION iom__read_var_id_att_id
- !> @endcode
+ CALL logger_error( " IOM READ ATT: can't read attribute in file "//&
+ & TRIM(td_file%c_name)//" : type unknown " )
+ END SELECT
+
+ END FUNCTION iom__read_att_varid_id
!-------------------------------------------------------------------
!> @brief This function read attribute (of variable or global) in an opened
!> file, given variable name or standard name, and attribute name.
- !> to get global attribute use 'GLOBAL' as variable name.
- !>
- !> To check only standard name of the variable, put variable name to ''
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] cd_varname : variable name or standard name. use 'GLOBAL' to read global
+ !> @details
+ !> - to get global attribute use 'GLOBAL' as variable name.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] cd_varname variable name or standard name. use 'GLOBAL' to read global
!> attribute in a file
- !> @param[in] cd_attname : attribute name
+ !> @param[in] cd_attname attribute name
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION iom__read_var_name_att_name( td_file, cd_varname, &
+ TYPE(TATT) FUNCTION iom__read_att_varname_name( td_file, cd_varname, &
& cd_attname)
IMPLICIT NONE
@@ -368,17 +369,16 @@
SELECT CASE(TRIM(td_file%c_type))
CASE('cdf')
- iom__read_var_name_att_name=iom_cdf_read_att( td_file, il_varid, &
+ iom__read_att_varname_name=iom_cdf_read_att( td_file, il_varid, &
& cd_attname)
CASE('dimg')
- CALL logger_warn( " READ ATT: can't read attribute "//&
+ CALL logger_warn( " IOM READ ATT: can't read attribute "//&
& "in dimg file :"//TRIM(td_file%c_name) )
CASE DEFAULT
- CALL logger_error( " READ ATT: can't read attribute in file "//&
+ CALL logger_error( " IOM READ ATT: can't read attribute in file "//&
& TRIM(td_file%c_name)//" : type unknown " )
END SELECT
ENDIF
- END FUNCTION iom__read_var_name_att_name
- !> @endcode
+ END FUNCTION iom__read_att_varname_name
!-------------------------------------------------------------------
!> @brief This function read attribute (of variable or global) in an opened
@@ -386,14 +386,13 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_varid : variable id. use NF90_GLOBAL to read global
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_varid variable id. use NF90_GLOBAL to read global
!> attribute in a file
- !> @param[in] cd_name : attribute name
+ !> @param[in] cd_attname attribute name
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
- TYPE(TATT) FUNCTION iom__read_var_id_att_name( td_file, id_varid, &
+ TYPE(TATT) FUNCTION iom__read_att_varid_name( td_file, id_varid, &
& cd_attname)
IMPLICIT NONE
@@ -407,16 +406,15 @@
SELECT CASE(TRIM(td_file%c_type))
CASE('cdf')
- iom__read_var_id_att_name=iom_cdf_read_att( td_file, id_varid, &
+ iom__read_att_varid_name=iom_cdf_read_att( td_file, id_varid, &
& cd_attname)
CASE('dimg')
- CALL logger_warn( " READ ATT: can't read attribute in dimg file :"&
+ CALL logger_warn( " IOM READ ATT: can't read attribute in dimg file :"&
& //TRIM(td_file%c_name) )
CASE DEFAULT
- CALL logger_error( " READ ATT: can't read attribute in file "//&
- & TRIM(td_file%c_name)//" : type unknown " )
- END SELECT
-
- END FUNCTION iom__read_var_id_att_name
- !> @endcode
+ CALL logger_error( " IOM READ ATT: can't read attribute in file "//&
+ & TRIM(td_file%c_name)//" : type unknown " )
+ END SELECT
+
+ END FUNCTION iom__read_att_varid_name
!-------------------------------------------------------------------
!> @brief This function read one dimension in an opened file,
@@ -424,11 +422,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_dimid : dimension id
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_dimid dimension id
!> @return dimension structure
!-------------------------------------------------------------------
- !> @code
TYPE(TDIM) FUNCTION iom__read_dim_id(td_file, id_dimid)
IMPLICIT NONE
@@ -445,10 +442,9 @@
iom__read_dim_id=iom_rstdimg_read_dim(td_file, id_dimid)
CASE DEFAULT
- CALL logger_error( " READ DIM: can't read dimension in file "//&
+ CALL logger_error( " IOM READ DIM: can't read dimension in file "//&
& TRIM(td_file%c_name)//" : type unknown " )
END SELECT
END FUNCTION iom__read_dim_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read one dimension in an opened netcdf file,
@@ -456,11 +452,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] cd_name : dimension name
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] cd_name dimension name
!> @return dimension structure
!-------------------------------------------------------------------
- !> @code
TYPE(TDIM) FUNCTION iom__read_dim_name(td_file, cd_name)
IMPLICIT NONE
@@ -477,27 +472,26 @@
iom__read_dim_name=iom_rstdimg_read_dim(td_file, cd_name)
CASE DEFAULT
- CALL logger_error( " READ DIM: can't read dimension in file "//&
+ CALL logger_error( " IOM READ DIM: can't read dimension in file "//&
& TRIM(td_file%c_name)//" : type unknown " )
END SELECT
END FUNCTION iom__read_dim_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read variable value in an opened
- !> file, given variable id.
+ !> file, given variable id.
+ !> @details
!> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_varid : variable id
- !> @param[in] id_start : index in the variable from which the data values
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_varid variable id
+ !> @param[in] id_start index in the variable from which the data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
+ !> @param[in] id_count number of indices selected along each dimension
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
TYPE(TVAR) FUNCTION iom__read_var_id( td_file, id_varid,&
& id_start, id_count)
@@ -519,32 +513,29 @@
& id_start, id_count)
CASE DEFAULT
- CALL logger_error( " READ VAR: can't read variable in file "//&
+ CALL logger_error( " IOM READ VAR: can't read variable in file "//&
& TRIM(td_file%c_name)//" : type unknown " )
END SELECT
END FUNCTION iom__read_var_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read variable value in an opened
- !> file, given variable name or standard name.
+ !> file, given variable name or standard name.
+ !> @details
!> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @details
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
+ !>
!> look first for variable name. If it doesn't
!> exist in file, look for variable standard name.
- !> If variable name is not present, check variable standard name.
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] cd_name : variable name or standard name
- !> @param[in] id_start : index in the variable from which the data values
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] cd_name variable name or standard name
+ !> @param[in] id_start index in the variable from which the data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
+ !> @param[in] id_count number of indices selected along each dimension
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
TYPE(TVAR) FUNCTION iom__read_var_name(td_file, cd_name, &
& id_start, id_count )
@@ -552,9 +543,7 @@
! Argument
TYPE(TFILE) , INTENT(IN) :: td_file
- CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_name
+ CHARACTER(LEN=*) , INTENT(IN) :: cd_name
INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
INTEGER(i4) , DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
!----------------------------------------------------------------
@@ -568,138 +557,17 @@
& id_start, id_count )
CASE DEFAULT
- CALL logger_error( " READ VAR: can't read variable in file "//&
+ CALL logger_error( " IOM READ VAR: can't read variable in file "//&
& TRIM(td_file%c_name)//" : type unknown " )
END SELECT
END FUNCTION iom__read_var_name
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill all variables value in an opened
- !> file.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom__fill_var_all( td_file, id_start, id_count)
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
- !----------------------------------------------------------------
-
- ! open file
- SELECT CASE(TRIM(td_file%c_type))
- CASE('cdf')
- CALL iom_cdf_fill_var(td_file, id_start, id_count)
- CASE('dimg')
- CALL iom_rstdimg_fill_var(td_file, id_start, id_count)
- CASE DEFAULT
- CALL logger_error( " FILL VAR: can't read variable in file "//&
- & TRIM(td_file%c_name)//" : type unknown " )
- END SELECT
-
- END SUBROUTINE iom__fill_var_all
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill variable value in an opened
- !> file, given variable id.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] id_varid : variable id
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom__fill_var_id( td_file, id_varid, id_start, id_count)
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- INTEGER(i4), INTENT(IN) :: id_varid
- INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
- !----------------------------------------------------------------
-
- ! open file
- SELECT CASE(TRIM(td_file%c_type))
- CASE('cdf')
- CALL iom_cdf_fill_var(td_file, id_varid, id_start, id_count)
- CASE('dimg')
- CALL iom_rstdimg_fill_var(td_file, id_varid, id_start, id_count)
- CASE DEFAULT
- CALL logger_error( " FILL VAR: can't read variable in file "//&
- & TRIM(td_file%c_name)//" : type unknown " )
- END SELECT
-
- END SUBROUTINE iom__fill_var_id
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill variable value in an opened
- !> file, given variable name or standard name.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @details
- !> look first for variable name. If it doesn't
- !> exist in file, look for variable standard name.
- !> If variable name is not present, check variable standard name.
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] cd_name : variable name or standard name
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom__fill_var_name( td_file, cd_name, id_start, id_count )
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- CHARACTER(LEN=*), INTENT(IN) :: cd_name
- INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
- !----------------------------------------------------------------
-
- ! open file
- SELECT CASE(TRIM(td_file%c_type))
- CASE('cdf')
- CALL iom_cdf_fill_var(td_file, cd_name, id_start, id_count )
- CASE('dimg')
- CALL iom_rstdimg_fill_var(td_file, cd_name, id_start, id_count )
- CASE DEFAULT
- CALL logger_error( " FILL VAR: can't read variable in file "//&
- & TRIM(td_file%c_name)//" : type unknown " )
- END SELECT
-
- END SUBROUTINE iom__fill_var_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write file structure in an opened file.
!
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_write_file(td_file)
IMPLICIT NONE
@@ -715,40 +583,9 @@
CALL iom_rstdimg_write_file(td_file)
CASE DEFAULT
- CALL logger_error( " WRITE: can't write file "//&
+ CALL logger_error( " IOM WRITE: can't write file "//&
& TRIM(td_file%c_name)//" : type unknown " )
END SELECT
END SUBROUTINE iom_write_file
- !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This function get sub domain decomposition.
-! !
-! !> @details
-! !
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in] td_file : file structure
-! !-------------------------------------------------------------------
-! !> @code
-! TYPE(TMPP) FUNCTION iom_get_mpp(td_file)
-! IMPLICIT NONE
-! ! Argument
-! TYPE(TFILE), INTENT(INOUT) :: td_file
-! !----------------------------------------------------------------
-!
-! ! open file
-! SELECT CASE(TRIM(td_file%c_type))
-! CASE('cdf')
-! iom_get_mpp = iom_cdf_get_mpp(td_file)
-! CASE('dimg')
-! iom_get_mpp = iom_rstdimg_get_mpp(td_file)
-! CASE DEFAULT
-! CALL logger_error( " WRITE: can't write file "//&
-! & TRIM(td_file%c_name)//" : type unknown " )
-! END SELECT
-!
-! END FUNCTION iom_get_mpp
-! !> @endcode
END MODULE iom
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_cdf.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_cdf.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_cdf.f90 (revision 5214)
@@ -6,30 +6,42 @@
!
! DESCRIPTION:
-!> @brief
-!> This module is a library to read/write Netcdf file.
+!> @brief NETCDF Input/Output manager : Library to read Netcdf input files
!>
!> @details
-!>
!> to open netcdf file:
+!> @code
!> CALL iom_cdf_open(td_file)
-!> - td_file is file structure (see file.f90)
+!> @endcode
+!> - td_file is file structure (see @ref file)
!>
!> to write in netcdf file:
+!> @code
!> CALL iom_cdf_write_file(td_file)
+!> @endcode
!>
!> to close netcdf file:
+!> @code
!> CALL iom_cdf_close(tl_file)
+!> @endcode
!>
!> to read one dimension in netcdf file:
-!> tl_dim = iom_cdf_read_dim(tl_file, id_dimid)
-!> or
+!> @code
+!> tl_dim = iom_cdf_read_dim(tl_file, id_dimid)
+!> @endcode
+!> or
+!> @code
!> tl_dim = iom_cdf_read_dim(tl_file, cd_name)
+!> @endcode
!> - id_dimid is dimension id
!> - cd_name is dimension name
!>
-!> to read one global attribute in netcdf file:
-!> tl_att = iom_cdf_read_att(tl_file, id_varid, id_attid)
-!> or
+!> to read one attribute in netcdf file:
+!> @code
+!> tl_att = iom_cdf_read_att(tl_file, id_varid, id_attid)
+!> @endcode
+!> or
+!> @code
!> tl_att = iom_cdf_read_att(tl_file, id_varid, cd_name)
+!> @endcode
!> - id_varid is variable id
!> - id_attid is attribute id
@@ -37,33 +49,24 @@
!>
!> to read one variable in netcdf file:
-!> tl_var = iom_cdf_read_var(td_file, id_varid, [id_start, id_count])
-!> or
-!> tl_var = iom_cdf_read_var(td_file, cd_name, [id_start, [id_count,]] [cd_stdname])
+!> @code
+!> tl_var = iom_cdf_read_var(td_file, id_varid, [id_start, id_count])
+!> @endcode
+!> or
+!> @code
+!> tl_var = iom_cdf_read_var(td_file, cd_name, [id_start, [id_count,]])
+!> @endcode
!> - id_varid is variabale id
!> - cd_name is variabale name
-!> - id_start is a integer(4) 1D table of index from which the data
-!> values will be read (optional)
-!> - id_count is a integer(4) 1D table of the number of indices selected
-!> along each dimension (optional)
-!> - cd_stdname is variable standard name (optional)
+!> - id_start is a integer(4) 1D array of index from which the data
+!> values will be read [optional]
+!> - id_count is a integer(4) 1D array of the number of indices selected
+!> along each dimension [optional]
!>
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
-!> @param MyModule_type : brief_description
+!> @date November, 2013 - Initial Version
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!
-!> @todo
-!> - inform variable pni, pnj, pnij, area, iglo, jglo
-!> - use var_init when read new variable
-!> - use dim_init when read new dimension
-!> - use att_init when read new attribute
-!> - add read td_dom
-!> @todo
-!> - voir si il ne faut pas redefinir (__copy) variable si elle vient de mpp
-!> exemple CALL mpp_move_var( td_mpp, td_mpp%t_var )
!----------------------------------------------------------------------
MODULE iom_cdf
@@ -72,13 +75,10 @@
USE kind ! F90 kind parameter
USE fct ! basic useful function
- USE logger ! log file manager
+ USE logger ! log file manager
USE att ! attribute manage
USE dim ! dimension manager
USE var ! variable manager
USE file ! file manager
- USE dom ! domain manager
-! USE proc ! processor manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
@@ -91,30 +91,29 @@
PUBLIC :: iom_cdf_fill_var !< fill variable value in an opened netcdf file
PUBLIC :: iom_cdf_write_file !< write file structure contents in an opened netcdf file
- ! PUBLIC :: iom_cdf_get_mpp ! get sub domain decomposition in a netcdf file
-
- PRIVATE :: iom_cdf__check !< provides a simple interface to netcdf error message
- PRIVATE :: iom_cdf__get_info !< get global information in an opened netcdf file
- PRIVATE :: iom_cdf__get_file_dim !< read dimension on an opened netcdf file, and reorder it
- PRIVATE :: iom_cdf__get_file_att !< read global attribute on an opened netcdf file
- PRIVATE :: iom_cdf__get_file_var !< read information about variable on an opened netcdf file
- PRIVATE :: iom_cdf__read_dim_id !< read one dimension in an opened netcdf file, given dimension id.
- PRIVATE :: iom_cdf__read_dim_name !< read one dimension in an opened netcdf file, given dimension name.
- PRIVATE :: iom_cdf__read_att_name !< read variable or global attribute in an opened netcdf file, given attribute name.
- PRIVATE :: iom_cdf__read_att_id !< read variable or global attribute in an opened netcdf file, given attribute id.
- PRIVATE :: iom_cdf__read_var_id !< read variable value in an opened netcdf file, given variable id.
- PRIVATE :: iom_cdf__read_var_name !< read variable value in an opened netcdf file, given variable name or standard name.
- PRIVATE :: iom_cdf__read_var_meta !< read metadata of a variable in an opened netcdf file.
- PRIVATE :: iom_cdf__read_var_dim !< read variable dimension in an opened netcdf file.
- PRIVATE :: iom_cdf__read_var_att !< read variable attributes in an opened netcdf file.
- PRIVATE :: iom_cdf__read_var_value !< read variable value in an opened netcdf file.
- PRIVATE :: iom_cdf__write_dim !< write one dimension in an opened netcdf file in write mode.
- PRIVATE :: iom_cdf__write_att !< write a variable attribute in an opened netcdf file.
- PRIVATE :: iom_cdf__write_var !< write a variable in an opened netcdf file.
- PRIVATE :: iom_cdf__write_var_def !< define variable in an opened netcdf file.
- PRIVATE :: iom_cdf__write_var_value !< put variable value in an opened netcdf file.
- PRIVATE :: iom_cdf__fill_var_id !< fill variable value in an opened netcdf file, given variable id
- PRIVATE :: iom_cdf__fill_var_name !< fill variable value in an opened netcdf file, given variable name
- PRIVATE :: iom_cdf__fill_var_all !< fill all variable value in an opened netcdf file
- PRIVATE :: iom_cdf__del_var_dim !< remove variable dimension from an opened netcdf file
+
+ PRIVATE :: iom_cdf__check ! provides a simple interface to netcdf error message
+ PRIVATE :: iom_cdf__get_info ! get global information in an opened netcdf file
+ PRIVATE :: iom_cdf__get_file_dim ! read dimension on an opened netcdf file, and reorder it
+ PRIVATE :: iom_cdf__get_file_att ! read global attribute on an opened netcdf file
+ PRIVATE :: iom_cdf__get_file_var ! read information about variable on an opened netcdf file
+ PRIVATE :: iom_cdf__read_dim_id ! read one dimension in an opened netcdf file, given dimension id.
+ PRIVATE :: iom_cdf__read_dim_name ! read one dimension in an opened netcdf file, given dimension name.
+ PRIVATE :: iom_cdf__read_att_name ! read variable or global attribute in an opened netcdf file, given attribute name.
+ PRIVATE :: iom_cdf__read_att_id ! read variable or global attribute in an opened netcdf file, given attribute id.
+ PRIVATE :: iom_cdf__read_var_id ! read variable value in an opened netcdf file, given variable id.
+ PRIVATE :: iom_cdf__read_var_name ! read variable value in an opened netcdf file, given variable name or standard name.
+ PRIVATE :: iom_cdf__read_var_meta ! read metadata of a variable in an opened netcdf file.
+ PRIVATE :: iom_cdf__read_var_dim ! read variable dimension in an opened netcdf file.
+ PRIVATE :: iom_cdf__read_var_att ! read variable attributes in an opened netcdf file.
+ PRIVATE :: iom_cdf__read_var_value ! read variable value in an opened netcdf file.
+ PRIVATE :: iom_cdf__write_dim ! write one dimension in an opened netcdf file in write mode.
+ PRIVATE :: iom_cdf__write_att ! write a variable attribute in an opened netcdf file.
+ PRIVATE :: iom_cdf__write_var ! write a variable in an opened netcdf file.
+ PRIVATE :: iom_cdf__write_var_def ! define variable in an opened netcdf file.
+ PRIVATE :: iom_cdf__write_var_value ! put variable value in an opened netcdf file.
+ PRIVATE :: iom_cdf__fill_var_id ! fill variable value in an opened netcdf file, given variable id
+ PRIVATE :: iom_cdf__fill_var_name ! fill variable value in an opened netcdf file, given variable name
+ PRIVATE :: iom_cdf__fill_var_all ! fill all variable value in an opened netcdf file
+ PRIVATE :: iom_cdf__del_coord_var ! remove coordinate variable from an opened netcdf file
INTERFACE iom_cdf_read_var
@@ -145,9 +144,8 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] id_status : error status
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] id_status error status
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__check(id_status)
IMPLICIT NONE
@@ -161,9 +159,9 @@
END SUBROUTINE iom_cdf__check
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine open a netcdf file in read or write mode
+ !-------------------------------------------------------------------
+ !> @brief This subroutine open a netcdf file in read or write mode.
+ !> @details
!> if try to open a file in write mode that did not exist, create it.
- !> if file already exist, get information about:
+ !> if file already exist, get information about0:
!> - the number of variables
!> - the number of dimensions
@@ -171,12 +169,12 @@
!> - the ID of the unlimited dimension
!> - the file format
- !> and finally read dimensions.
+ !> Finally it read dimensions, and 'longitude' variable to compute East-West
+ !> overlap.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf_open(td_file)
IMPLICIT NONE
@@ -189,8 +187,4 @@
INTEGER(i4) :: il_status
-
- TYPE(TVAR) :: tl_lon
- ! loop indices
- INTEGER(i4) :: ji
!----------------------------------------------------------------
@@ -202,11 +196,10 @@
IF( .NOT. td_file%l_wrt )THEN
- CALL logger_fatal( " OPEN: can not open file "//&
+ CALL logger_fatal( " IOM CDF OPEN: can not open file "//&
& TRIM(td_file%c_name) )
- td_file%i_id=-1
-
+
ELSE
- CALL logger_info( " CREATE: file "//TRIM(td_file%c_name) )
+ CALL logger_info( " IOM CDF CREATE: file "//TRIM(td_file%c_name) )
il_status = NF90_CREATE( TRIM(td_file%c_name),&
@@ -220,26 +213,25 @@
ELSE
-
IF( td_file%i_id /= 0 )THEN
- CALL logger_error( " OPEN: file "//&
+ CALL logger_error( " IOM CDF OPEN: file "//&
& TRIM(td_file%c_name)//" already opened")
ELSE
-
+
IF( .NOT. td_file%l_wrt )THEN
- CALL logger_info( " OPEN: file "//&
+ CALL logger_info( " IOM CDF OPEN: file "//&
& TRIM(td_file%c_name)//" in read only mode" )
il_status = NF90_OPEN( TRIM(td_file%c_name), &
- & NF90_NOWRITE, &
+ & NF90_NOWRITE, &
& td_file%i_id)
CALL iom_cdf__check(il_status)
- CALL logger_debug("OPEN "//TRIM(td_file%c_name)//" "//TRIM(fct_str(td_file%i_id)))
+ CALL logger_trace("IOM CDF OPEN "//TRIM(td_file%c_name)//" "//TRIM(fct_str(td_file%i_id)))
ELSE
- CALL logger_info( " OPEN: file "//&
+ CALL logger_info( "IOM CDF OPEN: file "//&
& TRIM(td_file%c_name)//" in write mode" )
@@ -263,19 +255,6 @@
CALL iom_cdf__get_file_var(td_file)
- ! get ew overlap
- tl_lon=iom_cdf_read_var(td_file,'longitude')
- td_file%i_ew=dom_get_ew_overlap(tl_lon)
- CALL logger_debug(" IOM OPEN EW "//TRIM(fct_str(td_file%i_ew)) )
- WHERE( td_file%t_var(:)%t_dim(1)%l_use )
- td_file%t_var(:)%i_ew=td_file%i_ew
- END WHERE
- CALL var_clean(tl_lon)
-
- DO ji=1,td_file%i_nvar
- CALL logger_debug(TRIM(td_file%t_var(ji)%c_name)//": "//TRIM(fct_str(td_file%t_var(ji)%i_ew)) )
- ENDDO
-
! remove dimension variable from list of variable
- CALL iom_cdf__del_var_dim(td_file)
+ CALL iom_cdf__del_coord_var(td_file)
ENDIF
@@ -284,14 +263,12 @@
END SUBROUTINE iom_cdf_open
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine close netcdf file
+ !-------------------------------------------------------------------
+ !> @brief This subroutine close netcdf file.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf_close(td_file)
IMPLICIT NONE
@@ -307,9 +284,9 @@
CALL logger_error( &
- & " CLOSE: no id associated to file "//TRIM(td_file%c_name))
+ & " IOM CDF CLOSE: no id associated to file "//TRIM(td_file%c_name))
ELSE
CALL logger_info( &
- & " CLOSE: file "//TRIM(td_file%c_name))
+ & " IOM CDF CLOSE: file "//TRIM(td_file%c_name))
il_status = NF90_CLOSE(td_file%i_id)
@@ -321,8 +298,7 @@
END SUBROUTINE iom_cdf_close
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine get global information in an opened netcdf
- !> file.
+ !> file.
!> @details
!> It gets the number of variables, the number of dimensions,
@@ -331,10 +307,8 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__get_info(td_file)
IMPLICIT NONE
@@ -348,5 +322,5 @@
CALL logger_trace( &
- & " GET INFO: about netcdf file "//TRIM(td_file%c_name))
+ & " IOM CDF GET INFO: about netcdf file "//TRIM(td_file%c_name))
il_status=NF90_INQUIRE(td_file%i_id, td_file%i_ndim, &
@@ -365,17 +339,14 @@
END SUBROUTINE iom_cdf__get_info
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine read dimension on an opened netcdf file, and
- !> reorder dimension to ('x', 'y', 'z', 't').
+ !> reorder dimension to ('x', 'y', 'z', 't').
!> The dimension structure inside file structure is then completed.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__get_file_dim(td_file)
IMPLICIT NONE
@@ -401,5 +372,5 @@
IF( td_file%i_uldid == -1 )THEN
CALL logger_warn( &
- & " GET FILE DIM: there is no unlimited dimension in file "//&
+ & " IOM CDF GET FILE DIM: there is no unlimited dimension in file "//&
& TRIM(td_file%c_name))
ELSE
@@ -410,5 +381,5 @@
CALL logger_warn( &
- & " GET FILE DIM: there is no dimension in file "//&
+ & " IOM CDF GET FILE DIM: there is no dimension in file "//&
& TRIM(td_file%c_name))
@@ -419,17 +390,16 @@
END SUBROUTINE iom_cdf__get_file_dim
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine read global attribute on an opened netcdf
- !> file.
+ !> file.
!> The attribute structure inside file structure is then completed.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - use attribute periodicity read from the file if present.
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__get_file_att(td_file)
IMPLICIT NONE
@@ -437,4 +407,5 @@
TYPE(TFILE), INTENT(INOUT) :: td_file
+ ! local variable
! loop indices
INTEGER(i4) :: ji
@@ -443,4 +414,5 @@
IF( td_file%i_natt > 0 )THEN
IF(ASSOCIATED(td_file%t_att))THEN
+ CALL att_clean(td_file%t_att(:))
DEALLOCATE(td_file%t_att)
ENDIF
@@ -451,36 +423,24 @@
td_file%t_att(ji)=iom_cdf_read_att( td_file, NF90_GLOBAL, ji)
- SELECT CASE(TRIM(td_file%t_att(ji)%c_name))
- CASE('periodicity')
- td_file%i_perio=INT(td_file%t_att(ji)%d_value(1),i4)
- CASE('pivot_point')
- td_file%i_pivot=INT(td_file%t_att(ji)%d_value(1),i4)
- CASE('ew_overlap')
- td_file%i_ew=INT(td_file%t_att(ji)%d_value(1),i4)
- END SELECT
-
ENDDO
ELSE
CALL logger_debug( &
- & " GET FILE ATT: there is no global attribute in file "//&
+ & " IOM CDF GET FILE ATT: there is no global attribute in file "//&
& TRIM(td_file%c_name))
ENDIF
END SUBROUTINE iom_cdf__get_file_att
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine read information about variable of an
- !> opened netcdf file.
+ !> opened netcdf file.
!> The variable structure inside file structure is then completed.
!> @note variable value are not read !
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__get_file_var(td_file)
IMPLICIT NONE
@@ -497,4 +457,5 @@
IF( td_file%i_nvar > 0 )THEN
IF(ASSOCIATED(td_file%t_var))THEN
+ CALL var_clean(td_file%t_var(:))
DEALLOCATE(td_file%t_var)
ENDIF
@@ -504,5 +465,4 @@
! read dimension information
td_file%t_var(ji)=iom_cdf__read_var_meta( td_file, ji)
-
SELECT CASE(td_file%t_var(ji)%i_ndim)
CASE(0)
@@ -524,7 +484,9 @@
td_file%i_depthid=ji
ELSE
- CALL logger_error("IOM OPEN: find more than one "//&
- & "depth variable in file "//&
- & TRIM(td_file%c_name) )
+ IF( td_file%i_depthid /= ji )THEN
+ CALL logger_error("IOM CDF GET FILE VAR: find more than one "//&
+ & "depth variable in file "//&
+ & TRIM(td_file%c_name) )
+ ENDIF
ENDIF
ENDIF
@@ -554,21 +516,19 @@
ELSE
CALL logger_debug( &
- & " GET FILE VAR: there is no variable in file "//&
+ & " IOM CDF GET FILE VAR: there is no variable in file "//&
& TRIM(td_file%c_name))
ENDIF
END SUBROUTINE iom_cdf__get_file_var
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine delete variable dimension from an
- !> opened netcdf file.
- !
- !> @author J.Paul
- !> - 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_cdf__del_var_dim(td_file)
+ !-------------------------------------------------------------------
+ !> @brief This subroutine delete coordinate variable from an
+ !> opened netcdf file if present.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
+ SUBROUTINE iom_cdf__del_coord_var(td_file)
IMPLICIT NONE
! Argument
@@ -598,87 +558,8 @@
ELSE
CALL logger_debug( &
- & " DEL VAR DIM: there is no variable in file "//&
+ & " IOM CDF DEL VAR DIM: there is no variable in file "//&
& TRIM(td_file%c_name))
ENDIF
- END SUBROUTINE iom_cdf__del_var_dim
- !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This subroutine get variable time from an
-! !> opened netcdf file.
-! !
-! !> @author J.Paul
-! !> - 2013- Initial Version
-! !
-! !> @param[inout] td_file : file structure
-! !-------------------------------------------------------------------
-! !> @code
-! SUBROUTINE iom_cdf__get_var_time(td_file)
-! IMPLICIT NONE
-! ! Argument
-! TYPE(TFILE), INTENT(INOUT) :: td_file
-!
-! ! local variable
-! CHARACTER(LEN=lc) :: cl_name
-!
-! ! loop indices
-! INTEGER(i4) :: ji
-! !----------------------------------------------------------------
-! IF( td_file%i_nvar > 0 )THEN
-! DO ji=1,td_file%i_nvar
-! cl_name=TRIM(td_file%t_var(ji)%c_name)
-! IF( INDEX(cl_name,'time') /= 0 )THEN
-! ! read time variable
-! td_file%t_time=iom_cdf_read_var(td_file,ji)
-! ! remove time variable from variable list
-! CALL file_del_ver(td_file,TRIM(cl_name))
-! EXIT
-! ENDIF
-! ENDDO
-! ELSE
-! CALL logger_debug( &
-! & " GET VAR TIME: there is no variable in file "//&
-! & TRIM(td_file%c_name))
-! ENDIF
-! END SUBROUTINE iom_cdf__get_var_time
-! !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This subroutine get variable depth from an
-! !> opened netcdf file.
-! !
-! !> @author J.Paul
-! !> - 2013- Initial Version
-! !
-! !> @param[inout] td_file : file structure
-! !-------------------------------------------------------------------
-! !> @code
-! SUBROUTINE iom_cdf__get_var_depth(td_file)
-! IMPLICIT NONE
-! ! Argument
-! TYPE(TFILE), INTENT(INOUT) :: td_file
-!
-! ! local variable
-! CHARACTER(LEN=lc) :: cl_name
-!
-! ! loop indices
-! INTEGER(i4) :: ji
-! !----------------------------------------------------------------
-! IF( td_file%i_nvar > 0 )THEN
-! DO ji=1,td_file%i_nvar
-! cl_name=TRIM(td_file%t_var(ji)%c_name)
-! IF( INDEX(cl_name,'depth') /= 0 )THEN
-! ! read depth variable
-! td_file%t_depth=iom_cdf_read_var(td_file,ji)
-! ! remove depth variable from variable list
-! CALL file_del_ver(td_file,TRIM(cl_name))
-! EXIT
-! ENDIF
-! ENDDO
-! ELSE
-! CALL logger_debug( &
-! & " GET VAR TIME: there is no variable in file "//&
-! & TRIM(td_file%c_name))
-! ENDIF
-! END SUBROUTINE iom_cdf__get_var_depth
-! !> @endcode
+ END SUBROUTINE iom_cdf__del_coord_var
!-------------------------------------------------------------------
!> @brief This function read one dimension in an opened netcdf file,
@@ -686,11 +567,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_dimid : dimension id
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_dimid dimension id
!> @return dimension structure
!-------------------------------------------------------------------
- !> @code
TYPE(TDIM) FUNCTION iom_cdf__read_dim_id(td_file, id_dimid)
IMPLICIT NONE
@@ -709,5 +589,5 @@
CALL logger_error( &
- & " READ DIM: no id associated to file "//TRIM(td_file%c_name))
+ & " IOM CDF READ DIM: no id associated to file "//TRIM(td_file%c_name))
ELSE
@@ -715,6 +595,6 @@
iom_cdf__read_dim_id%i_id=id_dimid
- CALL logger_debug( &
- & " READ DIM: dimension "//TRIM(fct_str(id_dimid))//&
+ CALL logger_trace( &
+ & " IOM CDF READ DIM: dimension "//TRIM(fct_str(id_dimid))//&
& " in file "//TRIM(td_file%c_name))
@@ -728,5 +608,4 @@
END FUNCTION iom_cdf__read_dim_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read one dimension in an opened netcdf file,
@@ -734,11 +613,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] cd_name : dimension name
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] cd_name dimension name
!> @return dimension structure
!-------------------------------------------------------------------
- !> @code
TYPE(TDIM) FUNCTION iom_cdf__read_dim_name(td_file, cd_name)
IMPLICIT NONE
@@ -756,5 +634,5 @@
CALL logger_error( &
- & " READ DIM: no id associated to file "//TRIM(td_file%c_name))
+ & " IOM CDF READ DIM: no id associated to file "//TRIM(td_file%c_name))
ELSE
@@ -769,5 +647,4 @@
END FUNCTION iom_cdf__read_dim_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read variable or global attribute in an opened
@@ -775,13 +652,12 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_varid : variable id. use NF90_GLOBAL to read global
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_varid variable id. use NF90_GLOBAL to read global
!> attribute in a file
- !> @param[in] cd_name : attribute name
+ !> @param[in] cd_name attribute name
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
TYPE(TATT) FUNCTION iom_cdf__read_att_name(td_file, id_varid, cd_name)
IMPLICIT NONE
@@ -800,4 +676,5 @@
CHARACTER(LEN=lc) :: cl_value
+
INTEGER(i1), DIMENSION(:), ALLOCATABLE :: bl_value
INTEGER(i2), DIMENSION(:), ALLOCATABLE :: sl_value
@@ -810,5 +687,5 @@
CALL logger_error( &
- & " READ ATT: no id associated to file "//TRIM(td_file%c_name))
+ & " IOM CDF READ ATT: no id associated to file "//TRIM(td_file%c_name))
ELSE
@@ -819,12 +696,12 @@
IF( id_varid == NF90_GLOBAL )THEN
- CALL logger_debug( &
- & " READ ATT: inquire global attribute "//&
+ CALL logger_trace( &
+ & " IOM CDF READ ATT: inquire global attribute "//&
& " in file "//TRIM(td_file%c_name))
ELSE
- CALL logger_debug( &
- & " READ ATT: inquire attribute "//&
+ CALL logger_trace( &
+ & " IOM CDF READ ATT: inquire attribute "//&
& " of variable "//TRIM(fct_str(id_varid))//&
& " in file "//TRIM(td_file%c_name))
@@ -840,5 +717,5 @@
!! get attribute value
- CALL logger_debug( " READ ATT: get attribute "//TRIM(cl_name)//&
+ CALL logger_debug( " IOM CDF READ ATT: get attribute "//TRIM(cl_name)//&
& " in file "//TRIM(td_file%c_name))
@@ -851,5 +728,5 @@
CALL logger_error( &
- & " READ ATT: not enough space to put attribute "//&
+ & " IOM CDF READ ATT: not enough space to put attribute "//&
& TRIM(cl_name) )
@@ -872,7 +749,6 @@
IF(il_status /= 0 )THEN
- CALL logger_error( &
- & " READ ATT: not enough space to put attribute "//&
- & TRIM(cl_name) )
+ CALL logger_error( "IOM CDF READ ATT: "//&
+ & "not enough space to put attribute "//TRIM(cl_name) )
ELSE
@@ -897,5 +773,5 @@
CALL logger_error( &
- & " READ ATT: not enough space to put attribute "//&
+ & " IOM CDF READ ATT: not enough space to put attribute "//&
& TRIM(cl_name) )
@@ -921,5 +797,5 @@
CALL logger_error( &
- & " READ ATT: not enough space to put attribute "//&
+ & " IOM CDF READ ATT: not enough space to put attribute "//&
& TRIM(cl_name) )
@@ -944,5 +820,5 @@
CALL logger_error( &
- & " READ ATT: not enough space to put attribute "//&
+ & " IOM CDF READ ATT: not enough space to put attribute "//&
& TRIM(cl_name) )
@@ -968,5 +844,5 @@
CALL logger_error( &
- & " READ ATT: not enough space to put attribute "//&
+ & " IOM CDF READ ATT: not enough space to put attribute "//&
& TRIM(cl_name) )
@@ -992,5 +868,4 @@
END FUNCTION iom_cdf__read_att_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read variable or global attribute in an opened
@@ -998,13 +873,12 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_varid : variable id. use NF90_GLOBAL to read global
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_varid variable id. use NF90_GLOBAL to read global
!> attribute in a file
- !> @param[in] id_attid : attribute id
+ !> @param[in] id_attid attribute id
!> @return attribute structure
!-------------------------------------------------------------------
- !> @code
TYPE(TATT) FUNCTION iom_cdf__read_att_id(td_file, id_varid, id_attid)
IMPLICIT NONE
@@ -1022,7 +896,7 @@
CALL logger_error( &
- & " READ ATT: no id associated to file "//TRIM(td_file%c_name))
-
- ELSE
+ & "IOM CDF READ ATT: no id associated to file "//TRIM(td_file%c_name))
+
+ ELSE
! get attribute name
@@ -1036,22 +910,21 @@
END FUNCTION iom_cdf__read_att_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read variable value in an opened
- !> netcdf file, given variable id.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_varid : variable id
- !> @param[in] id_start : index in the variable from which the data values
+ !> netcdf file, given variable id.
+ !> @details
+ !> Optionaly, start indices and number of indices selected along each dimension
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_varid variable id
+ !> @param[in] id_start index in the variable from which the data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
+ !> @param[in] id_count number of indices selected along each dimension
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
TYPE(TVAR) FUNCTION iom_cdf__read_var_id(td_file, id_varid,&
& id_start, id_count)
@@ -1070,15 +943,14 @@
CALL logger_error( &
- & " IOM READ VAR: no id associated to file "//TRIM(td_file%c_name))
+ & " IOM CDF READ VAR: no id associated to file "//TRIM(td_file%c_name))
ELSE
- ! look for variable id
+ ! look for variable index
il_ind(:)=MINLOC(td_file%t_var(:)%i_id,mask=(td_file%t_var(:)%i_id==id_varid))
IF( il_ind(1) /= 0 )THEN
- iom_cdf__read_var_id=td_file%t_var(il_ind(1))
-
- print *,"iom_cdf__read_var_id ",trim(iom_cdf__read_var_id%c_name)," ",iom_cdf__read_var_id%i_ew
+ iom_cdf__read_var_id=var_copy(td_file%t_var(il_ind(1)))
+
!!! read variable value
CALL iom_cdf__read_var_value(td_file, iom_cdf__read_var_id, &
@@ -1086,7 +958,6 @@
ELSE
- print *,"iom_cdf__read_var_id "
CALL logger_error( &
- & " IOM READ VAR: there is no variable with id "//&
+ & " IOM CDF READ VAR: there is no variable with id "//&
& TRIM(fct_str(id_varid))//" in file "//TRIM(td_file%c_name))
ENDIF
@@ -1094,27 +965,23 @@
ENDIF
END FUNCTION iom_cdf__read_var_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read variable value in an opened
- !> netcdf file, given variable name or standard name.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
+ !> netcdf file, given variable name or standard name.
!> @details
+ !> Optionaly, start indices and number of indices selected along each dimension
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
+ !>
!> look first for variable name. If it doesn't
!> exist in file, look for variable standard name.
- !> If variable name is not present, check variable standard name.
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] cd_name : variable name
- !> @param[in] id_start : index in the variable from which the data values will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] cd_stdname : variable standard name
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] cd_name variable name or standard name.
+ !> @param[in] id_start index in the variable from which the data values will be read
+ !> @param[in] id_count number of indices selected along each dimension
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
TYPE(TVAR) FUNCTION iom_cdf__read_var_name(td_file, cd_name, &
& id_start, id_count )
@@ -1127,5 +994,5 @@
! local variable
- INTEGER(i4) :: il_ind
+ INTEGER(i4) :: il_varid
!----------------------------------------------------------------
! check if file opened
@@ -1133,5 +1000,5 @@
CALL logger_error( &
- & " IOM READ VAR: no id associated to file "//TRIM(td_file%c_name))
+ & " IOM CDF READ VAR: no id associated to file "//TRIM(td_file%c_name))
ELSE
@@ -1140,13 +1007,13 @@
CALL logger_error( &
- & " IOM READ VAR: you must specify a variable to read "//&
+ & " IOM CDF READ VAR: you must specify a variable to read "//&
& " in file "//TRIM(td_file%c_name))
ELSE
- il_ind=var_get_id(td_file%t_var(:), cd_name)
- IF( il_ind /= 0 )THEN
-
- iom_cdf__read_var_name=td_file%t_var(il_ind)
+ il_varid=var_get_index(td_file%t_var(:), cd_name)
+ IF( il_varid /= 0 )THEN
+
+ iom_cdf__read_var_name=var_copy(td_file%t_var(il_varid))
!!! read variable value
@@ -1158,5 +1025,5 @@
CALL logger_error( &
- & " IOM READ VAR: there is no variable with "//&
+ & " IOM CDF READ VAR: there is no variable with "//&
& " name or standard name "//TRIM(cd_name)//&
& " in file "//TRIM(td_file%c_name) )
@@ -1168,23 +1035,19 @@
END FUNCTION iom_cdf__read_var_name
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill variable value in an opened
- !> netcdf file, given variable id.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @note ne peut pas marcher qd on fait boucle sur les variable d'un
- !> fichier. puisque change id.
-
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] id_start : index in the variable from which the data values
+ !-------------------------------------------------------------------
+ !> @brief This subroutine fill all variable value from an opened
+ !> netcdf file.
+ !> @details
+ !> Optionaly, start indices and number of indices selected along each dimension
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] id_start index in the variable from which the data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__fill_var_all(td_file, id_start, id_count)
IMPLICIT NONE
@@ -1203,34 +1066,31 @@
CALL logger_error( &
- & " FILL VAR: no id associated to file "//TRIM(td_file%c_name))
+ & " IOM CDF FILL VAR: no id associated to file "//TRIM(td_file%c_name))
ELSE
DO ji=1,td_file%i_nvar
- CALL iom_cdf_fill_var(td_file, ji, id_start, id_count)
+ CALL iom_cdf_fill_var(td_file, td_file%t_var(ji)%i_id, &
+ & id_start, id_count)
ENDDO
ENDIF
END SUBROUTINE iom_cdf__fill_var_all
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine fill variable value in an opened
- !> netcdf file, given variable id.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @note ne peut pas marcher qd on fait boucle sur les variable d'un
- !> fichier. puisque change id.
-
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] id_varid : variable id
- !> @param[in] id_start : index in the variable from which the data values
+ !> netcdf file, given variable id.
+ !> @details
+ !> Optionaly, start indices and number of indices selected along each dimension
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] id_varid variable id
+ !> @param[in] id_start index in the variable from which the data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__fill_var_id(td_file, id_varid, id_start, id_count)
IMPLICIT NONE
@@ -1242,5 +1102,5 @@
! local variable
- INTEGER(i4), DIMENSION(1) :: il_ind
+ INTEGER(i4), DIMENSION(1) :: il_varid
! loop indices
@@ -1251,23 +1111,25 @@
CALL logger_error( &
- & " FILL VAR: no id associated to file "//TRIM(td_file%c_name))
+ & "IOM CDF FILL VAR: no id associated to file "//TRIM(td_file%c_name))
ELSE
! look for variable id
- il_ind(:)=MINLOC( td_file%t_var(:)%i_id, &
+ il_varid(:)=MINLOC( td_file%t_var(:)%i_id, &
& mask=(td_file%t_var(:)%i_id==id_varid))
- IF( il_ind(1) /= 0 )THEN
+ IF( il_varid(1) /= 0 )THEN
!!! read variable value
- CALL iom_cdf__read_var_value(td_file, td_file%t_var(il_ind(1)), &
+ CALL iom_cdf__read_var_value(td_file, td_file%t_var(il_varid(1)), &
& id_start, id_count)
DO ji=1,td_file%i_nvar
- CALL logger_debug(" var id "//TRIM(td_file%t_var(ji)%c_name)//" "//TRIM(fct_str(td_file%t_var(ji)%i_id)) )
+ CALL logger_debug(" IOM CDF FILL VAR: var id "//&
+ & TRIM(td_file%t_var(ji)%c_name)//" "//&
+ & TRIM(fct_str(td_file%t_var(ji)%i_id)) )
ENDDO
ELSE
CALL logger_error( &
- & " FILL VAR: there is no variable with id "//&
+ & " IOM CDF FILL VAR: there is no variable with id "//&
& TRIM(fct_str(id_varid))//" in file "//TRIM(td_file%c_name))
ENDIF
@@ -1275,25 +1137,22 @@
ENDIF
END SUBROUTINE iom_cdf__fill_var_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine fill variable value in an opened
- !> netcdf file, given variable name or standard name.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
+ !> netcdf file, given variable name or standard name.
!> @details
+ !> Optionaly, start indices and number of indices selected along each dimension
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
+ !>
!> look first for variable name. If it doesn't
!> exist in file, look for variable standard name.
- !> If variable name is not present, check variable standard name.
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] cd_name : variable name or standard name
- !> @param[in] id_start : index in the variable from which the data values will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !-------------------------------------------------------------------
- !> @code
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] cd_name variable name or standard name
+ !> @param[in] id_start index in the variable from which the data values will be read
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__fill_var_name(td_file, cd_name, id_start, id_count )
IMPLICIT NONE
@@ -1305,5 +1164,5 @@
! local variable
- INTEGER(i4) :: il_ind
+ INTEGER(i4) :: il_varid
!----------------------------------------------------------------
! check if file opened
@@ -1311,13 +1170,13 @@
CALL logger_error( &
- & " FILL VAR: no id associated to file "//TRIM(td_file%c_name))
+ & "IOM CDF FILL VAR: no id associated to file "//TRIM(td_file%c_name))
ELSE
- il_ind=var_get_id(td_file%t_var(:), cd_name)
- IF( il_ind /= 0 )THEN
+ il_varid=var_get_index(td_file%t_var(:), cd_name)
+ IF( il_varid /= 0 )THEN
!!! read variable value
- CALL iom_cdf__read_var_value(td_file, td_file%t_var(il_ind), &
+ CALL iom_cdf__read_var_value(td_file, td_file%t_var(il_varid), &
& id_start, id_count)
@@ -1325,5 +1184,5 @@
CALL logger_error( &
- & " FILL VAR: there is no variable with "//&
+ & "IOM CDF FILL VAR: there is no variable with "//&
& "name or standard name"//TRIM(cd_name)//&
& " in file "//TRIM(td_file%c_name))
@@ -1333,19 +1192,19 @@
END SUBROUTINE iom_cdf__fill_var_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read metadata of a variable in an opened
- !> netcdf file.
+ !> netcdf file.
!
!> @note variable value are not read
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] id_fileid : file id
- !> @param[in] id_varid : variable id
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - force to use FillValue=1.e20 if no FillValue for coordinate variable.
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_varid variable id
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
TYPE(TVAR) FUNCTION iom_cdf__read_var_meta(td_file, id_varid)
IMPLICIT NONE
@@ -1375,5 +1234,6 @@
CALL logger_error( &
- & " READ ATT: no id associated to file "//TRIM(td_file%c_name))
+ & " IOM CDF READ VAR META: no id associated to file "//&
+ & TRIM(td_file%c_name))
ELSE
@@ -1381,5 +1241,6 @@
! inquire variable
CALL logger_trace( &
- & " READ VAR: inquire variable "//TRIM(fct_str(id_varid))//&
+ & " IOM CDF READ VAR META: inquire variable "//&
+ & TRIM(fct_str(id_varid))//&
& " in file "//TRIM(td_file%c_name))
@@ -1393,8 +1254,6 @@
& il_natt )
CALL iom_cdf__check(il_status)
-
!!! fill variable dimension structure
tl_dim(:)=iom_cdf__read_var_dim( td_file, il_ndim, il_dimid(:) )
-
IF( il_natt /= 0 )THEN
ALLOCATE( tl_att(il_natt) )
@@ -1405,5 +1264,5 @@
il_attid=att_get_id(tl_att(:),'_FillValue')
IF( il_attid == 0 )THEN
- CALL logger_warn("IOM READ VAR: no _FillValue for variable "//&
+ CALL logger_info("IOM CDF READ VAR META: no _FillValue for variable "//&
& TRIM(cl_name)//" in file "//TRIM(td_file%c_name) )
@@ -1411,27 +1270,39 @@
IF( il_attid /= 0 )THEN
! create attribute _FillValue
- CALL logger_warn("IOM READ VAR: assume _FillValue is equal to "//&
+ CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//&
& "missing_value for variable "//TRIM(cl_name) )
- tl_fill=att_init('_FillValue',tl_att(il_attid)%d_value(:))
+ tl_fill=att_init('_FillValue',tl_att(il_attid)%d_value(:), &
+ & id_type=tl_att(il_attid)%i_type)
ELSE
! create attribute _FillValue
- CALL logger_warn("IOM READ VAR: assume _FillValue is equal to "//&
- & "zero for variable "//TRIM(cl_name) )
- tl_fill=att_init('_FillValue',0.)
- !tl_fill=att_init('_FillValue',1.e20)
+ SELECT CASE(TRIM(cl_name))
+ CASE DEFAULT
+ CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//&
+ & "zero for variable "//TRIM(cl_name) )
+ tl_fill=att_init('_FillValue',0.)
+ CASE('nav_lon','nav_lat', &
+ & 'glamt','glamu','glamv','glamf', &
+ & 'gphit','gphiu','gphiv','gphif')
+ CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//&
+ & "dummy fillValue (1.e20) for variable "//TRIM(cl_name) )
+ tl_fill=att_init('_FillValue',1.e20)
+ END SELECT
ENDIF
ALLOCATE( tl_tmp(il_natt) )
! save read attribut
- tl_tmp(:)=tl_att(:)
- ! change number of attribute in table
+ tl_tmp(:)=att_copy(tl_att(:))
+ ! change number of attribute in array
+ CALL att_clean(tl_att(:))
DEALLOCATE( tl_att )
ALLOCATE( tl_att(il_natt+1) )
! copy read attribut
- tl_att(1:il_natt)=tl_tmp(:)
+ tl_att(1:il_natt)=att_copy(tl_tmp(:))
+ ! clean
+ CALL att_clean(tl_tmp(:))
DEALLOCATE( tl_tmp )
! create attribute _FillValue
- tl_att(il_natt+1)=tl_fill
+ tl_att(il_natt+1)=att_copy(tl_fill)
ENDIF
@@ -1440,9 +1311,18 @@
ALLOCATE(tl_att(il_natt+1) )
! create attribute _FillValue
- CALL logger_warn("IOM READ VAR: assume _FillValue is equal to "//&
- & "zero for variable "//TRIM(cl_name) )
- tl_fill=att_init('_FillValue',0.)
+ SELECT CASE(TRIM(cl_name))
+ CASE DEFAULT
+ CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//&
+ & "zero for variable "//TRIM(cl_name) )
+ tl_fill=att_init('_FillValue',0.)
+ CASE('nav_lon','nav_lat', &
+ & 'glamt','glamu','glamv','glamf', &
+ & 'gphit','gphiu','gphiv','gphif')
+ CALL logger_info("IOM CDF READ VAR META: assume _FillValue is equal to "//&
+ & "dummy fillValue (1.e20) for variable "//TRIM(cl_name) )
+ tl_fill=att_init('_FillValue',1.e20)
+ END SELECT
! create attribute _FillValue
- tl_att(il_natt+1)=tl_fill
+ tl_att(il_natt+1)=att_copy(tl_fill)
ENDIF
@@ -1451,4 +1331,8 @@
& tl_att(:), id_id=id_varid )
+ ! clean
+ CALL dim_clean(tl_dim(:))
+ CALL att_clean(tl_fill)
+ CALL att_clean(tl_att(:))
DEALLOCATE( tl_att )
@@ -1456,24 +1340,24 @@
END FUNCTION iom_cdf__read_var_meta
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine read variable dimension
!> in an opened netcdf file.
- !
+ !>
!> @details
!> the number of dimension can't exceed 4,
!> and should be 'x', 'y', 'z', 't' (whatever their order).
- !> If the number of dimension read is less than 4, the table of dimension
+ !> If the number of dimension read is less than 4, the array of dimension
!> strucure is filled with unused dimension.
- !> So the table of dimension structure of a variable is always compose of 4
+ !> So the array of dimension structure of a variable is always compose of 4
!> dimension (use or not).
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_ndim number of dimension
+ !> @param[in] id_dimid array of dimension id
+ !> @return array dimension structure
+ !-------------------------------------------------------------------
FUNCTION iom_cdf__read_var_dim(td_file, id_ndim, id_dimid)
IMPLICIT NONE
@@ -1502,5 +1386,8 @@
CALL dim_reorder(tl_dim(:))
- iom_cdf__read_var_dim(:)=tl_dim(:)
+ iom_cdf__read_var_dim(:)=dim_copy(tl_dim(:))
+
+ ! clean
+ CALL dim_clean(tl_dim(:))
ELSE IF( id_ndim > 0 .AND. id_ndim <= 4 )THEN
@@ -1508,5 +1395,5 @@
DO ji = 1, id_ndim
- CALL logger_debug( " READ VAR DIM: get variable dimension "//&
+ CALL logger_trace( " IOM CDF READ VAR DIM: get variable dimension "//&
& TRIM(fct_str(ji)) )
@@ -1521,9 +1408,12 @@
CALL dim_reorder(tl_dim(:))
- iom_cdf__read_var_dim(:)=tl_dim(:)
+ iom_cdf__read_var_dim(:)=dim_copy(tl_dim(:))
+
+ ! clean
+ CALL dim_clean(tl_dim(:))
ELSE
- CALL logger_error(" READ VAR DIM: can't manage "//&
+ CALL logger_error(" IOM CDF READ VAR DIM: can't manage "//&
& TRIM(fct_str(id_ndim))//" dimension(s)" )
@@ -1531,5 +1421,4 @@
END FUNCTION iom_cdf__read_var_dim
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine read variable attributes
@@ -1537,11 +1426,11 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[inout] td_var : variable structure
- !> @return filled variable attribute structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_varid variable id
+ !> @param[in] id_natt number of attributes
+ !> @return array of attribute structure
+ !-------------------------------------------------------------------
FUNCTION iom_cdf__read_var_att(td_file, id_varid, id_natt)
IMPLICIT NONE
@@ -1555,5 +1444,4 @@
! local variable
- TYPE(TATT), DIMENSION(id_natt) :: tl_att
! loop indices
@@ -1562,35 +1450,35 @@
IF( id_natt > 0 )THEN
-
+
! read attributes
DO ji = 1, id_natt
- CALL logger_debug( " READ VAR ATT: get attribute "//&
+ CALL logger_trace( " IOM CDF READ VAR ATT: get attribute "//&
& TRIM(fct_str(ji)) )
- tl_att(ji)=iom_cdf_read_att(td_file, id_varid, ji)
+ iom_cdf__read_var_att(ji)=iom_cdf_read_att(td_file, id_varid, ji)
ENDDO
- iom_cdf__read_var_att(:)=tl_att(:)
-
ELSE
- CALL logger_debug( " READ VAR ATT: no attribute for variable " )
+ CALL logger_debug( " IOM CDF READ VAR ATT: no attribute for variable " )
ENDIF
END FUNCTION iom_cdf__read_var_att
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine read variable value
!> in an opened netcdf file.
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[inout] td_var : variable structure
- !> @param[in] id_start : index in the variable from which the data values will be read
- !> @param[in] id_count : number of indices selected along each dimension
+ !> @details
+ !> Optionaly, start indices and number of indices selected along each dimension
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[inout] td_var variable structure
+ !> @param[in] id_start index in the variable from which the data values will be read
+ !> @param[in] id_count number of indices selected along each dimension
!> @return variable structure completed
!
@@ -1598,5 +1486,4 @@
!> - warning do not change fill value when use scale factor..
!-------------------------------------------------------------------
- !> @code
SUBROUTINE iom_cdf__read_var_value(td_file, td_var, &
& id_start, id_count )
@@ -1610,173 +1497,186 @@
! local variable
INTEGER(i4) :: il_status
- INTEGER(i4) :: il_tmp1, il_tmp2, il_varid
+ INTEGER(i4) :: il_tmp1
+ INTEGER(i4) :: il_tmp2
+ INTEGER(i4) :: il_varid
INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
INTEGER(i4), DIMENSION(ip_maxdim) :: il_start_ord
INTEGER(i4), DIMENSION(ip_maxdim) :: il_count_ord
- REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
-
- TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim
+ REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value
+ REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_tmp
+
! loop indices
INTEGER(i4) :: ji
!----------------------------------------------------------------
- ! check id_count and id_start optionals parameters...
- IF( ( PRESENT(id_start) .AND. (.NOT. PRESENT(id_count))) .OR. &
- ((.NOT. PRESENT(id_start)) .AND. PRESENT(id_count) ) )THEN
- CALL logger_warn( &
- & " READ VAR VALUE: id_start and id_count should be both specify")
- ENDIF
-
- IF( PRESENT(id_start).AND.PRESENT(id_count) )THEN
-
- IF( SIZE(id_start(:)) /= ip_maxdim .OR. &
- & SIZE(id_count(:)) /= ip_maxdim )THEN
- CALL logger_error("READ VAR: dimension of table start or count "//&
- & " are invalid to read variable "//TRIM(td_var%c_name)//&
- & " in file "//TRIM(td_file%c_name) )
- ENDIF
-
- ! change dimension order from ('x','y','z','t')
- il_start(:)=dim_reorder_xyzt2(td_var%t_dim, id_start(:))
- il_count(:)=dim_reorder_xyzt2(td_var%t_dim, id_count(:))
-
- ! keep ordered table ('x','y','z','t')
- il_start_ord(:)=il_start(:)
- il_count_ord(:)=il_count(:)
-
+ ! check if variable in file structure
+ il_varid=var_get_id(td_file%t_var(:),TRIM(td_var%c_name))
+ IF( il_varid /= 0 )THEN
+
+ ! check id_count and id_start optionals parameters...
+ IF( ( PRESENT(id_start) .AND. (.NOT. PRESENT(id_count))) .OR. &
+ ((.NOT. PRESENT(id_start)) .AND. PRESENT(id_count) ) )THEN
+ CALL logger_warn( &
+ & "IOM CDF READ VAR VALUE: id_start and id_count should be both specify")
+ ENDIF
+ IF( PRESENT(id_start).AND.PRESENT(id_count) )THEN
+
+ IF( SIZE(id_start(:)) /= ip_maxdim .OR. &
+ & SIZE(id_count(:)) /= ip_maxdim )THEN
+ CALL logger_error("IOM CDF READ VAR: dimension of array start or count "//&
+ & " are invalid to read variable "//TRIM(td_var%c_name)//&
+ & " in file "//TRIM(td_file%c_name) )
+ ENDIF
+
+ ! change dimension order from ('x','y','z','t')
+ il_start(:)=dim_reorder_xyzt2(td_var%t_dim, id_start(:))
+ il_count(:)=dim_reorder_xyzt2(td_var%t_dim, id_count(:))
+
+ ! keep ordered array ('x','y','z','t')
+ il_start_ord(:)=id_start(:)
+ il_count_ord(:)=id_count(:)
+
+ ELSE
+
+ ! change dimension order from ('x','y','z','t')
+ il_start(:)=(/1,1,1,1/)
+ il_count(:)=dim_reorder_xyzt2(td_var%t_dim(:),td_var%t_dim(:)%i_len)
+
+ ! keep ordered array ('x','y','z','t')
+ il_start_ord(:)=(/1,1,1,1/)
+ il_count_ord(:)=td_var%t_dim(:)%i_len
+
+ ENDIF
+
+ ! check dimension
+ IF( .NOT. ALL(il_start_ord(:)>=(/1,1,1,1/)) )THEN
+
+ CALL logger_error( "IOM CDF READ VAR VALUE: start indices should"//&
+ & " be greater than or equal to 1")
+
+ ENDIF
+
+ IF(.NOT.ALL(il_start_ord(:)+il_count_ord(:)-1 <= &
+ & (/td_var%t_dim( 1 )%i_len,&
+ & td_var%t_dim( 2 )%i_len,&
+ & td_var%t_dim( 3 )%i_len,&
+ & td_var%t_dim( 4 )%i_len &
+ & /)) )THEN
+
+ CALL logger_error( "IOM CDF READ VAR VALUE: start + count exceed "//&
+ & "variable dimension for "//TRIM(td_var%c_name) )
+
+ DO ji = 1, ip_maxdim
+ il_tmp1=il_start_ord(ji)+il_count_ord(ji)-1
+ il_tmp2=td_var%t_dim(ji)%i_len
+ CALL logger_debug( "IOM CDF READ VAR VALUE: start + count -1:"//&
+ & TRIM(fct_str(il_tmp1))//" variable dimension"//&
+ & TRIM(fct_str(il_tmp2)))
+ ENDDO
+
+ ELSE
+
+ ! Allocate space to hold variable value (unorder)
+ ALLOCATE(dl_value( il_count(1), &
+ & il_count(2), &
+ & il_count(3), &
+ & il_count(4)),&
+ & stat=il_status)
+ IF( il_status /= 0 )THEN
+
+ CALL logger_error( &
+ & "IOM CDF READ VAR VALUE: not enough space to put variable "//&
+ & TRIM(td_var%c_name))
+
+ ENDIF
+
+ ! read values
+ CALL logger_debug( &
+ & "IOM CDF READ VAR VALUE: get variable "//TRIM(td_var%c_name)//&
+ & " in file "//TRIM(td_file%c_name))
+
+ il_status = NF90_GET_VAR( td_file%i_id, il_varid, &
+ & dl_value(:,:,:,:), &
+ & start = il_start(:),&
+ & count = il_count(:) )
+ CALL iom_cdf__check(il_status)
+
+ ! Allocate space to hold variable value in structure
+ IF( ASSOCIATED(td_var%d_value) )THEN
+ DEALLOCATE(td_var%d_value)
+ ENDIF
+
+ ! new dimension length
+ td_var%t_dim(:)%i_len=il_count_ord(:)
+
+!> dummy patch for pgf95
+ ALLOCATE( dl_tmp( td_var%t_dim(1)%i_len, &
+ & td_var%t_dim(2)%i_len, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len),&
+ & stat=il_status)
+ IF(il_status /= 0 )THEN
+
+ CALL logger_error( &
+ & "IOM CDF READ VAR VALUE: not enough space to put variable "//&
+ & TRIM(td_var%c_name)//&
+ & " in variable structure")
+ ENDIF
+ dl_tmp(:,:,:,:)=td_var%d_fill
+
+ ! reshape values to be ordered as ('x','y','z','t')
+ dl_tmp(:,:,:,:)=dim_reshape_2xyzt(td_var%t_dim(:), &
+ & dl_value(:,:,:,:))
+
+ DEALLOCATE(dl_value)
+
+ ALLOCATE(td_var%d_value( td_var%t_dim(1)%i_len, &
+ & td_var%t_dim(2)%i_len, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len),&
+ & stat=il_status)
+ IF(il_status /= 0 )THEN
+
+ CALL logger_error( &
+ & "IOM CDF READ VAR VALUE: not enough space to put variable "//&
+ & TRIM(td_var%c_name)//&
+ & " in variable structure")
+
+ ENDIF
+! ! FillValue by default
+! td_var%d_value(:,:,:,:)=td_var%d_fill
+!
+! ! reshape values to be ordered as ('x','y','z','t')
+! td_var%d_value(:,:,:,:)=dim_reshape_2xyzt(td_var%t_dim(:), &
+! & dl_value(:,:,:,:))
+!
+! DEALLOCATE(dl_value)
+
+ td_var%d_value(:,:,:,:)=dl_tmp(:,:,:,:)
+ DEALLOCATE(dl_tmp)
+!< dummy patch for pgf95
+
+ ! force to change _FillValue to avoid mistake
+ ! with dummy zero _FillValue
+ IF( td_var%d_fill == 0._dp )THEN
+ CALL var_chg_FillValue(td_var)
+ ENDIF
+ ENDIF
ELSE
-
- ! change dimension order from ('x','y','z','t')
- il_start(:)=(/1,1,1,1/)
- il_count(:)=dim_reorder_xyzt2(td_var%t_dim(:),td_var%t_dim(:)%i_len)
-
- ! keep ordered table ('x','y','z','t')
- il_start_ord(:)=(/1,1,1,1/)
- il_count_ord(:)=td_var%t_dim(:)%i_len
-
- ENDIF
-
- ! check dimension
- IF( .NOT. ALL(il_start_ord(:)>=(/1,1,1,1/)) )THEN
-
CALL logger_error( &
- &" READ VAR VALUE: start indices should be greater than or equal to 1")
-
- ENDIF
-
- IF(.NOT.ALL(il_start_ord(:)+il_count_ord(:)-1<=(/td_var%t_dim(1)%i_len,&
- & td_var%t_dim(2)%i_len,&
- & td_var%t_dim(3)%i_len,&
- & td_var%t_dim(4)%i_len &
- & /)) )THEN
-
- CALL logger_error( &
- & " READ VAR VALUE: start + count exceed variable dimension" )
-
- DO ji = 1, ip_maxdim
- il_tmp1=il_start_ord(ji)+il_count_ord(ji)
- il_tmp2=td_var%t_dim(ji)%i_len
- CALL logger_debug( &
- & " READ VAR VALUE: start + count -1 "//TRIM(fct_str(il_tmp1))//&
- & " variable dimension"//TRIM(fct_str(il_tmp2)))
- ENDDO
-
- ELSE
-
- ! Allocate space to hold variable value (unorder)
- ALLOCATE(dl_value( il_count(1), &
- & il_count(2), &
- & il_count(3), &
- & il_count(4)),&
- & stat=il_status)
- IF( il_status /= 0 )THEN
-
- CALL logger_error( &
- & " READ VAR VALUE: not enough space to put variable "//&
- & TRIM(td_var%c_name))
-
- ENDIF
-
- ! read values
- CALL logger_debug( &
- & " READ VAR VALUE: get variable "//TRIM(td_var%c_name)//&
- & " in file "//TRIM(td_file%c_name))
- CALL logger_debug("start "//TRIM(fct_str(il_start(1)))//','//&
- & TRIM(fct_str(il_start(2)))//','//&
- & TRIM(fct_str(il_start(3)))//','//&
- & TRIM(fct_str(il_start(4)))//')' )
- CALL logger_debug("count "//TRIM(fct_str(il_count(1)))//','//&
- & TRIM(fct_str(il_count(2)))//','//&
- & TRIM(fct_str(il_count(3)))//','//&
- & TRIM(fct_str(il_count(4)))//')' )
- CALL logger_debug("dim "//TRIM(fct_str(td_file%t_dim(1)%i_len))//','//&
- & TRIM(fct_str(td_file%t_dim(2)%i_len))//','//&
- & TRIM(fct_str(td_file%t_dim(3)%i_len))//','//&
- & TRIM(fct_str(td_file%t_dim(4)%i_len))//')' )
- CALL logger_debug("shape "//TRIM(fct_str(SIZE(dl_value,DIM=1)))//","//&
- & TRIM(fct_str(SIZE(dl_value,DIM=2)))//","//&
- & TRIM(fct_str(SIZE(dl_value,DIM=3)))//","//&
- & TRIM(fct_str(SIZE(dl_value,DIM=4)))//")" )
- CALL logger_debug("var "//TRIM(td_var%c_name))
- il_varid=var_get_id(td_file%t_var(:),TRIM(td_var%c_name))
- CALL logger_debug("var id "//TRIM(fct_str(il_varid))//' '//TRIM(fct_str(td_var%i_id)))
- CALL logger_debug("file id "//TRIM(fct_str(td_file%i_id)))
- il_status = NF90_GET_VAR( td_file%i_id, td_var%i_id, &
- & dl_value(:,:,:,:), &
- & start = il_start(:),&
- & count = il_count(:) )
- CALL iom_cdf__check(il_status)
-
- ! Allocate space to hold variable value in structure
- IF( ASSOCIATED(td_var%d_value) )THEN
- DEALLOCATE(td_var%d_value)
- ENDIF
-
- ! new dimension length
- td_var%t_dim(:)%i_len=il_count_ord(:)
-
- ALLOCATE(td_var%d_value( il_count_ord(1), &
- & il_count_ord(2), &
- & il_count_ord(3), &
- & il_count_ord(4)),&
- & stat=il_status)
- IF(il_status /= 0 )THEN
-
- CALL logger_error( &
- & " READ VAR VALUE: not enough space to put variable "//&
- & TRIM(td_var%c_name)//&
- & " in variable structure")
-
- ENDIF
- ! FillValue by default
- td_var%d_value(:,:,:,:)=td_var%d_fill
-
- ! reshape values to be ordered as ('x','y','z','t')
- tl_dim(:)=td_var%t_dim(:)
- td_var%d_value(:,:,:,:)=dim_reshape_2xyzt(tl_dim,dl_value(:,:,:,:))
-
- DEALLOCATE(dl_value)
-
- ! force to change _FillValue to avoid mistake
- ! with dummy zero _FillValue
- IF( td_var%d_fill == 0._dp )THEN
- CALL var_chg_FillValue(td_var)
- ENDIF
+ & "IOM CDF READ VAR VALUE: no variable "//TRIM(td_var%c_name)//&
+ & " in file structure "//TRIM(td_file%c_name))
ENDIF
END SUBROUTINE iom_cdf__read_var_value
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write file structure in an opened netcdf file.
!
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf_write_file(td_file)
IMPLICIT NONE
@@ -1800,14 +1700,14 @@
CALL logger_error( &
- & " WRITE FILE: no id associated to file "//TRIM(td_file%c_name))
+ & " IOM CDF WRITE FILE: no id associated to file "//TRIM(td_file%c_name))
ELSE
IF( td_file%l_wrt )THEN
- ! delete dummy variable
- CALL file_del_var( td_file, 'no0d' )
- CALL file_del_var( td_file, 'no1d' )
- CALL file_del_var( td_file, 'no2d' )
- CALL file_del_var( td_file, 'no3d' )
+ ! remove dummy variable
+ CALL file_del_var(td_file,'no0d')
+ CALL file_del_var(td_file,'no1d')
+ CALL file_del_var(td_file,'no2d')
+ CALL file_del_var(td_file,'no3d')
DO ji = 1, td_file%i_nvar
@@ -1816,9 +1716,13 @@
! save usefull dimension
- tl_dim(:)=var_max_dim(td_file%t_var(:))
-
- DO ji=1,ip_maxdim
- IF( tl_dim(ji)%l_use ) CALL file_move_dim(td_file, tl_dim(ji))
- ENDDO
+ IF( ASSOCIATED(td_file%t_var) )THEN
+ tl_dim(:)=var_max_dim(td_file%t_var(:))
+
+ DO ji=1,ip_maxdim
+ IF( tl_dim(ji)%l_use ) CALL file_move_dim(td_file, tl_dim(ji))
+ ENDDO
+ ! clean
+ CALL dim_clean(tl_dim(:))
+ ENDIF
! write dimension in file
@@ -1836,6 +1740,10 @@
DEALLOCATE(il_value)
+
+ ! do not use FillValue for dimension variable
+ CALL var_del_att(tl_var, "_FillValue")
CALL iom_cdf__write_var(td_file,tl_var)
+ ! clean
CALL var_clean(tl_var)
@@ -1856,5 +1764,5 @@
CALL logger_error( &
- & " WRITE FILE: try to write in file "//TRIM(td_file%c_name)//&
+ & "IOM CDF WRITE FILE: try to write in file "//TRIM(td_file%c_name)//&
& ", not opened in write mode")
@@ -1863,5 +1771,4 @@
END SUBROUTINE iom_cdf_write_file
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write one dimension in an opened netcdf
@@ -1869,10 +1776,9 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[inout] td_dim : dimension structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[inout] td_dim dimension structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__write_dim(td_file, td_dim)
IMPLICIT NONE
@@ -1887,6 +1793,6 @@
IF( .NOT. td_file%l_def )THEN
- CALL logger_debug( &
- & " WRITE FILE DIM: Enter define mode, file "//TRIM(td_file%c_name))
+ CALL logger_trace( &
+ & " IOM CDF WRITE FILE DIM: Enter define mode, file "//TRIM(td_file%c_name))
! Enter define mode
@@ -1901,6 +1807,6 @@
IF( td_dim%l_uld )THEN
! write unlimited dimension
- CALL logger_debug( &
- & " WRITE FILE DIM: write unlimited dimension "//&
+ CALL logger_trace( &
+ & "IOM CDF WRITE FILE DIM: write unlimited dimension "//&
& TRIM(td_dim%c_name)//" in file "//TRIM(td_file%c_name))
@@ -1911,6 +1817,6 @@
ELSE
! write not unlimited dimension
- CALL logger_debug( &
- & " WRITE FILE DIM: write dimension "//TRIM(td_dim%c_name)//&
+ CALL logger_trace( &
+ & "IOM CDF WRITE FILE DIM: write dimension "//TRIM(td_dim%c_name)//&
& " in file "//TRIM(td_file%c_name))
@@ -1923,5 +1829,4 @@
END SUBROUTINE iom_cdf__write_dim
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write a variable attribute in
@@ -1929,12 +1834,11 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] id_varid : variable id. use NF90_GLOBAL to write global attribute
- !> in a file
- !> @param[in] td_att : attribute structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] id_varid variable id. use NF90_GLOBAL to write
+ !> global attribute in a file
+ !> @param[in] td_att attribute structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__write_att(td_file, id_varid, td_att)
IMPLICIT NONE
@@ -1950,6 +1854,6 @@
IF( .NOT. td_file%l_def )THEN
- CALL logger_debug( &
- & " WRITE FILE ATT: Enter define mode, file "//TRIM(td_file%c_name))
+ CALL logger_trace( &
+ & "IOM CDF WRITE FILE ATT: Enter define mode, file "//TRIM(td_file%c_name))
! Enter define mode
@@ -1962,6 +1866,6 @@
!! put attribute value
- CALL logger_debug( &
- & " WRITE FILE ATT: write attribute "//TRIM(td_att%c_name)//&
+ CALL logger_trace( &
+ & "IOM CDF WRITE FILE ATT: write attribute "//TRIM(td_att%c_name)//&
& " of variable "//TRIM(fct_str(id_varid))//&
& " in file "//TRIM(td_file%c_name))
@@ -1983,15 +1887,13 @@
END SUBROUTINE iom_cdf__write_att
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine write a variable in an opened netcdf file.
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[inout] td_var : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !-------------------------------------------------------------------
+ !> @brief This subroutine write a variable in an opened netcdf file.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[inout] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__write_var(td_file, td_var)
IMPLICIT NONE
@@ -2002,10 +1904,14 @@
! local variable
INTEGER(i4) :: il_status
+ LOGICAL :: ll_chg
+ ! loop indices
+ INTEGER(i4) :: ji
!----------------------------------------------------------------
IF( .NOT. td_file%l_def )THEN
- CALL logger_debug( &
- & " WRITE FILE VAR: Enter define mode, file "//TRIM(td_file%c_name))
+ CALL logger_trace( &
+ & " IOM CDF WRITE VAR: Enter define mode, file "//&
+ & TRIM(td_file%c_name))
! Enter define mode
@@ -2023,6 +1929,20 @@
CALL var_check_dim(td_var)
- ! change fill value to NETCDF standard
- CALL var_chg_FillValue(td_var)
+ ll_chg=.TRUE.
+ DO ji=1,ip_maxdim
+ IF( TRIM(fct_lower(cp_dimorder(ji:ji))) == &
+ & TRIM(fct_lower(td_var%c_name)) )THEN
+ ll_chg=.FALSE.
+ CALL logger_trace(TRIM(fct_lower(td_var%c_name))//' is var dimension')
+ EXIT
+ ENDIF
+ ENDDO
+ IF( ll_chg )THEN
+ ! not a dimension variable
+ ! change FillValue
+
+ ! ugly patch until NEMO do not force to use 0. as FillValue
+ CALL var_chg_FillValue(td_var,0._dp)
+ ENDIF
! define variable in file
@@ -2031,6 +1951,7 @@
IF( td_file%l_def )THEN
- CALL logger_debug( &
- & " WRITE FILE VAR: Leave define mode, file "//TRIM(td_file%c_name))
+ CALL logger_trace( &
+ & " IOM CDF WRITE VAR: Leave define mode, file "//&
+ & TRIM(td_file%c_name))
! Leave define mode
@@ -2050,16 +1971,14 @@
END SUBROUTINE iom_cdf__write_var
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function define variable in an opened netcdf file.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] td_var : variable structure
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] td_var variable structure
!> @return variable id
!-------------------------------------------------------------------
- !> @code
INTEGER(i4) FUNCTION iom_cdf__write_var_def(td_file, td_var)
IMPLICIT NONE
@@ -2070,5 +1989,8 @@
! local variable
INTEGER(i4) :: il_status
+ INTEGER(i4) :: il_ind
INTEGER(i4), DIMENSION(ip_maxdim) :: il_dimid
+
+ TYPE(TVAR) :: tl_var
! loop indices
@@ -2077,12 +1999,11 @@
!----------------------------------------------------------------
- CALL logger_debug( &
- & " WRITE FILE VAR DEF: get dimension to be used for variable "//&
- & TRIM(td_var%c_name)//" in file "//TRIM(td_file%c_name))
-
- IF( ALL( .NOT. td_var%t_dim(:)%l_use ) )THEN
+ ! copy structure
+ tl_var=var_copy(td_var)
+
+ IF( ALL( .NOT. tl_var%t_dim(:)%l_use ) )THEN
! scalar value
- il_status = NF90_DEF_VAR(td_file%i_id, TRIM(td_var%c_name), &
- & td_var%i_type, varid=iom_cdf__write_var_def)
+ il_status = NF90_DEF_VAR(td_file%i_id, TRIM(tl_var%c_name), &
+ & tl_var%i_type, varid=iom_cdf__write_var_def)
CALL iom_cdf__check(il_status)
ELSE
@@ -2093,20 +2014,19 @@
! reorder dimension, so unused dimension won't be written
DO ji = 1, ip_maxdim
- IF( td_var%t_dim(ji)%l_use )THEN
+ IF( tl_var%t_dim(ji)%l_use )THEN
jj=jj+1
- CALL logger_debug(" get dim id for dimension "//TRIM(td_var%t_dim(ji)%c_name))
- il_dimid(jj)=dim_get_id(td_file%t_dim(:),td_var%t_dim(ji)%c_name)
+ il_dimid(jj)=dim_get_id(td_file%t_dim(:),tl_var%t_dim(ji)%c_name)
ENDIF
ENDDO
- CALL logger_debug( &
- & " WRITE FILE VAR DEF: define dimension to be used for variable "//&
- & TRIM(td_var%c_name)//" in file "//TRIM(td_file%c_name))
+ CALL logger_trace( &
+ & "IOM CDF WRITE VAR DEF: define dimension to be used for variable "//&
+ & TRIM(tl_var%c_name)//" in file "//TRIM(td_file%c_name))
DO ji=1,jj
- CALL logger_debug(" WRITE FILE VAR DEF: dimid "//TRIM(fct_str(il_dimid(ji))) )
+ CALL logger_trace("IOM CDF WRITE VAR DEF: dimid "//TRIM(fct_str(il_dimid(ji))) )
ENDDO
- il_status = NF90_DEF_VAR(td_file%i_id, TRIM(td_var%c_name), &
- & td_var%i_type, &
+ il_status = NF90_DEF_VAR(td_file%i_id, TRIM(tl_var%c_name), &
+ & tl_var%i_type, &
& il_dimid(1:jj), &
& varid=iom_cdf__write_var_def )
@@ -2114,45 +2034,52 @@
ENDIF
- DO ji = 1, td_var%i_natt
- CALL logger_debug( &
- & " WRITE FILE VAR DEF: put attribute "//TRIM(td_var%t_att(ji)%c_name)//&
- & " for variable "//TRIM(td_var%c_name)//&
+ ! remove unuseful attribute
+ il_ind=att_get_index( tl_var%t_att(:), "ew_overlap" )
+ IF( il_ind /= 0 )THEN
+ IF( tl_var%t_att(il_ind)%d_value(1) == -1 )THEN
+ CALL var_del_att(tl_var, tl_var%t_att(il_ind))
+ ENDIF
+ ENDIF
+
+ DO ji = 1, tl_var%i_natt
+ CALL logger_trace( &
+ & " IOM CDF WRITE VAR DEF: put attribute "//TRIM(tl_var%t_att(ji)%c_name)//&
+ & " for variable "//TRIM(tl_var%c_name)//&
& " in file "//TRIM(td_file%c_name) )
- IF( td_var%t_att(ji)%i_type == NF90_CHAR )THEN
- !IF( TRIM(td_var%t_att(ji)%c_value) /= 'unknown' )THEN
- IF( TRIM(td_var%t_att(ji)%c_value) /= '' )THEN
+ IF( tl_var%t_att(ji)%i_type == NF90_CHAR )THEN
+ IF( TRIM(tl_var%t_att(ji)%c_value) /= '' )THEN
il_status = NF90_PUT_ATT(td_file%i_id, iom_cdf__write_var_def, &
- & TRIM(td_var%t_att(ji)%c_name), &
- & TRIM(td_var%t_att(ji)%c_value) )
+ & TRIM(tl_var%t_att(ji)%c_name), &
+ & TRIM(tl_var%t_att(ji)%c_value) )
CALL iom_cdf__check(il_status)
ENDIF
ELSE
- SELECT CASE(td_var%t_att(ji)%i_type)
+ SELECT CASE(tl_var%t_att(ji)%i_type)
CASE(NF90_BYTE)
il_status = NF90_PUT_ATT(td_file%i_id, &
& iom_cdf__write_var_def, &
- & TRIM(td_var%t_att(ji)%c_name), &
- & INT(td_var%t_att(ji)%d_value(:),i1))
+ & TRIM(tl_var%t_att(ji)%c_name), &
+ & INT(tl_var%t_att(ji)%d_value(:),i1))
CASE(NF90_SHORT)
il_status = NF90_PUT_ATT(td_file%i_id, &
& iom_cdf__write_var_def, &
- & TRIM(td_var%t_att(ji)%c_name), &
- & INT(td_var%t_att(ji)%d_value(:),i2))
+ & TRIM(tl_var%t_att(ji)%c_name), &
+ & INT(tl_var%t_att(ji)%d_value(:),i2))
CASE(NF90_INT)
il_status = NF90_PUT_ATT(td_file%i_id, &
& iom_cdf__write_var_def, &
- & TRIM(td_var%t_att(ji)%c_name), &
- & INT(td_var%t_att(ji)%d_value(:),i4))
+ & TRIM(tl_var%t_att(ji)%c_name), &
+ & INT(tl_var%t_att(ji)%d_value(:),i4))
CASE(NF90_FLOAT)
il_status = NF90_PUT_ATT(td_file%i_id, &
& iom_cdf__write_var_def, &
- & TRIM(td_var%t_att(ji)%c_name), &
- & REAL(td_var%t_att(ji)%d_value(:),sp))
+ & TRIM(tl_var%t_att(ji)%c_name), &
+ & REAL(tl_var%t_att(ji)%d_value(:),sp))
CASE(NF90_DOUBLE)
il_status = NF90_PUT_ATT(td_file%i_id, &
& iom_cdf__write_var_def, &
- & TRIM(td_var%t_att(ji)%c_name), &
- & REAL(td_var%t_att(ji)%d_value(:),dp))
+ & TRIM(tl_var%t_att(ji)%c_name), &
+ & REAL(tl_var%t_att(ji)%d_value(:),dp))
END SELECT
CALL iom_cdf__check(il_status)
@@ -2161,5 +2088,4 @@
END FUNCTION iom_cdf__write_var_def
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine put variable value in an opened netcdf file.
@@ -2167,14 +2093,13 @@
!> @details
!> The variable is written in the type define in variable structure.
- !> Only dimension used are printed, and fillValue in table are
+ !> Only dimension used are printed, and fillValue in array are
!> replaced by default fill values defined in module netcdf for each type.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] td_var : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_cdf__write_var_value(td_file, td_var)
IMPLICIT NONE
@@ -2194,6 +2119,6 @@
! check which dimension use
- CALL logger_debug( &
- & " WRITE FILE VAR VALUE: get dimension to be used for variable "//&
+ CALL logger_trace( &
+ & "IOM CDF WRITE VAR VALUE: get dimension to be used for variable "//&
& TRIM(td_var%c_name)//" in file "//TRIM(td_file%c_name))
@@ -2202,6 +2127,4 @@
IF( td_var%t_dim(ji)%l_use )THEN
jj=jj+1
- !il_order(ji)=jj
- !il_shape(ji)=td_var%t_dim(jj)%i_len
il_order(jj)=ji
il_shape(jj)=td_var%t_dim(ji)%i_len
@@ -2212,6 +2135,4 @@
IF( .NOT. td_var%t_dim(ji)%l_use )THEN
jj=jj+1
- !il_order(ji)=jj
- !il_shape(ji)=td_var%t_dim(jj)%i_len
il_order(jj)=ji
il_shape(jj)=td_var%t_dim(ji)%i_len
@@ -2221,5 +2142,5 @@
ALLOCATE( dl_value( il_shape(1),il_shape(2),il_shape(3),il_shape(4) ) )
- ! reshape table, so unused dimension won't be written
+ ! reshape array, so unused dimension won't be written
dl_value(:,:,:,:)=RESHAPE(source=td_var%d_value(:,:,:,:),&
& SHAPE = il_shape(:), &
@@ -2227,6 +2148,6 @@
! put value
- CALL logger_debug( &
- & " WRITE FILE VAR VALUE: put "//TRIM(td_var%c_name)//" value "//&
+ CALL logger_trace( &
+ & "IOM CDF WRITE VAR VALUE: put "//TRIM(td_var%c_name)//" value "//&
& "in file "//TRIM(td_file%c_name))
@@ -2237,4 +2158,3 @@
END SUBROUTINE iom_cdf__write_var_value
- !> @endcode
END MODULE iom_cdf
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_dom.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_dom.f90 (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_dom.f90 (revision 5214)
@@ -0,0 +1,714 @@
+!----------------------------------------------------------------------
+! NEMO system team, System and Interface for oceanic RElocable Nesting
+!----------------------------------------------------------------------
+!
+! MODULE: iom_dom
+!
+! DESCRIPTION:
+!> @brief This module allow to read domain (defined as domain structure) in a mpp files.
+!>
+!> @details
+!> to read one variable in an mpp files over domain defined as domain structure:
+!> @code
+!> tl_var=iom_dom_read_var( td_mpp, id_varid, td_dom )
+!> @endcode
+!> or
+!> @code
+!> tl_var=iom_dom_read_var( td_mpp, cd_name, td_dom )
+!> @endcode
+!> - td_mpp is a mpp structure
+!> - id_varid is a variable id
+!> - cd_name is variable name or standard name
+!> - td_dom is a domain structure
+!>
+!> @author
+!> J.Paul
+! REVISION HISTORY:
+!> @date October, 2014 - Initial Version
+!>
+!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
+!----------------------------------------------------------------------
+MODULE iom_dom
+ USE netcdf ! nf90 library
+ USE global ! global parameter
+ USE kind ! F90 kind parameter
+ USE fct ! basic useful function
+ USE logger ! log file manager
+ USE dim ! dimension manager
+ USE att ! attribute manager
+ USE var ! variable manager
+ USE iom ! I/O manager
+ USE mpp ! mpp manager
+ USe dom ! domain manager
+ USE iom_mpp ! I/O mpp manager
+ IMPLICIT NONE
+ ! NOTE_avoid_public_variables_if_possible
+
+ ! function and subroutine
+ PUBLIC :: iom_dom_open !< open files composing mpp structure over domain to be used
+ PUBLIC :: iom_dom_read_var !< read one variable in an mpp structure over domain to be used
+ PUBLIC :: iom_dom_close !< close file composing mpp structure over domain
+
+ PRIVATE :: iom_dom__read_var_id ! read one variable in an mpp structure, given variable id
+ PRIVATE :: iom_dom__read_var_name ! read one variable in an mpp structure, given variable name
+ PRIVATE :: iom_dom__read_var_value ! read variable value in an mpp structure
+ PRIVATE :: iom_dom__no_pole_no_overlap ! do not overlap north fold boundary or east-west boundary
+ PRIVATE :: iom_dom__no_pole_cyclic ! do not overlap north fold boundary. However uses cyclic east-west boundary
+ PRIVATE :: iom_dom__no_pole_overlap ! do not overlap north fold boundary. However overlaps east-west boundary
+! PRIVATE :: iom_dom__pole_no_overlap ! overlaps north fold boundary. However do not overlap east-west boundary
+! PRIVATE :: iom_dom__pole_cyclic ! overlaps north fold boundary and uses cyclic east-west boundary
+! PRIVATE :: iom_dom__pole_overlap ! overlaps north fold boundary and east-west boundary
+
+ INTERFACE iom_dom_read_var ! read one variable in an mpp structure
+ MODULE PROCEDURE iom_dom__read_var_id ! given variable id
+ MODULE PROCEDURE iom_dom__read_var_name ! given variable name
+ END INTERFACE iom_dom_read_var
+
+CONTAINS
+ !-------------------------------------------------------------------
+ !> @brief This subroutine open files composing mpp structure
+ !> over domain to be used.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !
+ !> @param[inout] td_mpp mpp structure
+ !-------------------------------------------------------------------
+ SUBROUTINE iom_dom_open(td_mpp, td_dom, id_perio, id_ew)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP) , INTENT(INOUT) :: td_mpp
+ TYPE(TDOM) , INTENT(IN) :: td_dom
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
+
+ ! local variable
+ ! loop indices
+ !----------------------------------------------------------------
+ ! check if mpp exist
+ IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
+
+ CALL logger_error( " IOM DOM OPEN: domain decomposition not define "//&
+ & " in mpp strcuture "//TRIM(td_mpp%c_name))
+
+ ELSE
+ ! get processor to be used
+ CALL mpp_get_use( td_mpp, td_dom%i_imin, td_dom%i_imax, &
+ & td_dom%i_jmin, td_dom%i_jmax )
+
+ CALL iom_mpp_open(td_mpp, id_perio, id_ew)
+
+ ENDIF
+
+ END SUBROUTINE iom_dom_open
+ !-------------------------------------------------------------------
+ !> @brief This subroutine close files composing mpp structure.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !
+ !> @param[in] td_mpp mpp structure
+ !-------------------------------------------------------------------
+ SUBROUTINE iom_dom_close(td_mpp)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), INTENT(INOUT) :: td_mpp
+
+ ! loop indices
+ !----------------------------------------------------------------
+
+ CALL iom_mpp_close(td_mpp)
+
+ END SUBROUTINE iom_dom_close
+ !-------------------------------------------------------------------
+ !> @brief This function read variable value in opened mpp files,
+ !> given variable id and domain strcuture.
+ !>
+ !> @details
+ !> Optionally start indices and number of point to be read could be specify.
+ !> as well as East West ovelap of the global domain.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[in] id_varid variable id
+ !> @param[in] td_dom domain structure
+ !> @return variable structure
+ !-------------------------------------------------------------------
+ TYPE(TVAR) FUNCTION iom_dom__read_var_id(td_mpp, id_varid, td_dom )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP) , INTENT(IN) :: td_mpp
+ INTEGER(i4), INTENT(IN) :: id_varid
+ TYPE(TDOM) , INTENT(IN) :: td_dom
+
+ ! local variable
+ INTEGER(i4), DIMENSION(1) :: il_ind
+ !----------------------------------------------------------------
+ ! check if mpp exist
+ IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
+
+ CALL logger_error( " IOM DOM READ VAR: domain decomposition "//&
+ & "not define in mpp strcuture "//TRIM(td_mpp%c_name))
+
+ ELSE
+
+ IF( ANY(td_mpp%t_proc(:)%i_id /= 0) )THEN
+ ! look for variable id
+ il_ind(:)=MINLOC( td_mpp%t_proc(1)%t_var(:)%i_id, &
+ & mask=(td_mpp%t_proc(1)%t_var(:)%i_id==id_varid))
+ IF( il_ind(1) /= 0 )THEN
+
+ iom_dom__read_var_id=var_copy(td_mpp%t_proc(1)%t_var(il_ind(1)))
+
+ !!! read variable value
+ CALL iom_dom__read_var_value(td_mpp, iom_dom__read_var_id, &
+ & td_dom)
+
+ ELSE
+ CALL logger_error( &
+ & " IOM DOM READ VAR: there is no variable with id "//&
+ & TRIM(fct_str(id_varid))//" in processor/file "//&
+ & TRIM(td_mpp%t_proc(1)%c_name))
+ ENDIF
+ ELSE
+ CALL logger_error(" IOM DOM READ VAR: can't read variable, mpp "//&
+ & TRIM(td_mpp%c_name)//" not opened")
+ ENDIF
+
+ ENDIF
+
+ END FUNCTION iom_dom__read_var_id
+ !-------------------------------------------------------------------
+ !> @brief This function read variable value in opened mpp files,
+ !> given variable name or standard name, and domain structure.
+ !>
+ !> @details
+ !> Optionally start indices and number of point to be read could be specify.
+ !> as well as East West ovelap of the global domain.
+ !>
+ !> look first for variable name. If it doesn't
+ !> exist in file, look for variable standard name.
+ !> If variable name is not present, check variable standard name.
+ !
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !
+ !> @param[in] td_mpp mpp structure
+ !> @param[in] cd_name variable name
+ !> @param[in] td_dom domain structure
+ !> @return variable structure
+ !-------------------------------------------------------------------
+ TYPE(TVAR) FUNCTION iom_dom__read_var_name(td_mpp, cd_name, td_dom )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), INTENT(IN) :: td_mpp
+ CHARACTER(LEN=*), INTENT(IN) :: cd_name
+ TYPE(TDOM) , INTENT(IN) :: td_dom
+
+ ! local variable
+ INTEGER(i4) :: il_ind
+
+ !----------------------------------------------------------------
+ ! check if mpp exist
+ IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
+
+ CALL logger_error( " IOM DOM READ VAR: domain decomposition not define "//&
+ & " in mpp strcuture "//TRIM(td_mpp%c_name))
+
+ ELSE
+
+ il_ind=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name)
+ IF( il_ind /= 0 )THEN
+
+ iom_dom__read_var_name=var_copy(td_mpp%t_proc(1)%t_var(il_ind))
+
+ !!! read variable value
+ CALL iom_dom__read_var_value( td_mpp, &
+ & iom_dom__read_var_name, &
+ & td_dom )
+
+ ELSE
+
+ CALL logger_error( &
+ & " IOM DOM READ VAR: there is no variable with "//&
+ & "name or standard name"//TRIM(cd_name)//&
+ & " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name))
+ ENDIF
+
+ ENDIF
+
+ END FUNCTION iom_dom__read_var_name
+ !-------------------------------------------------------------------
+ !> @brief This subroutine read variable value
+ !> in an mpp structure, given domain structure.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !>
+ !> @todo
+ !> - handle north fold
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dom domain structure
+ !-------------------------------------------------------------------
+ SUBROUTINE iom_dom__read_var_value(td_mpp, td_var, td_dom )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), INTENT(IN) :: td_mpp
+ TYPE(TVAR), INTENT(INOUT) :: td_var
+ TYPE(TDOM), INTENT(IN) :: td_dom
+
+ ! local variable
+ INTEGER(i4) :: il_status
+
+ TYPE(TATT) :: tl_att
+ TYPE(TMPP) :: tl_mpp
+ TYPE(TDOM) :: tl_dom
+
+ ! loop indices
+ INTEGER(i4) :: jk
+ !----------------------------------------------------------------
+
+ CALL logger_debug(" IOM DOM READ VAR VALUE: name "//&
+ & TRIM(td_var%c_name)//" "//TRIM(td_var%c_point) )
+ CALL logger_debug(" IOM DOM READ VAR VALUE: ndim "//&
+ & TRIM(fct_str(td_var%i_ndim)) )
+
+ ! copy mpp structure
+ tl_mpp=mpp_copy(td_mpp)
+ ! forced to keep same id
+ tl_mpp%t_proc(:)%i_id=td_mpp%t_proc(:)%i_id
+
+ ! Allocate space to hold variable value in structure
+ IF( ASSOCIATED(td_var%d_value) )THEN
+ DEALLOCATE(td_var%d_value)
+ ENDIF
+
+ ! copy domain structure
+ tl_dom=dom_copy(td_dom)
+ DO jk=1,ip_maxdim
+ IF( .NOT. td_var%t_dim(jk)%l_use ) tl_dom%t_dim(jk)%i_len = 1
+ ENDDO
+
+ ! use domain dimension
+ td_var%t_dim(1:2)%i_len=tl_dom%t_dim(1:2)%i_len
+
+ ALLOCATE(td_var%d_value( tl_dom%t_dim(1)%i_len, &
+ & tl_dom%t_dim(2)%i_len, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len),&
+ & stat=il_status)
+ IF(il_status /= 0 )THEN
+
+ CALL logger_error( &
+ & " IOM DOM READ VAR VALUE: not enough space to put variable "//&
+ & TRIM(td_var%c_name)//&
+ & " in variable structure")
+
+ ENDIF
+ CALL logger_debug("IOM DOM READ VAR VALUE: shape ("//&
+ & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=1)))//","//&
+ & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=2)))//","//&
+ & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=3)))//","//&
+ & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=4)))//")" )
+ ! FillValue by default
+ td_var%d_value(:,:,:,:)=td_var%d_fill
+
+ IF( tl_dom%i_perio0 < 3 .OR. &
+ & tl_dom%i_jmax /= tl_dom%t_dim0(2)%i_len )THEN
+ ! no north pole
+
+ IF( (tl_dom%i_perio0 == 1 .OR. &
+ & tl_dom%i_perio0 == 4 .OR. &
+ & tl_dom%i_perio0 == 6) .AND. &
+ & tl_dom%i_imin == 1 .AND. &
+ & tl_dom%i_imax == tl_dom%t_dim0(1)%i_len )THEN
+ ! east west cyclic
+
+ CALL iom_dom__no_pole_cyclic(tl_mpp, td_var, tl_dom)
+
+ ELSEIF( tl_dom%i_imin <= tl_dom%i_imax )THEN
+ ! no east west overlap
+
+ CALL iom_dom__no_pole_no_overlap(tl_mpp, td_var, tl_dom)
+
+ ! no more EW overlap in variable
+ td_var%i_ew=-1
+
+ ELSEIF( (tl_dom%i_perio0 == 1 .OR. &
+ & tl_dom%i_perio0 == 4 .OR. &
+ & tl_dom%i_perio0 == 6) .AND. &
+ & tl_dom%i_imin > tl_dom%i_imax )THEN
+ ! east west overlap
+
+ CALL iom_dom__no_pole_overlap(tl_mpp, td_var, tl_dom)
+
+ ! no more EW overlap in variable
+ td_var%i_ew=-1
+
+ ELSE
+
+ CALL logger_fatal(" IOM DOM READ VAR VALUE: invalid domain definition.")
+
+ ENDIF
+
+ ELSE ! tl_dom%i_jmax == tl_dom%t_dim0(2)%i_len
+ ! north pole
+
+ CALL logger_error("IOM DOM READ VAR VALUE: "//&
+ & TRIM(fct_str(tl_dom%i_jmin))//" "//&
+ & TRIM(fct_str(tl_dom%i_jmax)) )
+ CALL logger_fatal("IOM DOM READ VAR VALUE: siren is not able to "//&
+ & "use north pole now, maybe in the next release")
+ ! IF( tl_dom%i_imin < tl_dom%i_imax )THEN
+ ! ! no east west overlap
+
+ ! CALL iom_dom__pole_no_overlap(tl_mpp, td_var, tl_dom)
+
+ ! ELSEIF(tl_dom%i_imin == tl_dom%i_imax)THEN
+ ! ! east west cyclic
+
+ ! CALL iom_dom__pole_cyclic(tl_mpp, td_var, tl_dom)
+
+ ! ELSE ! tl_dom%i_imin > tl_dom%i_imax
+ ! ! east west overlap
+
+ ! CALL iom_dom__pole_overlap(tl_mpp, td_var, tl_dom)
+
+ ! ENDIF
+ ENDIF
+
+ ! clean
+ CALL mpp_clean(tl_mpp)
+ CALL dom_clean(tl_dom)
+
+ IF( td_var%t_dim(1)%l_use .AND. &
+ & td_var%t_dim(1)%i_len == td_mpp%t_dim(1)%i_len )THEN
+ IF( td_mpp%i_ew >= 0 )THEN
+ tl_att=att_init("ew_overlap",td_mpp%i_ew)
+ CALL var_move_att(td_var,tl_att)
+ ! clean
+ CALL att_clean(tl_att)
+ ENDIF
+ ENDIF
+
+ ! force to change _FillValue to avoid mistake
+ ! with dummy zero _FillValue
+ IF( td_var%d_fill == 0._dp )THEN
+ CALL var_chg_FillValue(td_var)
+ ENDIF
+
+ END SUBROUTINE iom_dom__read_var_value
+ !-------------------------------------------------------------------
+ !> @brief This subroutine read variable value
+ !> in an mpp structure.
+ !> @details
+ !> The output domain do not overlap
+ !> north fold boundary or east-west boundary.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dom domain structure
+ !-------------------------------------------------------------------
+ SUBROUTINE iom_dom__no_pole_no_overlap(td_mpp, td_var, td_dom )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), INTENT(IN) :: td_mpp
+ TYPE(TVAR), INTENT(INOUT) :: td_var
+ TYPE(TDOM), INTENT(IN) :: td_dom
+
+ ! local variable
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
+
+ TYPE(TDOM) :: tl_dom
+
+ ! loop indices
+ !----------------------------------------------------------------
+
+ ! copy domain structure
+ tl_dom=dom_copy(td_dom)
+
+ ! change dimension length if not use
+ IF( .NOT. td_var%t_dim(1)%l_use )THEN
+ tl_dom%i_imin=1 ; tl_dom%i_imax=1
+ ENDIF
+ IF( .NOT. td_var%t_dim(2)%l_use )THEN
+ tl_dom%i_jmin=1 ; tl_dom%i_jmax=1
+ ENDIF
+
+ il_start(:)=(/tl_dom%i_imin,tl_dom%i_jmin,1,1/)
+
+ il_count(:)=(/tl_dom%i_imax-tl_dom%i_imin+1, &
+ & tl_dom%i_jmax-tl_dom%i_jmin+1, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len/)
+
+ td_var=iom_mpp_read_var(td_mpp, TRIM(td_var%c_name), &
+ & il_start(:), il_count(:) )
+
+ CALL dom_clean(tl_dom)
+
+ END SUBROUTINE iom_dom__no_pole_no_overlap
+ !-------------------------------------------------------------------
+ !> @brief This subroutine read cyclic variable value
+ !> in an mpp structure.
+ !> @details
+ !> The output domain do not overlap north fold boundary.
+ !> However it uses cyclic east-west boundary.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dom domain structure
+ !-------------------------------------------------------------------
+ SUBROUTINE iom_dom__no_pole_cyclic(td_mpp, td_var, td_dom )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), INTENT(IN ) :: td_mpp
+ TYPE(TVAR), INTENT(INOUT) :: td_var
+ TYPE(TDOM), INTENT(IN ) :: td_dom
+
+ ! local variable
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
+
+ TYPE(TDOM) :: tl_dom
+
+ ! loop indices
+ !----------------------------------------------------------------
+
+ ! copy domain structure
+ tl_dom=dom_copy(td_dom)
+
+ ! cyclic domain
+ tl_dom%i_imin=1
+ tl_dom%i_imax=tl_dom%t_dim(1)%i_len
+
+ ! change dimension length if not use
+ IF( .NOT. td_var%t_dim(1)%l_use )THEN
+ tl_dom%i_imin=1 ; tl_dom%i_imax=1
+ ENDIF
+ IF( .NOT. td_var%t_dim(2)%l_use )THEN
+ tl_dom%i_jmin=1 ; tl_dom%i_jmax=1
+ ENDIF
+
+ il_start(:)=(/tl_dom%i_imin,tl_dom%i_jmin,1,1/)
+
+ il_count(:)=(/tl_dom%i_imax-tl_dom%i_imin+1, &
+ & tl_dom%i_jmax-tl_dom%i_jmin+1, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len /)
+
+ td_var=iom_mpp_read_var(td_mpp, TRIM(td_var%c_name), &
+ & il_start(:), il_count(:) )
+
+ ! clean
+ CALL dom_clean(tl_dom)
+
+ END SUBROUTINE iom_dom__no_pole_cyclic
+ !-------------------------------------------------------------------
+ !> @brief This subroutine read East West overlap variable value
+ !> in an mpp structure.
+ !> @details
+ !> The output domain do not overlap north fold boundary.
+ !> However it overlaps east-west boundary.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dom domain structure
+ !-------------------------------------------------------------------
+ SUBROUTINE iom_dom__no_pole_overlap(td_mpp, td_var, td_dom )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), INTENT(IN) :: td_mpp
+ TYPE(TVAR), INTENT(INOUT) :: td_var
+ TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom
+
+ ! local variable
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
+
+ INTEGER(i4) :: il_dim1
+ INTEGER(i4) :: il_dim2
+
+ TYPE(TVAR) :: tl_var1
+ TYPE(TVAR) :: tl_var2
+
+ TYPE(TDOM) :: tl_dom
+
+ ! loop indices
+ !----------------------------------------------------------------
+
+ ! copy domain structure
+ tl_dom=dom_copy(td_dom)
+
+ ! change dimension length if not use
+ IF( .NOT. td_var%t_dim(1)%l_use )THEN
+ tl_dom%i_imin=1 ; tl_dom%i_imax=1
+ ENDIF
+ IF( .NOT. td_var%t_dim(2)%l_use )THEN
+ tl_dom%i_jmin=1 ; tl_dom%i_jmax=1
+ ENDIF
+
+ ! get first part of domain
+ tl_var1=var_copy(td_var)
+ DEALLOCATE(tl_var1%d_value)
+
+ il_start(:)=(/tl_dom%i_imin,tl_dom%i_jmin,1,1/)
+
+ il_dim1 = td_mpp%t_dim(1)%i_len - td_mpp%i_ew - tl_dom%i_imin + 1
+
+ il_count(:)=(/il_dim1, &
+ & tl_dom%i_jmax-tl_dom%i_jmin+1, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len /)
+
+ ! dimension part 1
+ tl_var1%t_dim(:)%i_len=il_count(:)
+
+ ALLOCATE(tl_var1%d_value(tl_var1%t_dim(1)%i_len, &
+ & tl_var1%t_dim(2)%i_len, &
+ & tl_var1%t_dim(3)%i_len, &
+ & tl_var1%t_dim(4)%i_len) )
+
+ tl_var1=iom_mpp_read_var(td_mpp, TRIM(td_var%c_name), &
+ & il_start(:), il_count(:) )
+
+ IF( td_var%t_dim(jp_I)%l_use )THEN
+ ! get second part of domain
+ tl_var2=var_copy(td_var)
+ DEALLOCATE(tl_var2%d_value)
+
+ il_start(:)=(/1,tl_dom%i_jmin,1,1/)
+
+ il_dim2 = tl_dom%i_imax
+
+ il_count(:)=(/il_dim2, &
+ & tl_dom%i_jmax-tl_dom%i_jmin+1, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len /)
+
+ ! dimension part 2
+ tl_var2%t_dim(:)%i_len=il_count(:)
+
+ ALLOCATE(tl_var2%d_value(tl_var2%t_dim(1)%i_len, &
+ & tl_var2%t_dim(2)%i_len, &
+ & tl_var2%t_dim(3)%i_len, &
+ & tl_var2%t_dim(4)%i_len) )
+
+ tl_var2=iom_mpp_read_var(td_mpp, TRIM(td_var%c_name), &
+ & il_start(:), il_count(:) )
+
+ ! concatenate both part
+ td_var=var_concat(tl_var1, tl_var2, jp_I)
+
+ ! clean
+ CALL var_clean(tl_var1)
+ CALL var_clean(tl_var2)
+ ELSE
+ td_var=var_copy(tl_var1)
+ ! clean
+ CALL var_clean(tl_var1)
+ ENDIF
+
+ ! clean
+ CALL dom_clean(tl_dom)
+
+ END SUBROUTINE iom_dom__no_pole_overlap
+ !-------------------------------------------------------------------
+ !> @brief This subroutine read north fold variable value
+ !> in an mpp structure.
+ !> @details
+ !> The output domain overlaps
+ !> north fold boundary. However it do not overlap east-west boundary.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dom domain structure
+ !-------------------------------------------------------------------
+! SUBROUTINE iom_dom__pole_no_overlap(td_mpp, td_var, td_dom )
+! IMPLICIT NONE
+! ! Argument
+! TYPE(TMPP), INTENT(IN) :: td_mpp
+! TYPE(TVAR), INTENT(INOUT) :: td_var
+! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom
+!
+! ! local variable
+!
+! ! loop indices
+! !----------------------------------------------------------------
+!
+! END SUBROUTINE iom_dom__pole_no_overlap
+ !-------------------------------------------------------------------
+ !> @brief This subroutine read semi global variable value
+ !> in an mpp structure.
+ !> @details
+ !> The output domain overlaps north fold boundary.
+ !> and uses cyclic east-west boundary.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dom domain structure
+ !> @return variable structure completed
+ !-------------------------------------------------------------------
+! SUBROUTINE iom_dom__pole_cyclic(td_mpp, td_var, td_dom )
+! IMPLICIT NONE
+! ! Argument
+! TYPE(TMPP), INTENT(IN) :: td_mpp
+! TYPE(TVAR), INTENT(INOUT) :: td_var
+! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom
+!
+! ! local variable
+!
+! ! loop indices
+! !----------------------------------------------------------------
+!
+! END SUBROUTINE iom_dom__pole_cyclic
+ !-------------------------------------------------------------------
+ !> @brief This subroutine read north fold East West overlap variable value
+ !> in an mpp structure.
+ !> @details
+ !> The output domain overlaps north fold boundary.
+ !> and east-west boundary.
+ !>
+ !> @author J.Paul
+ !> - October, 2014- Initial Version
+ !
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dom domain structure
+ !> @return variable structure completed
+ !-------------------------------------------------------------------
+! SUBROUTINE iom_dom__pole_overlap(td_mpp, td_var, td_dom )
+! IMPLICIT NONE
+! ! Argument
+! TYPE(TMPP), INTENT(IN) :: td_mpp
+! TYPE(TVAR), INTENT(INOUT) :: td_var
+! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom
+!
+! ! local variable
+!
+! ! loop indices
+! !----------------------------------------------------------------
+!
+! END SUBROUTINE iom_dom__pole_overlap
+
+END MODULE iom_dom
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_mpp.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_mpp.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_mpp.f90 (revision 5214)
@@ -6,36 +6,81 @@
!
! DESCRIPTION:
-!> @brief massively parallel processing Input/Output manager :
-!> Library to read/write mpp files
+!> @brief This module manage massively parallel processing Input/Output manager.
+!> Library to read/write mpp files.
!>
!> @details
-!>
!> to open mpp files (only file to be used (see mpp_get_use)
!> will be open):
+!> @code
!> CALL iom_mpp_open(td_mpp)
+!> @endcode
!> - td_mpp is a mpp structure
!>
!> to creates mpp files:
+!> @code
!> CALL iom_mpp_create(td_mpp)
+!> @endcode
!> - td_mpp is a mpp structure
!>
!> to write in mpp files :
+!> @code
!> CALL iom_mpp_write_file(td_mpp)
+!> @endcode
!> - td_mpp is a mpp structure
!>
!> to close mpp files:
+!> @code
!> CALL iom_mpp_close(td_mpp)
+!> @endcode
!>
!> to read one variable in an mpp files:
-!> - tl_var=iom_mpp_read_var( td_mpp, id_varid, [td_dom,] [ld_border] )
-!> - tl_var=iom_mpp_read_var( td_mpp, [cd_name,] [td_dom,] [ld_border,] [cd_stdname] )
+!> @code
+!> tl_var=iom_mpp_read_var( td_mpp, id_varid, [id_start, id_count] [,id_ew] )
+!> @endcode
+!> or
+!> @code
+!> tl_var=iom_mpp_read_var( td_mpp, cd_name, [id_start, id_count] [,id_ew] )
+!> @endcode
!> - td_mpp is a mpp structure
!> - id_varid is a variable id
-!> - td_dom is a domain structure (optional, can't be used with ld_border)
-!> - ld_border is true if we want to read border of global domain only
-!> (optional, can't be used with td_dom)
-!> - cd_name is variable name (optional, cd_name and/or cd_stdname should be specify.)
-!> - cd_stdname is variable standard name (optional, cd_name and/or cd_stdname should be specify.)
-!>
+!> - cd_name is variable name or standard name
+!> - id_start is a integer(4) 1D array of index from which the data
+!> values will be read [optional]
+!> - id_count is a integer(4) 1D array of the number of indices selected
+!> along each dimension [optional]
+!> - id_ew East West overlap [optional]
+!>
+!> to fill variable value in mpp structure:
+!> @code
+!> CALL iom_mpp_fill_var(td_mpp, id_varid, [id_start, id_count] [,id_ew] )
+!> @endcode
+!> or
+!> @code
+!> CALL iom_mpp_fill_var(td_mpp, cd_name, [id_start, id_count] [,id_ew] )
+!> @endcode
+!> - td_mpp is mpp structure
+!> - id_varid is variable id
+!> - cd_name is variable name or standard name
+!> - id_start is a integer(4) 1D array of index from which the data
+!> values will be read [optional]
+!> - id_count is a integer(4) 1D array of the number of indices selected
+!> along each dimension [optional]
+!> - id_ew East West overlap [optional]
+!>
+!> to fill all variable in mpp structure:
+!> @code
+!> CALL iom_mpp_fill_var(td_mpp, [id_start, id_count] [,id_ew] )
+!> @endcode
+!> - td_mpp is mpp structure
+!> - id_start is a integer(4) 1D array of index from which the data
+!> values will be read [optional]
+!> - id_count is a integer(4) 1D array of the number of indices selected
+!> along each dimension [optional]
+!> - id_ew East West overlap
+!>
+!> to write files composong mpp strucutre:
+!> @code
+!> CALL iom_mpp_write_file(td_mpp)
+!> @endcode
!>
!> @author
@@ -43,19 +88,13 @@
! REVISION HISTORY:
!> @date Nov, 2013 - Initial Version
-!
+!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!> @todo
-!> - add read var with start and count as in iom
-!> - add iom_mpp_fill_var_value : cf iom_fill_var_value
-!> - not so easy to use that it should be, have to work on it
-!> - improve mpp init
-!> - improve mpp_get_use
-!> - imporve dom_init
!----------------------------------------------------------------------
MODULE iom_mpp
USE netcdf ! nf90 library
+ USE global ! global parameter
USE kind ! F90 kind parameter
USE fct ! basic useful function
- USE logger ! log file manager
+ USE logger ! log file manager
USE dim ! dimension manager
USE att ! attribute manager
@@ -64,41 +103,27 @@
USE iom ! I/O manager
USE mpp ! mpp manager
- USE dom ! domain manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! function and subroutine
- PUBLIC :: iom_mpp_open !< open files composing mpp structure to be used
- PUBLIC :: iom_mpp_create !< creates files composing mpp structure to be used
+ PUBLIC :: iom_mpp_open !< open all files composing mpp structure
+ PUBLIC :: iom_mpp_create !< creates files composing mpp structure
PUBLIC :: iom_mpp_close !< close file composing mpp structure
PUBLIC :: iom_mpp_read_var !< read one variable in an mpp structure
- PUBLIC :: iom_mpp_fill_var !< fill variable value in mpp structure
PUBLIC :: iom_mpp_write_file !< write mpp structure in files
- PRIVATE :: iom_mpp__read_var_id !< read one variable in an mpp structure, given variable id
- PRIVATE :: iom_mpp__read_var_name !< read one variable in an mpp structure, given variable name
- PRIVATE :: iom_mpp__read_var_value !< read variable value in an mpp structure
- PRIVATE :: iom_mpp__no_pole_no_overlap !< do not overlap north fold boundary or east-west boundary
- PRIVATE :: iom_mpp__no_pole_cyclic !< do not overlap north fold boundary. However uses cyclic east-west boundary
- PRIVATE :: iom_mpp__no_pole_overlap !< do not overlap north fold boundary. However overlaps east-west boundary
-! PRIVATE :: iom_mpp__pole_no_overlap !< overlaps north fold boundary. However do not overlap east-west boundary
-! PRIVATE :: iom_mpp__pole_cyclic !< overlaps north fold boundary and uses cyclic east-west boundary
-! PRIVATE :: iom_mpp__pole_overlap !< overlaps north fold boundary and east-west boundary
-
- INTERFACE iom_mpp_read_var !< read one variable in an mpp structure
- MODULE PROCEDURE iom_mpp__read_var_id !< given variable id
- MODULE PROCEDURE iom_mpp__read_var_name !< given variable name
+ PRIVATE :: iom_mpp__read_var_id ! read one variable in an mpp structure, given variable id
+ PRIVATE :: iom_mpp__read_var_name ! read one variable in an mpp structure, given variable name
+ PRIVATE :: iom_mpp__read_var_value ! read variable value in an mpp structure
+
+ INTERFACE iom_mpp_read_var ! read one variable in an mpp structure
+ MODULE PROCEDURE iom_mpp__read_var_id ! given variable id
+ MODULE PROCEDURE iom_mpp__read_var_name ! given variable name
END INTERFACE iom_mpp_read_var
- INTERFACE iom_mpp_fill_var !< fill variable value in an mpp structure
- MODULE PROCEDURE iom_mpp__fill_var_id !< given variable id
- MODULE PROCEDURE iom_mpp__fill_var_name !< given variable name
- MODULE PROCEDURE iom_mpp__fill_var_all !< fill all variable
- END INTERFACE iom_mpp_fill_var
-
CONTAINS
!-------------------------------------------------------------------
- !> @brief This subroutine open files composing mpp structure to be used
+ !> @brief This subroutine open files composing mpp structure to be used.
+ !> @details
!> If try to open a file in write mode that did not exist, create it.
!>
@@ -112,13 +137,14 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_mpp : mpp structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_mpp_open(td_mpp)
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_mpp mpp structure
+ !-------------------------------------------------------------------
+ SUBROUTINE iom_mpp_open(td_mpp, id_perio, id_ew)
IMPLICIT NONE
! Argument
- TYPE(TMPP), INTENT(INOUT) :: td_mpp
+ TYPE(TMPP) , INTENT(INOUT) :: td_mpp
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
! local variable
@@ -135,59 +161,68 @@
ELSE
- IF( ANY(td_mpp%t_proc(:)%l_use) )THEN
-
- ! add suffix to mpp name
- td_mpp%c_name=file_add_suffix( TRIM(td_mpp%c_name), &
- & TRIM(td_mpp%c_type) )
-
- td_mpp%t_proc(:)%c_type=TRIM(td_mpp%c_type)
- IF( td_mpp%i_nproc > 1 )THEN
- DO ji=1,td_mpp%i_nproc
- IF( td_mpp%t_proc(ji)%l_use )THEN
-
+ ! if no processor file selected
+ ! force to open all files
+ IF( .NOT. ANY( td_mpp%t_proc(:)%l_use ) )THEN
+ td_mpp%t_proc(:)%l_use=.TRUE.
+ ENDIF
+
+ ! add suffix to mpp name
+ td_mpp%c_name=file_add_suffix( TRIM(td_mpp%c_name), &
+ & TRIM(td_mpp%c_type) )
+
+ td_mpp%t_proc(:)%c_type=TRIM(td_mpp%c_type)
+ IF( td_mpp%i_nproc > 1 )THEN
+ DO ji=1,td_mpp%i_nproc
+ IF( td_mpp%t_proc(ji)%l_use )THEN
+
+ SELECT CASE(TRIM(td_mpp%c_type))
+ CASE('cdf')
+ cl_name=TRIM( file_rename(td_mpp%c_name, ji-1) )
+ CASE('dimg')
cl_name=TRIM( file_rename(td_mpp%c_name, ji) )
- td_mpp%t_proc(ji)%c_name=TRIM(cl_name)
-
- CALL iom_open(td_mpp%t_proc(ji))
-
- ENDIF
- ENDDO
- ELSE ! td_mpp%i_nproc == 1
- cl_name=TRIM( file_rename(td_mpp%c_name) )
- td_mpp%t_proc(1)%c_name=TRIM(cl_name)
-
- CALL iom_open(td_mpp%t_proc(1))
- ENDIF
-
- ELSE
-
- IF( ANY(td_mpp%t_proc(:)%l_ctr) )THEN
-
- CALL logger_warn("IOM MPP OPEN: open file on border")
- DO ji=1,td_mpp%i_nproc
- IF( td_mpp%t_proc(ji)%l_ctr )THEN
- CALL iom_open(td_mpp%t_proc(ji))
- ENDIF
- ENDDO
-
- ELSE
- CALL logger_error( " IOM MPP OPEN: no processor to be used.")
- CALL logger_debug( " use mpp_get_use before running iom_mpp_open")
- ENDIF
- ENDIF
+ CASE DEFAULT
+ CALL logger_fatal("IOM MPP OPEN: can not open file "//&
+ & "of type "//TRIM(td_mpp%c_type))
+ END SELECT
+
+ td_mpp%t_proc(ji)%c_name=TRIM(cl_name)
+
+ CALL iom_open(td_mpp%t_proc(ji))
+
+ ENDIF
+ ENDDO
+ ELSE ! td_mpp%i_nproc == 1
+ cl_name=TRIM( file_rename(td_mpp%c_name) )
+ td_mpp%t_proc(1)%c_name=TRIM(cl_name)
+
+ CALL iom_open(td_mpp%t_proc(1))
+ ENDIF
+
+ IF( PRESENT(id_ew) )THEN
+ td_mpp%i_ew=id_ew
+ ! add east west overlap to each variable
+ DO ji=1,td_mpp%i_nproc
+ WHERE(td_mpp%t_proc(ji)%t_var(:)%t_dim(1)%l_use)
+ td_mpp%t_proc(ji)%t_var(:)%i_ew=td_mpp%i_ew
+ ENDWHERE
+ ENDDO
+ ENDIF
+
+ IF( PRESENT(id_perio) )THEN
+ td_mpp%i_perio=id_perio
+ ENDIF
+
ENDIF
END SUBROUTINE iom_mpp_open
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine create files, composing mpp structure to be used,
- !> in write mode
+ !> in write mode.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_mpp : mpp structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_mpp mpp structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_mpp_create(td_mpp)
IMPLICIT NONE
@@ -209,14 +244,12 @@
END SUBROUTINE iom_mpp_create
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine close files composing mpp structure.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_mpp mpp structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_mpp_close(td_mpp)
IMPLICIT NONE
@@ -239,35 +272,36 @@
ENDIF
ENDDO
+ td_mpp%t_proc(:)%l_use=.FALSE.
ENDIF
END SUBROUTINE iom_mpp_close
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read variable value in opened mpp files,
- !> given variable id.
+ !> given variable id.
!>
!> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
- !>
- !
+ !> Optionally start indices and number of point to be read could be specify.
+ !> as well as East West ovelap of the global domain.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[in] id_varid : variable id
- !> @param[in] td_dom : domain structure
- !> @param[in] ld_border : read only border
+ !> - November, 2013- Initial Version
+ !> @date October, 2014
+ !> - use start and count array instead of domain structure.
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[in] id_varid variable id
+ !> @param[in] id_start index in the variable from which the data values
+ !> will be read
+ !> @param[in] id_count number of indices selected along each dimension
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
TYPE(TVAR) FUNCTION iom_mpp__read_var_id(td_mpp, id_varid,&
- & td_dom, ld_border)
+ & id_start, id_count)
IMPLICIT NONE
! Argument
- TYPE(TMPP), INTENT(IN) :: td_mpp
- INTEGER(i4), INTENT(IN) :: id_varid
- TYPE(TDOM) , INTENT(IN), OPTIONAL :: td_dom
- LOGICAL, INTENT(IN), OPTIONAL :: ld_border
+ TYPE(TMPP), INTENT(IN) :: td_mpp
+ INTEGER(i4), INTENT(IN) :: id_varid
+ INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
! local variable
@@ -288,9 +322,9 @@
IF( il_ind(1) /= 0 )THEN
- iom_mpp__read_var_id=td_mpp%t_proc(1)%t_var(il_ind(1))
+ iom_mpp__read_var_id=var_copy(td_mpp%t_proc(1)%t_var(il_ind(1)))
!!! read variable value
CALL iom_mpp__read_var_value(td_mpp, iom_mpp__read_var_id, &
- & td_dom, ld_border)
+ & id_start, id_count)
ELSE
@@ -308,13 +342,12 @@
END FUNCTION iom_mpp__read_var_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read variable value in opened mpp files,
- !> given variable name or standard name.
+ !> given variable name or standard name.
+ !>
!> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
- !
- !> @details
+ !> Optionally start indices and number of point to be read could be specify.
+ !> as well as East West ovelap of the global domain.
+ !>
!> look first for variable name. If it doesn't
!> exist in file, look for variable standard name.
@@ -322,24 +355,26 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[in] cd_name : variable name
- !> @param[in] td_dom : domain structure
- !> @param[in] ld_border : read only border
+ !> - November, 2013- Initial Version
+ !> @date October, 2014
+ !> - use start and count array instead of domain structure.
+ !
+ !> @param[in] td_mpp mpp structure
+ !> @param[in] cd_name variable name
+ !> @param[in] id_start index in the variable from which the data values
+ !> will be read
+ !> @param[in] id_count number of indices selected along each dimension
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
TYPE(TVAR) FUNCTION iom_mpp__read_var_name(td_mpp, cd_name, &
- & td_dom, ld_border )
+ & id_start, id_count )
IMPLICIT NONE
! Argument
- TYPE(TMPP), INTENT(IN) :: td_mpp
- CHARACTER(LEN=*), INTENT(IN) :: cd_name
- TYPE(TDOM) , INTENT(IN), OPTIONAL :: td_dom
- LOGICAL, INTENT(IN), OPTIONAL :: ld_border
+ TYPE(TMPP), INTENT(IN) :: td_mpp
+ CHARACTER(LEN=*), INTENT(IN) :: cd_name
+ INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
! local variable
- INTEGER(i4) :: il_varid
+ INTEGER(i4) :: il_ind
!----------------------------------------------------------------
! check if mpp exist
@@ -351,13 +386,13 @@
ELSE
- il_varid=var_get_id( td_mpp%t_proc(1)%t_var(:), cd_name)
- IF( il_varid /= 0 )THEN
-
- iom_mpp__read_var_name=td_mpp%t_proc(1)%t_var(il_varid)
+ il_ind=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name)
+ IF( il_ind /= 0 )THEN
+
+ iom_mpp__read_var_name=var_copy(td_mpp%t_proc(1)%t_var(il_ind))
!!! read variable value
CALL iom_mpp__read_var_value( td_mpp, &
& iom_mpp__read_var_name, &
- & td_dom, ld_border)
+ & id_start, id_count)
ELSE
@@ -372,174 +407,4 @@
END FUNCTION iom_mpp__read_var_name
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill all variable value in opened mpp files,
- !> given variable id.
- !>
- !> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
- !>
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_mpp : mpp structure
- !> @param[in] td_dom : domain structure
- !> @param[in] ld_border : read only border
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_mpp__fill_var_all(td_mpp, td_dom, ld_border)
- IMPLICIT NONE
- ! Argument
- TYPE(TMPP), INTENT(INOUT) :: td_mpp
- TYPE(TDOM) , INTENT(IN), OPTIONAL :: td_dom
- LOGICAL, INTENT(IN), OPTIONAL :: ld_border
-
- ! local variable
-
- ! loop indices
- INTEGER(i4) :: ji
- !----------------------------------------------------------------
- ! check if mpp exist
- IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
-
- CALL logger_error( " IOM MPP FILL VAR : domain decomposition not define "//&
- & " in mpp strcuture "//TRIM(td_mpp%c_name))
-
- ELSE
-
- DO ji=1,td_mpp%t_proc(1)%i_nvar
- CALL iom_mpp_fill_var(td_mpp, ji, td_dom, ld_border )
- ENDDO
-
- ENDIF
-
- END SUBROUTINE iom_mpp__fill_var_all
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill variable value in opened mpp files,
- !> given variable id.
- !>
- !> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
- !>
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_mpp : mpp structure
- !> @param[in] id_varid : variable id
- !> @param[in] td_dom : domain structure
- !> @param[in] ld_border : read only border
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_mpp__fill_var_id(td_mpp, id_varid, td_dom, ld_border)
- IMPLICIT NONE
- ! Argument
- TYPE(TMPP), INTENT(INOUT) :: td_mpp
- INTEGER(i4), INTENT(IN) :: id_varid
- TYPE(TDOM) , INTENT(IN), OPTIONAL :: td_dom
- LOGICAL, INTENT(IN), OPTIONAL :: ld_border
-
- ! local variable
- INTEGER(i4), DIMENSION(1) :: il_ind
- !----------------------------------------------------------------
- ! check if mpp exist
- IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
-
- CALL logger_error( " IOM MPP FILL VAR: domain decomposition not define "//&
- & " in mpp strcuture "//TRIM(td_mpp%c_name))
-
- ELSE
-
- IF( ANY(td_mpp%t_proc(:)%i_id /= 0) )THEN
- ! look for variable id
- il_ind(:)=MINLOC( td_mpp%t_proc(1)%t_var(:)%i_id, &
- & mask=(td_mpp%t_proc(1)%t_var(:)%i_id==id_varid))
- IF( il_ind(1) /= 0 )THEN
-
- !!! read variable value
- CALL iom_mpp__read_var_value( td_mpp, &
- & td_mpp%t_proc(1)%t_var(il_ind(1)), &
- & td_dom, ld_border)
-
- ELSE
- CALL logger_error( &
- & " IOM MPP FILL VAR : there is no variable with id "//&
- & TRIM(fct_str(id_varid))//" in processor/file "//&
- & TRIM(td_mpp%t_proc(1)%c_name))
- ENDIF
- ELSE
- CALL logger_error(" IOM MPP FILL VAR : can't read variable, mpp "//&
- & TRIM(td_mpp%c_name)//" not opened")
- ENDIF
-
- ENDIF
-
- END SUBROUTINE iom_mpp__fill_var_id
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill variable value in opened mpp files,
- !> given variable name or standard name.
- !> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
- !
- !> @details
- !> look first for variable name. If it doesn't
- !> exist in file, look for variable standard name.
- !> If variable name is not present, check variable standard name.
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_mpp : mpp structure
- !> @param[in] cd_name : variable name or standard name
- !> @param[in] td_dom : domain structure
- !> @param[in] ld_border : read only border
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_mpp__fill_var_name(td_mpp, cd_name, td_dom, ld_border )
- IMPLICIT NONE
- ! Argument
- TYPE(TMPP), INTENT(INOUT) :: td_mpp
- CHARACTER(LEN=*), INTENT(IN ) :: cd_name
- TYPE(TDOM) , INTENT(IN ), OPTIONAL :: td_dom
- LOGICAL, INTENT(IN ), OPTIONAL :: ld_border
-
- ! local variable
- INTEGER(i4) :: il_ind
- !----------------------------------------------------------------
- ! check if mpp exist
- IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
-
- CALL logger_error( " IOM MPP FILL VAR : domain decomposition not define "//&
- & " in mpp strcuture "//TRIM(td_mpp%c_name))
-
- ELSE
-
- il_ind=var_get_id( td_mpp%t_proc(1)%t_var(:), cd_name, cd_name)
- IF( il_ind /= 0 )THEN
-
- !!! read variable value
- CALL iom_mpp__read_var_value(td_mpp, &
- & td_mpp%t_proc(1)%t_var(il_ind), &
- & td_dom, ld_border)
-
- ELSE
-
- CALL logger_error( &
- & " IOM MPP FILL VAR : there is no variable with "//&
- & "name or standard name "//TRIM(cd_name)//&
- & " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name))
-
- ENDIF
-
- ENDIF
-
- END SUBROUTINE iom_mpp__fill_var_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine read variable value
@@ -547,28 +412,26 @@
!>
!> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
+ !> Optionally start indices and number of point to be read could be specify.
+ !> as well as East West ovelap of the global domain.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dom : domain structure
- !> @param[in] ld_border : read only border
- !> @return variable structure completed
- !
- !> @todo
- !> - modif en fonction dimension de la variable lu pour cas dom
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !> @date October, 2014
+ !> - use start and count array instead of domain structure.
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[inout] td_var variable structure
+ !> @param[in] id_start index in the variable from which the data values
+ !> will be read
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
SUBROUTINE iom_mpp__read_var_value(td_mpp, td_var, &
- & td_dom, ld_border )
+ & id_start, id_count )
IMPLICIT NONE
! Argument
TYPE(TMPP), INTENT(IN) :: td_mpp
TYPE(TVAR), INTENT(INOUT) :: td_var
- TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom
- LOGICAL, INTENT(IN), OPTIONAL :: ld_border
+ INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
! local variable
@@ -579,9 +442,18 @@
INTEGER(i4) :: il_j1p
INTEGER(i4) :: il_j2p
-
- LOGICAL :: ll_border
+ INTEGER(i4) :: il_i1
+ INTEGER(i4) :: il_i2
+ INTEGER(i4) :: il_j1
+ INTEGER(i4) :: il_j2
+
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_end
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_count
+
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt
+
+ TYPE(TATT) :: tl_att
TYPE(TVAR) :: tl_var
- TYPE(TMPP) :: tl_mpp
- TYPE(TDOM) :: tl_dom
! loop indices
@@ -589,381 +461,54 @@
!----------------------------------------------------------------
- ll_border=.FALSE.
- IF( PRESENT(ld_border) ) ll_border=ld_border
- ! check td_dom and ld_border optionals parameters...
- IF( ll_border .AND. PRESENT(td_dom) )THEN
- CALL logger_error( "IOM MPP READ VAR VALUE: &
- & domain and border can't be both specify")
- ENDIF
-
- IF( ll_border )THEN
-
- ! copy mpp structure
- tl_mpp=td_mpp
- ! forced to keep same id
- tl_mpp%t_proc(:)%i_id=td_mpp%t_proc(:)%i_id
-
- IF( ALL(td_mpp%t_proc(:)%l_ctr) )THEN
- CALL logger_warn( "IOM MPP READ VAR VALUE: &
- & contour not define. look for it")
- ! get contour
- CALL mpp_get_contour( tl_mpp )
- ENDIF
-
- ! Allocate space to hold variable value in structure
- IF( ASSOCIATED(td_var%d_value) )THEN
- DEALLOCATE(td_var%d_value)
- ENDIF
-
- DO jk=1,ip_maxdim
- IF( .NOT. td_var%t_dim(jk)%l_use ) tl_mpp%t_dim(jk)%i_len = 1
- ENDDO
-
- ! use mpp global dimension
- td_var%t_dim(:)%i_len=tl_mpp%t_dim(:)%i_len
-
- ALLOCATE(td_var%d_value( td_var%t_dim(1)%i_len, &
- & td_var%t_dim(2)%i_len, &
- & td_var%t_dim(3)%i_len, &
- & td_var%t_dim(4)%i_len),&
- & stat=il_status)
- IF(il_status /= 0 )THEN
-
- CALL logger_error( &
- & " IOM MPP READ VAR VALUE: not enough space to put variable "//&
- & TRIM(td_var%c_name)//&
- & " in variable structure")
-
- ENDIF
-
- ! read border processor
- DO jk=1,tl_mpp%i_nproc
- IF( tl_mpp%t_proc(jk)%l_ctr )THEN
-
- CALL logger_debug(" IOM MPP READ VAR VALUE: name "//TRIM(td_var%c_name) )
- CALL logger_debug(" IOM MPP READ VAR VALUE: ndim "//TRIM(fct_str(td_var%i_ndim)) )
- tl_var=iom_read_var( tl_mpp%t_proc(jk), td_var%c_name )
-
- ! get processor indices
- il_ind(:)=mpp_get_proc_index( tl_mpp, jk )
- il_i1p = il_ind(1)
- il_i2p = il_ind(2)
- il_j1p = il_ind(3)
- il_j2p = il_ind(4)
-
- IF( .NOT. td_var%t_dim(1)%l_use )THEN
- il_i1p=1
- il_i2p=1
- ENDIF
-
- IF( .NOT. td_var%t_dim(2)%l_use )THEN
- il_j1p=1
- il_j2p=1
- ENDIF
-
- ! replace value in mpp domain
- td_var%d_value(il_i1p:il_i2p,il_j1p:il_j2p,:,:) = &
- & tl_var%d_value(:,:,:,:)
-
- ! clean variable
- CALL var_clean(tl_var)
- ENDIF
- ENDDO
-
- ENDIF
-
- IF( PRESENT(td_dom) )THEN
-
- ! copy mpp structure
- tl_mpp=td_mpp
- ! forced to keep same id
- tl_mpp%t_proc(:)%i_id=td_mpp%t_proc(:)%i_id
-
- IF( ALL(.NOT. td_mpp%t_proc(:)%l_use) )THEN
- CALL logger_warn( "IOM MPP READ VAR VALUE: &
- & processor to be used not defined. look for it")
- ! get processor to be used
- CALL mpp_get_use( tl_mpp, td_dom )
- ENDIF
-
- ! Allocate space to hold variable value in structure
- IF( ASSOCIATED(td_var%d_value) )THEN
- DEALLOCATE(td_var%d_value)
- ENDIF
-
- tl_dom=td_dom
- DO jk=1,ip_maxdim
- IF( .NOT. td_var%t_dim(jk)%l_use ) tl_dom%t_dim(jk)%i_len = 1
- ENDDO
-
- ! use domain dimension
- td_var%t_dim(1:2)%i_len=tl_dom%t_dim(1:2)%i_len
-
- ALLOCATE(td_var%d_value( tl_dom%t_dim(1)%i_len, &
- & tl_dom%t_dim(2)%i_len, &
- & td_var%t_dim(3)%i_len, &
- & td_var%t_dim(4)%i_len),&
- & stat=il_status)
- IF(il_status /= 0 )THEN
-
- CALL logger_error( &
- & " IOM MPP READ VAR VALUE: not enough space to put variable "//&
- & TRIM(td_var%c_name)//&
- & " in variable structure")
-
- ENDIF
- CALL logger_debug("IOM MPP READ VAR VALUE: shape ("//&
- & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=1)))//","//&
- & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=2)))//","//&
- & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=3)))//","//&
- & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=4)))//")" )
- ! FillValue by default
- td_var%d_value(:,:,:,:)=td_var%d_fill
-
- IF( tl_dom%i_jmin < tl_dom%i_jmax )THEN
- ! no north pole
-
- IF( tl_dom%i_imin == 1 .AND. &
- & tl_dom%i_imax == tl_dom%t_dim0(1)%i_len )THEN
- ! east west cyclic
-
- CALL iom_mpp__no_pole_cyclic(tl_mpp, td_var, tl_dom)
-
- ELSEIF( tl_dom%i_imin < tl_dom%i_imax )THEN
- ! no east west overlap
-
- CALL iom_mpp__no_pole_no_overlap(tl_mpp, td_var, tl_dom)
-
- ! no more EW overlap in variable
- td_var%i_ew=-1
-
- ELSEIF( tl_dom%i_imin > tl_dom%i_imax )THEN
- ! east west overlap
-
- CALL iom_mpp__no_pole_overlap(tl_mpp, td_var, tl_dom)
-
- ! no more EW overlap in variable
- td_var%i_ew=-1
-
- ELSE
-
- CALL logger_error(" IOM MPP READ VAR VALUE: invalid domain definition.")
-
- ENDIF
-
- ELSE ! tl_dom%i_jmin >= tl_dom%i_jmax
- ! north pole
-
- CALL logger_error("IOM MPP READ VAR VALUE: siren is not able to do so now "//&
- & "maybe in the next release")
- ! IF( tl_dom%i_imin < tl_dom%i_imax )THEN
- ! ! no east west overlap
-
- ! CALL iom_mpp__pole_no_overlap(tl_mpp, td_var, tl_dom)
-
- ! ELSEIF(tl_dom%i_imin == tl_dom%i_imax)THEN
- ! ! east west cyclic
-
- ! CALL iom_mpp__pole_cyclic(tl_mpp, td_var, tl_dom)
-
- ! ELSE ! tl_dom%i_imin > tl_dom%i_imax
- ! ! east west overlap
-
- ! CALL iom_mpp__pole_overlap(tl_mpp, td_var, tl_dom)
-
- ! ENDIF
- ENDIF
-
- ENDIF
-
- ! force to change _FillValue to avoid mistake
- ! with dummy zero _FillValue
- IF( td_var%d_fill == 0._dp )THEN
- CALL var_chg_FillValue(td_var)
- ENDIF
-
- END SUBROUTINE iom_mpp__read_var_value
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine read variable value
- !> in an mpp structure. The output domain do not overlap
- !> north fold boundary or east-west boundary.
- !>
- !> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dom : domain structure
- !> @return variable structure completed
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_mpp__no_pole_no_overlap(td_mpp, td_var, td_dom )
- IMPLICIT NONE
- ! Argument
- TYPE(TMPP), INTENT(IN) :: td_mpp
- TYPE(TVAR), INTENT(INOUT) :: td_var
- TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom
-
- ! local variable
- INTEGER(i4), DIMENSION(4) :: il_ind
- INTEGER(i4) :: il_i1p
- INTEGER(i4) :: il_j1p
- INTEGER(i4) :: il_i2p
- INTEGER(i4) :: il_j2p
-
- INTEGER(i4) :: il_i1
- INTEGER(i4) :: il_j1
- INTEGER(i4) :: il_i2
- INTEGER(i4) :: il_j2
-
- INTEGER(i4), DIMENSION(4) :: il_start
- INTEGER(i4), DIMENSION(4) :: il_count
- TYPE(TVAR) :: tl_var
- TYPE(TDOM) :: tl_dom
-
- ! loop indices
- INTEGER(i4) :: jk
- !----------------------------------------------------------------
-
- ! change dimension length if not use
- tl_dom=td_dom
- IF( .NOT. td_var%t_dim(1)%l_use )THEN
- tl_dom%i_imin=1 ; tl_dom%i_imax=1
- ENDIF
- IF( .NOT. td_var%t_dim(2)%l_use )THEN
- tl_dom%i_jmin=1 ; tl_dom%i_jmax=1
- ENDIF
-! IF( .NOT. td_var%t_dim(3)%l_use )THEN
-! tl_dom%i_kmin=1 ; tl_dom%i_kmax=1
-! ENDIF
-! IF( .NOT. td_var%t_dim(4)%l_use )THEN
-! tl_dom%i_lmin=1 ; tl_dom%i_lmax=1
-! ENDIF
-
- ! read processor
- DO jk=1,td_mpp%i_nproc
- IF( td_mpp%t_proc(jk)%l_use )THEN
-
- ! get processor indices
- il_ind(:)=mpp_get_proc_index( td_mpp, jk )
- il_i1p = il_ind(1)
- il_i2p = il_ind(2)
- il_j1p = il_ind(3)
- il_j2p = il_ind(4)
-
- IF( .NOT. td_var%t_dim(1)%l_use )THEN
- il_i1p=tl_dom%i_imin ; il_i2p=tl_dom%i_imax
- ENDIF
- IF( .NOT. td_var%t_dim(2)%l_use )THEN
- il_j1p=tl_dom%i_jmin ; il_j2p=tl_dom%i_jmax
- ENDIF
-
- il_i1=MAX(il_i1p, tl_dom%i_imin)
- il_i2=MIN(il_i2p, tl_dom%i_imax)
-
- il_j1=MAX(il_j1p, tl_dom%i_jmin)
- il_j2=MIN(il_j2p, tl_dom%i_jmax)
-
- IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN
-
- il_start(:)=(/ il_i1-il_i1p+1, &
- & il_j1-il_j1p+1, &
- & 1,1 /)
-! & tl_dom%i_kmin, &
-! & tl_dom%i_lmin /)
-
- il_count(:)=(/ il_i2-il_i1+1, &
- & il_j2-il_j1+1, &
- & td_var%t_dim(3)%i_len, &
- & td_var%t_dim(4)%i_len /)
-! & tl_dom%t_dim(3)%i_len, &
-! & tl_dom%t_dim(4)%i_len /)
-
- tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,&
- & il_start(:), il_count(:) )
-
- ! replace value in output variable structure
- td_var%d_value( il_i1 - tl_dom%i_imin + 1 : &
- & il_i2 - tl_dom%i_imin + 1, &
- & il_j1 - tl_dom%i_jmin + 1 : &
- & il_j2 - tl_dom%i_jmin + 1, &
- & :,:) = tl_var%d_value(:,:,:,:)
-
- ENDIF
-
- ENDIF
+ il_start(:)=1
+ IF( PRESENT(id_start) ) il_start(:)=id_start(:)
+
+ il_count(:)=td_mpp%t_dim(:)%i_len
+ IF( PRESENT(id_count) ) il_count(:)=id_count(:)
+
+ DO jk=1,ip_maxdim
+ IF( .NOT. td_var%t_dim(jk)%l_use )THEN
+ il_start(jk) = 1
+ il_count(jk) = 1
+ ENDIF
+
+ il_end(jk)=il_start(jk)+il_count(jk)-1
ENDDO
- END SUBROUTINE iom_mpp__no_pole_no_overlap
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine read variable value
- !> in an mpp structure. The output domain do not overlap north fold boundary.
- !> However it uses cyclic east-west boundary.
- !>
- !> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dom : domain structure
- !> @return variable structure completed
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_mpp__no_pole_cyclic(td_mpp, td_var, td_dom )
- IMPLICIT NONE
- ! Argument
- TYPE(TMPP), INTENT(IN ) :: td_mpp
- TYPE(TVAR), INTENT(INOUT) :: td_var
- TYPE(TDOM), INTENT(IN ), OPTIONAL :: td_dom
-
- ! local variable
- INTEGER(i4), DIMENSION(4) :: il_ind
- INTEGER(i4) :: il_i1p
- INTEGER(i4) :: il_j1p
- INTEGER(i4) :: il_i2p
- INTEGER(i4) :: il_j2p
-
- INTEGER(i4) :: il_i1
- INTEGER(i4) :: il_j1
- INTEGER(i4) :: il_i2
- INTEGER(i4) :: il_j2
-
- INTEGER(i4), DIMENSION(4) :: il_start
- INTEGER(i4), DIMENSION(4) :: il_count
- TYPE(TVAR) :: tl_var
- TYPE(TDOM) :: tl_dom
-
- ! loop indices
- INTEGER(i4) :: jk
- !----------------------------------------------------------------
-
- ! change dimension length if not use
- tl_dom=td_dom
- IF( .NOT. td_var%t_dim(1)%l_use )THEN
- tl_dom%i_imin=1 ; tl_dom%i_imax=1
- ENDIF
- IF( .NOT. td_var%t_dim(2)%l_use )THEN
- tl_dom%i_jmin=1 ; tl_dom%i_jmax=1
- ENDIF
-! IF( .NOT. td_var%t_dim(3)%l_use )THEN
-! tl_dom%i_kmin=1 ; tl_dom%i_kmax=1
-! ENDIF
-! IF( .NOT. td_var%t_dim(4)%l_use )THEN
-! tl_dom%i_lmin=1 ; tl_dom%i_lmax=1
-! ENDIF
+
+ IF( ANY(il_end(:) > td_mpp%t_dim(:)%i_len) )THEN
+ CALL logger_fatal("IOM MPP READ VAR VALUE: start + count "//&
+ & "exceed dimension bound.")
+ ENDIF
+
+ ! use domain dimension
+ td_var%t_dim(:)%i_len=il_count(:)
+
+ ! Allocate space to hold variable value in structure
+ IF( ASSOCIATED(td_var%d_value) )THEN
+ DEALLOCATE(td_var%d_value)
+ ENDIF
+
+ ALLOCATE(td_var%d_value( il_count(1), &
+ & il_count(2), &
+ & il_count(3), &
+ & il_count(4)),&
+ & stat=il_status)
+ IF(il_status /= 0 )THEN
+
+ CALL logger_error( &
+ & " IOM MPP READ VAR VALUE: not enough space to put variable "//&
+ & TRIM(td_var%c_name)//&
+ & " in variable structure")
+
+ ENDIF
+
+ CALL logger_debug("IOM MPP READ VAR VALUE: shape ("//&
+ & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=1)))//","//&
+ & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=2)))//","//&
+ & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=3)))//","//&
+ & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=4)))//")" )
+ ! FillValue by default
+ td_var%d_value(:,:,:,:)=td_var%d_fill
! read processor
@@ -977,322 +522,71 @@
il_j1p = il_ind(3)
il_j2p = il_ind(4)
-
+
IF( .NOT. td_var%t_dim(1)%l_use )THEN
- il_i1p=tl_dom%i_imin ; il_i2p=tl_dom%i_imax
+ il_i1p=il_start(1) ; il_i2p=il_end(1)
ENDIF
IF( .NOT. td_var%t_dim(2)%l_use )THEN
- il_j1p=tl_dom%i_jmin ; il_j2p=tl_dom%i_jmax
+ il_j1p=il_start(2) ; il_j2p=il_end(2)
+ ENDIF
+
+ il_i1=MAX(il_i1p, il_start(1))
+ il_i2=MIN(il_i2p, il_end(1))
+
+ il_j1=MAX(il_j1p, il_start(2))
+ il_j2=MIN(il_j2p, il_end(2))
+
+ IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN
+ il_strt(:)=(/ il_i1-il_i1p+1, &
+ & il_j1-il_j1p+1, &
+ & 1,1 /)
+
+ il_cnt(:)=(/ il_i2-il_i1+1, &
+ & il_j2-il_j1+1, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len /)
+
+ tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,&
+ & il_strt(:), il_cnt(:) )
+ ! replace value in output variable structure
+ td_var%d_value( il_i1 - il_start(1) + 1 : &
+ & il_i2 - il_start(1) + 1, &
+ & il_j1 - il_start(2) + 1 : &
+ & il_j2 - il_start(2) + 1, &
+ & :,:) = tl_var%d_value(:,:,:,:)
+
+ ! clean
+ CALL var_clean(tl_var)
ENDIF
- il_i1=il_i1p
- il_j1=MAX(il_j1p, td_dom%i_jmin)
-
- il_i2=il_i2p
- il_j2=MIN(il_j2p, td_dom%i_jmax)
-
- IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN
-
- il_start(:)=(/ il_i1, &
- & il_j1-il_j1p+1, &
- & 1,1 /)
-! & tl_dom%i_kmin, &
-! & tl_dom%i_lmin /)
-
- il_count(:)=(/ il_i2-il_i1+1, &
- & il_j2-il_j1+1, &
- & td_var%t_dim(3)%i_len, &
- & td_var%t_dim(4)%i_len /)
-! & tl_dom%t_dim(3)%i_len, &
-! & tl_dom%t_dim(4)%i_len /)
-
- tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,&
- & il_start(:), il_count(:) )
-
- ! replace value in output variable structure
- td_var%d_value( il_i1 : il_i2, &
- & il_j1 - td_dom%i_jmin + 1 : &
- & il_j2 - td_dom%i_jmin + 1, &
- & :,:) = tl_var%d_value(:,:,:,:)
-
- ENDIF
-
ENDIF
ENDDO
- END SUBROUTINE iom_mpp__no_pole_cyclic
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine read variable value
- !> in an mpp structure. The output domain do not overlap north fold boundary.
- !> However it overlaps east-west boundary.
- !>
+ IF( td_var%t_dim(1)%l_use .AND. &
+ & td_var%t_dim(1)%i_len == td_mpp%t_dim(1)%i_len )THEN
+ IF( td_mpp%i_ew >= 0 )THEN
+ tl_att=att_init("ew_overlap",td_mpp%i_ew)
+ CALL var_move_att(td_var,tl_att)
+ ! clean
+ CALL att_clean(tl_att)
+ ENDIF
+ ENDIF
+
+ ! force to change _FillValue to avoid mistake
+ ! with dummy zero _FillValue
+ IF( td_var%d_fill == 0._dp )THEN
+ CALL var_chg_FillValue(td_var)
+ ENDIF
+
+ END SUBROUTINE iom_mpp__read_var_value
+ !-------------------------------------------------------------------
+ !> @brief This subroutine write files composing mpp structure.
+ !
!> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dom : domain structure
- !> @return variable structure completed
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_mpp__no_pole_overlap(td_mpp, td_var, td_dom )
- IMPLICIT NONE
- ! Argument
- TYPE(TMPP), INTENT(IN) :: td_mpp
- TYPE(TVAR), INTENT(INOUT) :: td_var
- TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom
-
- ! local variable
- INTEGER(i4), DIMENSION(4) :: il_ind
- INTEGER(i4) :: il_i1p
- INTEGER(i4) :: il_j1p
- INTEGER(i4) :: il_i2p
- INTEGER(i4) :: il_j2p
-
- INTEGER(i4) :: il_i1
- INTEGER(i4) :: il_j1
- INTEGER(i4) :: il_i2
- INTEGER(i4) :: il_j2
-
- INTEGER(i4) :: il_ioffset
-
- INTEGER(i4), DIMENSION(4) :: il_start
- INTEGER(i4), DIMENSION(4) :: il_count
- TYPE(TVAR) :: tl_var
- TYPE(TDOM) :: tl_dom
-
- ! loop indices
- INTEGER(i4) :: jk
- !----------------------------------------------------------------
-
- il_ioffset = (td_mpp%t_dim(1)%i_len-2) - td_dom%i_imin + 1
-
- ! change dimension length if not use
- tl_dom=td_dom
- IF( .NOT. td_var%t_dim(1)%l_use )THEN
- tl_dom%i_imin=1 ; tl_dom%i_imax=1
- il_ioffset=0
- ENDIF
- IF( .NOT. td_var%t_dim(2)%l_use )THEN
- tl_dom%i_jmin=1 ; tl_dom%i_jmax=1
- ENDIF
-! IF( .NOT. td_var%t_dim(3)%l_use )THEN
-! tl_dom%i_kmin=1 ; tl_dom%i_kmax=1
-! ENDIF
-! IF( .NOT. td_var%t_dim(4)%l_use )THEN
-! tl_dom%i_lmin=1 ; tl_dom%i_lmax=1
-! ENDIF
-
- ! read processor
- DO jk=1,td_mpp%i_nproc
- IF( td_mpp%t_proc(jk)%l_use )THEN
-
- ! get processor indices
- il_ind(:)=mpp_get_proc_index( td_mpp, jk )
- il_i1p = il_ind(1)
- il_i2p = il_ind(2)
- il_j1p = il_ind(3)
- il_j2p = il_ind(4)
-
- IF( .NOT. td_var%t_dim(1)%l_use )THEN
- il_i1p=tl_dom%i_imin ; il_i2p=tl_dom%i_imax
- ENDIF
- IF( .NOT. td_var%t_dim(2)%l_use )THEN
- il_j1p=tl_dom%i_jmin ; il_j2p=tl_dom%i_jmax
- ENDIF
-
- !!!!!! get first part of domain
- il_i1=MAX(il_i1p, td_dom%i_imin)
- il_j1=MAX(il_j1p, td_dom%i_jmin)
-
- il_i2=MIN(il_i2p, td_mpp%t_dim(1)%i_len-td_var%i_ew) ! east-west overlap
- il_j2=MIN(il_j2p, td_dom%i_jmax)
-
- IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN
-
- il_start(:)=(/ il_i1-il_i1p+1, &
- & il_j1-il_j1p+1, &
- & 1,1 /)
-! & tl_dom%i_kmin, &
-! & tl_dom%i_lmin /)
-
- il_count(:)=(/ il_i2-il_i1+1, &
- & il_j2-il_j1+1, &
- & td_var%t_dim(3)%i_len, &
- & td_var%t_dim(4)%i_len /)
-! & tl_dom%t_dim(3)%i_len, &
-! & tl_dom%t_dim(4)%i_len /)
-
- tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,&
- & il_start(:), il_count(:) )
-
- ! replace value in output variable structure
- td_var%d_value( il_i1 - td_dom%i_imin + 1 : &
- & il_i2 - td_dom%i_imin + 1, &
- & il_j1 - td_dom%i_jmin + 1 : &
- & il_j2 - td_dom%i_jmin + 1, &
- & :,:) = tl_var%d_value(:,:,:,:)
-
- ENDIF
-
- !!!!! get second part of domain
- il_i1=MAX(il_i1p, 1)
- il_j1=MAX(il_j1p, td_dom%i_jmin)
-
- il_i2=MIN(il_i2p, td_dom%i_imax)
- il_j2=MIN(il_j2p, td_dom%i_jmax)
-
- IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN
-
- il_start(:)=(/ il_i1, &
- & il_j1-il_j1p+1, &
- & 1,1 /)
-! & tl_dom%i_kmin, &
-! & tl_dom%i_lmin /)
-
- il_count(:)=(/ il_i2-il_i1+1, &
- & il_j2-il_j1+1, &
- & td_var%t_dim(3)%i_len, &
- & td_var%t_dim(4)%i_len /)
-! & tl_dom%t_dim(3)%i_len, &
-! & tl_dom%t_dim(4)%i_len /)
-
- tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,&
- & il_start(:), il_count(:) )
-
- ! replace value in output variable structure
- td_var%d_value( il_ioffset + il_i1 : &
- & il_ioffset + il_i2, &
- & il_j1 - td_dom%i_jmin + 1 : &
- & il_j2 - td_dom%i_jmin + 1, &
- & :,:) = tl_var%d_value(:,:,:,:)
-
- ENDIF
-
- ENDIF
- ENDDO
-
- END SUBROUTINE iom_mpp__no_pole_overlap
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine read variable value
- !> in an mpp structure. The output domain overlaps
- !> north fold boundary. However it do not overlap east-west boundary.
- !>
- !> @details
- !> If domain is given, read only domain.
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dom : domain structure
- !> @return variable structure completed
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
-! SUBROUTINE iom_mpp__pole_no_overlap(td_mpp, td_var, td_dom )
-! IMPLICIT NONE
-! ! Argument
-! TYPE(TMPP), INTENT(IN) :: td_mpp
-! TYPE(TVAR), INTENT(INOUT) :: td_var
-! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom
-!
-! ! local variable
-!
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END SUBROUTINE iom_mpp__pole_no_overlap
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine read variable value
- !> in an mpp structure. The output domain overlaps north fold boundary.
- !> and uses cyclic east-west boundary.
- !>
- !> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dom : domain structure
- !> @param[in] ld_border : read only border
- !> @return variable structure completed
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
-! SUBROUTINE iom_mpp__pole_cyclic(td_mpp, td_var, td_dom )
-! IMPLICIT NONE
-! ! Argument
-! TYPE(TMPP), INTENT(IN) :: td_mpp
-! TYPE(TVAR), INTENT(INOUT) :: td_var
-! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom
-!
-! ! local variable
-!
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END SUBROUTINE iom_mpp__pole_cyclic
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine read variable value
- !> in an mpp structure. The output domain overlaps north fold boundary.
- !> and east-west boundary.
- !>
- !> @details
- !> If domain is given, read only domain.
- !> If border is .TRUE., read only border processor
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dom : domain structure
- !> @param[in] ld_border : read only border
- !> @return variable structure completed
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
-! SUBROUTINE iom_mpp__pole_overlap(td_mpp, td_var, td_dom )
-! IMPLICIT NONE
-! ! Argument
-! TYPE(TMPP), INTENT(IN) :: td_mpp
-! TYPE(TVAR), INTENT(INOUT) :: td_var
-! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom
-!
-! ! local variable
-!
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END SUBROUTINE iom_mpp__pole_overlap
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine write mpp structure in opened files.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_mpp mpp structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_mpp_write_file(td_mpp)
IMPLICIT NONE
@@ -1300,4 +594,5 @@
TYPE(TMPP), INTENT(INOUT) :: td_mpp
+ ! local variable
! loop indices
INTEGER(i4) :: ji
@@ -1312,4 +607,7 @@
DO ji=1, td_mpp%i_nproc
IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN
+ !CALL file_del_att(td_mpp%t_proc(ji), 'periodicity')
+ !CALL file_del_att(td_mpp%t_proc(ji), 'ew_overlap')
+
CALL iom_write_file(td_mpp%t_proc(ji))
ELSE
@@ -1320,4 +618,3 @@
ENDIF
END SUBROUTINE iom_mpp_write_file
- !> @endcode
END MODULE iom_mpp
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_rstdimg.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_rstdimg.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/iom_rstdimg.f90 (revision 5214)
@@ -10,66 +10,73 @@
!>
!> @details
-!>
!> to open dimg file (create file structure):
+!> @code
!> CALL iom_rstdimg_open(td_file)
+!> @endcode
!> - td_file is file structure (see file.f90)
!>
!> to write in dimg file:
+!> @code
!> CALL iom_rstdimg_write_file(td_file)
+!> @endcode
!>
!> to close dimg file:
+!> @code
!> CALL iom_rstdimg_close(tl_file)
+!> @endcode
!>
!> to read one dimension in dimg file:
-!> tl_dim = iom_rstdimg_read_dim(tl_file, id_dimid)
-!> or
+!> @code
+!> tl_dim = iom_rstdimg_read_dim(tl_file, id_dimid)
+!> @endcode
+!> or
+!> @code
!> tl_dim = iom_rstdimg_read_dim(tl_file, cd_name)
+!> @endcode
!> - id_dimid is dimension id
!> - cd_name is dimension name
!>
-!> to read one global attribute in dimg file:
-!> tl_att = iom_rstdimg_read_att(tl_file, id_varid, id_attid)
-!> or
-!> tl_att = iom_rstdimg_read_att(tl_file, id_varid, cd_name)
-!> - id_varid is variable id
-!> - id_attid is attribute id
-!> - cd_name is attribute name
-!>
!> to read one variable in dimg file:
-!> tl_var = iom_rstdimg_read_var(td_file, id_varid, [id_start, id_count])
-!> or
-!> tl_var = iom_rstdimg_read_var(td_file, cd_name, [id_start, [id_count,]] [cd_stdname])
+!> @code
+!> tl_var = iom_rstdimg_read_var(td_file, id_varid, [id_start, id_count])
+!> @endcode
+!> or
+!> @code
+!> tl_var = iom_rstdimg_read_var(td_file, cd_name, [id_start, [id_count]])
+!> @endcode
!> - id_varid is variabale id
-!> - cd_name is variabale name
-!> - id_start is a integer(4) 1D table of index from which the data
-!> values will be read (optional)
-!> - id_count is a integer(4) 1D table of the number of indices selected
-!> along each dimension (optional)
-!> - cd_stdname is variable standard name (optional)
+!> - cd_name is variabale name or standard name
+!> - id_start is a integer(4) 1D array of index from which the data
+!> values will be read [optional]
+!> - id_count is a integer(4) 1D array of the number of indices selected
+!> along each dimension [optional]
+!>
+!> to get sub domain decomppistion in a dimg file:
+!> @code
+!> CALL iom_rstdimg_get_mpp(td_file)
+!> @endcode
!>
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
-!> @param MyModule_type : brief_description
+!> @date November, 2013 - Initial Version
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!
-!> @todo
!----------------------------------------------------------------------
MODULE iom_rstdimg
USE netcdf ! nf90 library
+ USE global ! global parameter
USE kind ! F90 kind parameter
USE fct ! basic useful function
- USE logger ! log file manager
+ USE logger ! log file manager
USE att ! attribute manager
USE dim ! dimension manager
USE var ! variable manager
USE file ! file manager
- USE dom ! domain manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
+
+ ! type and variable
+ PRIVATE :: im_vnl !< variable name length
! function and subroutine
@@ -78,27 +85,24 @@
PUBLIC :: iom_rstdimg_read_dim !< read one dimension in an opened dimg file, return variable structure
PUBLIC :: iom_rstdimg_read_var !< read one variable in an opened dimg file, return dimension structure
- PUBLIC :: iom_rstdimg_fill_var !< fill variable value in an opened dimg file
PUBLIC :: iom_rstdimg_write_file !< write file structure contents in an opened dimg file
PUBLIC :: iom_rstdimg_get_mpp !< get sub domain decomppistion in a dimg file
- PRIVATE :: iom_rstdimg__get_info !< get global information in an opened dimg file
- PRIVATE :: iom_rstdimg__get_file_var !< read information about variable on an opened dimg file.
- PRIVATE :: iom_rstdimg__get_file_var_0d !< put information about scalar variable in file structure
- PRIVATE :: iom_rstdimg__get_file_var_1d !< put information about variable 1D in file structure
- PRIVATE :: iom_rstdimg__get_file_var_2d !< put information about variable 2D in file structure
- PRIVATE :: iom_rstdimg__get_file_var_3d !< put information about variable 3D in file structure
- PRIVATE :: iom_rstdimg__read_dim_id !< read dimension structure in an opened dimg file, given variable id.
- PRIVATE :: iom_rstdimg__read_dim_name !< read dimension structure in an opened dimg file, given variable name or standard name.
- PRIVATE :: iom_rstdimg__read_var_id !< read variable value in an opened dimg file, given variable id.
- PRIVATE :: iom_rstdimg__read_var_name !< read variable value in an opened dimg file, given variable name or standard name.
- PRIVATE :: iom_rstdimg__read_var_value !< read variable value in an opened dimg file, for variable 1,2,3d
- PRIVATE :: iom_rstdimg__write_header !< write header in an opened dimg file
- PRIVATE :: iom_rstdimg__write_var !< write variables in an opened dimg file
- PRIVATE :: iom_rstdimg__fill_var_id !< fill variable value in an opened dimg file, given variable id
- PRIVATE :: iom_rstdimg__fill_var_name !< fill variable value in an opened dimg file, given variable name
- PRIVATE :: iom_rstdimg__fill_var_all !< fill all variable value in an opened dimg file
+ PRIVATE :: iom_rstdimg__get_info ! get global information in an opened dimg file
+ PRIVATE :: iom_rstdimg__get_file_var ! read information about variable on an opened dimg file.
+ PRIVATE :: iom_rstdimg__get_file_var_0d ! put information about scalar variable in file structure
+ PRIVATE :: iom_rstdimg__get_file_var_1d ! put information about variable 1D in file structure
+ PRIVATE :: iom_rstdimg__get_file_var_2d ! put information about variable 2D in file structure
+ PRIVATE :: iom_rstdimg__get_file_var_3d ! put information about variable 3D in file structure
+ PRIVATE :: iom_rstdimg__read_dim_id ! read dimension structure in an opened dimg file, given variable id.
+ PRIVATE :: iom_rstdimg__read_dim_name ! read dimension structure in an opened dimg file, given variable name or standard name.
+ PRIVATE :: iom_rstdimg__read_var_id ! read variable value in an opened dimg file, given variable id.
+ PRIVATE :: iom_rstdimg__read_var_name ! read variable value in an opened dimg file, given variable name or standard name.
+ PRIVATE :: iom_rstdimg__read_var_value ! read variable value in an opened dimg file, for variable 1,2,3d
+ PRIVATE :: iom_rstdimg__get_rec ! compute record number before writing file
+ PRIVATE :: iom_rstdimg__write_header ! write header in an opened dimg file
+ PRIVATE :: iom_rstdimg__write_var ! write variables in an opened dimg file
! module variable
- INTEGER(i4), PARAMETER :: ip_vnl = 32 ! variable name length
+ INTEGER(i4), PARAMETER :: im_vnl = 32 ! variable name length
INTERFACE iom_rstdimg_read_dim
@@ -112,13 +116,8 @@
END INTERFACE iom_rstdimg_read_var
- INTERFACE iom_rstdimg_fill_var
- MODULE PROCEDURE iom_rstdimg__fill_var_id
- MODULE PROCEDURE iom_rstdimg__fill_var_name
- MODULE PROCEDURE iom_rstdimg__fill_var_all
- END INTERFACE iom_rstdimg_fill_var
-
CONTAINS
!-------------------------------------------------------------------
- !> @brief This subroutine open a dimg file in read or write mode
+ !> @brief This subroutine open a dimg file in read or write mode.
+ !> @details
!> if try to open a file in write mode that did not exist, create it.
!> if file already exist, get information about:
@@ -128,12 +127,12 @@
!> - the ID of the unlimited dimension
!> - the file format
- !> and finally read dimensions.
+ !> Finally it read dimensions, and 'longitude' variable to compute East-West
+ !> overlap.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg_open(td_file)
IMPLICIT NONE
@@ -146,6 +145,4 @@
INTEGER(i4) :: il_status
-
- TYPE(TVAR) :: tl_lon
!----------------------------------------------------------------
@@ -180,5 +177,4 @@
ENDIF
-
ENDIF
@@ -224,5 +220,4 @@
ENDIF
-
IF( .NOT. td_file%l_wrt )THEN
@@ -240,5 +235,8 @@
CALL fct_err(il_status)
IF( il_status /= 0 )THEN
- CALL logger_error("OPEN: file "//TRIM(td_file%c_name)&
+ CALL logger_debug("IOM RSTDIMG OPEN: open staus "//&
+ & TRIM(fct_str(il_status)))
+ CALL logger_fatal("IOM RSTDIMG OPEN: file "//&
+ & TRIM(td_file%c_name)&
& //" with record length "//TRIM(fct_str(td_file%i_recl)))
ENDIF
@@ -260,5 +258,8 @@
CALL fct_err(il_status)
IF( il_status /= 0 )THEN
- CALL logger_error("OPEN: file "//TRIM(td_file%c_name))
+ CALL logger_debug("IOM RSTDIMG OPEN: open staus "//&
+ & TRIM(fct_str(il_status)))
+ CALL logger_error("IOM RSTDIMG OPEN: file "//&
+ & TRIM(td_file%c_name))
ENDIF
@@ -274,12 +275,4 @@
CALL iom_rstdimg__get_file_var(td_file)
- ! get ew overlap
- tl_lon=iom_rstdimg_read_var(td_file,'longitude')
- td_file%i_ew=dom_get_ew_overlap(tl_lon)
- WHERE( td_file%t_var(:)%t_dim(1)%l_use )
- td_file%t_var(:)%i_ew=td_file%i_ew
- ENDWHERE
- CALL var_clean(tl_lon)
-
ENDIF
@@ -287,14 +280,12 @@
END SUBROUTINE iom_rstdimg_open
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine close dimg file
+ !-------------------------------------------------------------------
+ !> @brief This subroutine close dimg file.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg_close(td_file)
IMPLICIT NONE
@@ -327,21 +318,18 @@
END SUBROUTINE iom_rstdimg_close
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine get global information in an opened dimg
- !> file.
+ !> file.
!> @details
!> It gets the number of variables, the domain decompistion,
- !> the record of the header infos.
+ !> the record of the header.
!> It read dimensions, and add it to dimension structure inside
!> file structure.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg__get_info(td_file)
IMPLICIT NONE
@@ -360,5 +348,5 @@
CALL logger_debug( &
- & " GET INFO: about dimg file "//TRIM(td_file%c_name))
+ & " IOM RSTDIMG GET INFO: about dimg file "//TRIM(td_file%c_name))
! read first record
@@ -370,9 +358,8 @@
CALL fct_err(il_status)
IF( il_status /= 0 )THEN
- CALL logger_error("GET INFO: read first line of "//TRIM(td_file%c_name))
- ENDIF
-
- CALL logger_trace( &
- & " GET INFO: about dimg file "//TRIM(td_file%c_name))
+ CALL logger_debug(" READ status: "//TRIM(fct_str(il_status)))
+ CALL logger_fatal("IOM RSTDIMG GET INFO: read first line of "//&
+ & TRIM(td_file%c_name))
+ ENDIF
td_file%c_type='dimg'
@@ -380,9 +367,9 @@
! add dimension to file structure
tl_dim=dim_init('X', il_nx)
- CALL file_add_dim(td_file, tl_dim)
+ CALL file_move_dim(td_file, tl_dim)
tl_dim=dim_init('Y', il_ny)
- CALL file_add_dim(td_file, tl_dim)
+ CALL file_move_dim(td_file, tl_dim)
tl_dim=dim_init('Z', il_nz)
- CALL file_add_dim(td_file, tl_dim)
+ CALL file_move_dim(td_file, tl_dim)
! reorder dimension to ('x','y','z','t')
@@ -401,17 +388,14 @@
END SUBROUTINE iom_rstdimg__get_info
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine get sub domain decomposition in a dimg file.
+ !-------------------------------------------------------------------
+ !> @brief This subroutine get sub domain decomposition in a dimg file.
!> @details
!> domain decomposition informations are saved in attributes.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @return mpp structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg_get_mpp(td_file)
IMPLICIT NONE
@@ -440,5 +424,6 @@
!----------------------------------------------------------------
- CALL logger_trace( " GET MPP: dimg file "//TRIM(td_file%c_name))
+ CALL logger_debug( " IOM RSTDIMG GET MPP: dimg file "//&
+ & TRIM(td_file%c_name))
! read first record
@@ -453,22 +438,25 @@
CALL fct_err(il_status)
IF( il_status /= 0 )THEN
- CALL logger_error("GET MPP: read first line of "//TRIM(td_file%c_name))
+ CALL logger_debug(" IOM RSTDIMG GET MPP: read status: "//&
+ & TRIM(fct_str(il_status)))
+ CALL logger_error(" IOM RSTDIMG GET MPP: read first line of "//&
+ & TRIM(td_file%c_name))
ENDIF
! create attributes to save mpp value
tl_att=att_init( "DOMAIN_number_total", il_nproc)
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_I_number_total", il_niproc)
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_J_number_total", il_njproc)
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_number", il_area)
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_size_global", (/il_iglo, il_jglo/))
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
! allocate local variable
@@ -480,6 +468,6 @@
IF(il_status /= 0 )THEN
- CALL logger_error( " GET MPP: not enough space to put domain &
- & decomposition in file "//TRIM(td_file%c_name) )
+ CALL logger_error( " IOM RSTDIMG GET MPP: not enough space to put "//&
+ & "domain decomposition in file "//TRIM(td_file%c_name) )
ENDIF
@@ -500,39 +488,44 @@
CALL fct_err(il_status)
IF( il_status /= 0 )THEN
- CALL logger_error("GET INFO: read domain decomposition on first &
- & line of "//TRIM(td_file%c_name))
+ CALL logger_debug(" IOM RSTDIMG GET MPP: read status: "//&
+ & TRIM(fct_str(il_status)))
+ CALL logger_fatal("IOM RSTDIMG GET MPP: read domain decomposition "//&
+ & "on first line of "//TRIM(td_file%c_name))
ENDIF
tl_att=att_init( "DOMAIN_position_first", (/il_impp(il_area), il_jmpp(il_area)/))
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_position_last", (/il_lci(il_area), il_lcj(il_area)/))
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_halo_size_start", (/il_ldi(il_area), il_ldj(il_area)/))
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_halo_size_end", (/il_lei(il_area), il_lej(il_area)/))
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_I_position_first", il_impp(:) )
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_J_position_first", il_jmpp(:) )
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_I_position_last", il_lci(:) )
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_J_position_last", il_lcj(:) )
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_I_halo_size_start", il_ldi(:) )
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_J_halo_size_start", il_ldj(:) )
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_I_halo_size_end", il_lei(:) )
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
tl_att=att_init( "DOMAIN_J_halo_size_end", il_lej(:) )
- CALL file_add_att(td_file, tl_att)
+ CALL file_move_att(td_file, tl_att)
+
+ ! clean
+ CALL att_clean(tl_att)
DEALLOCATE( il_impp, il_jmpp,&
@@ -542,18 +535,17 @@
END SUBROUTINE iom_rstdimg_get_mpp
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine read information about variable on an
- !> opened dimg file.
- !> The variable structure inside file structure is then completed.
+ !> opened dimg file.
+ !> @details
+ !> The variables structures inside file structure are then completed.
+ !> Variables no0d, no1d, no2d, no3d are deleted from file strucutre.
!> @note variable value are read only for scalar variable (0d).
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg__get_file_var(td_file)
IMPLICIT NONE
@@ -562,5 +554,5 @@
! local variable
- CHARACTER(LEN=ip_vnl), DIMENSION(:), ALLOCATABLE :: cl_name
+ CHARACTER(LEN=im_vnl), DIMENSION(:), ALLOCATABLE :: cl_name
REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value
@@ -605,4 +597,5 @@
IF(ASSOCIATED(td_file%t_var))THEN
+ CALL var_clean(td_file%t_var(:))
DEALLOCATE(td_file%t_var)
ENDIF
@@ -638,23 +631,20 @@
END SUBROUTINE iom_rstdimg__get_file_var
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine put information about scalar variable
+ !-------------------------------------------------------------------
+ !> @brief This subroutine put informations about scalar variable
!> inside file structure.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] cd_name : table of variable name
- !> @param[in] dd_value : table of variable value
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] cd_name array of variable name
+ !> @param[in] dd_value array of variable value
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg__get_file_var_0d(td_file, cd_name, dd_value)
IMPLICIT NONE
! Argument
TYPE(TFILE), INTENT(INOUT) :: td_file
- CHARACTER(LEN=ip_vnl), DIMENSION(:), INTENT(IN) :: cd_name
+ CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN) :: cd_name
REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value
@@ -667,5 +657,5 @@
! define same dimension as in file
- tl_dim(:)=td_file%t_dim(:)
+ tl_dim(:)=dim_copy(td_file%t_dim(:))
! do not use any dimension
tl_dim(:)%l_use=.FALSE.
@@ -676,5 +666,6 @@
td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, &
- & tl_dim(:), id_id=ji, id_rec=1 )
+ & tl_dim(:), dd_fill=0._dp, &
+ & id_id=ji, id_rec=1 )
! get value of scalar
@@ -688,24 +679,24 @@
ENDDO
+ ! clean
+ CALL dim_clean(tl_dim(:))
+
END SUBROUTINE iom_rstdimg__get_file_var_0d
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine put information about variable 1D
+ !-------------------------------------------------------------------
+ !> @brief This subroutine put informations about variable 1D
!> inside file structure.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] cd_name : table of variable name
- !> @param[in] dd_value : table of variable record
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] cd_name array of variable name
+ !> @param[in] dd_value array of variable record
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg__get_file_var_1d(td_file, cd_name, dd_value)
IMPLICIT NONE
! Argument
TYPE(TFILE), INTENT(INOUT) :: td_file
- CHARACTER(LEN=ip_vnl), DIMENSION(:), INTENT(IN) :: cd_name
+ CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN) :: cd_name
REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value
@@ -722,5 +713,5 @@
! define same dimension as in file
- tl_dim(:)=td_file%t_dim(:)
+ tl_dim(:)=dim_copy(td_file%t_dim(:))
! do not use X and Y dimension
td_file%t_var(ji)%t_dim(1:2)%l_use=.FALSE.
@@ -728,29 +719,29 @@
td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, &
- & tl_dim(:), id_id=ji, &
- & id_rec=INT(dd_value(ji),i4) )
+ & tl_dim(:), dd_fill=0._dp, &
+ & id_id=ji, id_rec=INT(dd_value(ji),i4) )
+
+ ! clean
+ CALL dim_clean(tl_dim(:))
ENDDO
END SUBROUTINE iom_rstdimg__get_file_var_1d
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine put information about variable 2D
+ !-------------------------------------------------------------------
+ !> @brief This subroutine put informations about variable 2D
!> inside file structure.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] cd_name : table of variable name
- !> @param[in] dd_value : table of variable record
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] cd_name array of variable name
+ !> @param[in] dd_value array of variable record
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg__get_file_var_2d(td_file, cd_name, dd_value)
IMPLICIT NONE
! Argument
TYPE(TFILE), INTENT(INOUT) :: td_file
- CHARACTER(LEN=ip_vnl), DIMENSION(:), INTENT(IN) :: cd_name
+ CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN) :: cd_name
REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value
@@ -767,5 +758,5 @@
! define same dimension as in file
- tl_dim(:)=td_file%t_dim(:)
+ tl_dim(:)=dim_copy(td_file%t_dim(:))
! do not use Z dimension
tl_dim(3)%l_use=.FALSE.
@@ -773,29 +764,29 @@
td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, &
- & tl_dim(:), id_id=ji, &
- & id_rec=INT(dd_value(ji),i4) )
+ & tl_dim(:), dd_fill=0._dp, &
+ & id_id=ji, id_rec=INT(dd_value(ji),i4) )
+
+ ! clean
+ CALL dim_clean(tl_dim(:))
ENDDO
END SUBROUTINE iom_rstdimg__get_file_var_2d
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine put information about variable 3D
+ !-------------------------------------------------------------------
+ !> @brief This subroutine put informations about variable 3D
!> inside file structure.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] cd_name : table of variable name
- !> @param[in] dd_value : table of variable record
- !> @return file structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !> @param[in] cd_name array of variable name
+ !> @param[in] dd_value array of variable record
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg__get_file_var_3d(td_file, cd_name, dd_value)
IMPLICIT NONE
! Argument
TYPE(TFILE), INTENT(INOUT) :: td_file
- CHARACTER(LEN=ip_vnl), DIMENSION(:), INTENT(IN) :: cd_name
+ CHARACTER(LEN=im_vnl), DIMENSION(:), INTENT(IN) :: cd_name
REAL(dp), DIMENSION(:), INTENT(IN) :: dd_value
@@ -812,14 +803,16 @@
! define same dimension as in file
- tl_dim(:)=td_file%t_dim(:)
+ tl_dim(:)=dim_copy(td_file%t_dim(:))
td_file%t_var(ji)=var_init( TRIM(cd_name(ji)), NF90_DOUBLE, &
- & tl_dim(:), id_id=ji, &
- & id_rec=INT(dd_value(ji),i4) )
+ & tl_dim(:), dd_fill=0._dp, &
+ & id_id=ji, id_rec=INT(dd_value(ji),i4) )
+
+ ! clean
+ CALL dim_clean(tl_dim(:))
ENDDO
END SUBROUTINE iom_rstdimg__get_file_var_3d
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read one dimension in an opened netcdf file,
@@ -829,9 +822,8 @@
!> - Nov, 2013- Initial Version
!
- !> @param[in] td_file : file structure
- !> @param[in] id_dimid : dimension id
+ !> @param[in] td_file file structure
+ !> @param[in] id_dimid dimension id
!> @return dimension structure
!-------------------------------------------------------------------
- !> @code
TYPE(TDIM) FUNCTION iom_rstdimg__read_dim_id(td_file, id_dimid)
IMPLICIT NONE
@@ -866,5 +858,4 @@
END FUNCTION iom_rstdimg__read_dim_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read one dimension in an opened netcdf file,
@@ -874,9 +865,8 @@
!> - Nov, 2013- Initial Version
!
- !> @param[in] td_file : file structure
- !> @param[in] cd_name : dimension name
+ !> @param[in] td_file file structure
+ !> @param[in] cd_name dimension name
!> @return dimension structure
!-------------------------------------------------------------------
- !> @code
TYPE(TDIM) FUNCTION iom_rstdimg__read_dim_name(td_file, cd_name)
IMPLICIT NONE
@@ -909,22 +899,21 @@
END FUNCTION iom_rstdimg__read_dim_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read variable value in an opened
- !> dimg file, given variable id.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
+ !> dimg file, given variable id.
+ !> @details
+ !> Optionaly, start indices and number of indices selected along each dimension
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] id_varid : variable id
- !> @param[in] id_start : index in the variable from which the data values
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] id_varid variable id
+ !> @param[in] id_start index in the variable from which the data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
+ !> @param[in] id_count number of indices selected along each dimension
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
TYPE(TVAR) FUNCTION iom_rstdimg__read_var_id(td_file, id_varid,&
& id_start, id_count)
@@ -935,9 +924,7 @@
INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
! local variable
- INTEGER(i4), DIMENSION(1) :: il_ind
+ INTEGER(i4), DIMENSION(1) :: il_varid
!----------------------------------------------------------------
! check if file opened
@@ -950,8 +937,8 @@
! look for variable id
- il_ind(:)=MINLOC(td_file%t_var(:)%i_id,mask=(td_file%t_var(:)%i_id==id_varid))
- IF( il_ind(1) /= 0 )THEN
-
- iom_rstdimg__read_var_id=td_file%t_var(il_ind(1))
+ il_varid(:)=MINLOC(td_file%t_var(:)%i_id,mask=(td_file%t_var(:)%i_id==id_varid))
+ IF( il_varid(1) /= 0 )THEN
+
+ iom_rstdimg__read_var_id=var_copy(td_file%t_var(il_varid(1)))
IF( iom_rstdimg__read_var_id%i_ndim /= 0 )THEN
@@ -962,5 +949,5 @@
ELSE
CALL logger_debug( " READ VAR: variable 0d "//&
- & TRIM(td_file%t_var(il_ind(1))%c_name)//&
+ & TRIM(td_file%t_var(il_varid(1))%c_name)//&
& " should be already read ")
ENDIF
@@ -974,27 +961,24 @@
ENDIF
END FUNCTION iom_rstdimg__read_var_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function read variable value in an opened
- !> dimg file, given variable name or standard name.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
+ !> dimg file, given variable name or standard name.
!> @details
+ !> Optionaly, start indices and number of indices selected along each dimension
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
+ !
!> look first for variable name. If it doesn't
!> exist in file, look for variable standard name.
- !> If variable name is not present, check variable standard name.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] cd_name : variable name or standard name
- !> @param[in] id_start : index in the variable from which the data values
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[in] cd_name variable name or standard name
+ !> @param[in] id_start index in the variable from which the data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
+ !> @param[in] id_count number of indices selected along each dimension
!> @return variable structure
!-------------------------------------------------------------------
- !> @code
TYPE(TVAR) FUNCTION iom_rstdimg__read_var_name(td_file, cd_name, &
& id_start, id_count )
@@ -1005,9 +989,7 @@
INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
! local variable
- INTEGER(i4) :: il_ind
+ INTEGER(i4) :: il_varid
!----------------------------------------------------------------
! check if file opened
@@ -1019,10 +1001,10 @@
ELSE
- il_ind=var_get_id(td_file%t_var(:), cd_name)
- IF( il_ind /= 0 )THEN
-
- iom_rstdimg__read_var_name=td_file%t_var(il_ind)
-
- IF( td_file%t_var(il_ind)%i_ndim /= 0 )THEN
+ il_varid=var_get_index(td_file%t_var(:), cd_name)
+ IF( il_varid /= 0 )THEN
+
+ iom_rstdimg__read_var_name=var_copy(td_file%t_var(il_varid))
+
+ IF( td_file%t_var(il_varid)%i_ndim /= 0 )THEN
!!! read variable value
CALL iom_rstdimg__read_var_value( td_file, &
@@ -1031,5 +1013,5 @@
ELSE
CALL logger_debug( " READ VAR: variable 0d "//&
- & TRIM(td_file%t_var(il_ind)%c_name)//&
+ & TRIM(td_file%t_var(il_varid)%c_name)//&
& " should have been already read ")
ENDIF
@@ -1047,197 +1029,19 @@
END FUNCTION iom_rstdimg__read_var_name
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill all variable value in an opened
- !> dimg file.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_rstdimg__fill_var_all(td_file, id_start, id_count)
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
-
- ! local variable
-
- ! loop indices
- INTEGER(i4) :: ji
- !----------------------------------------------------------------
- ! check if file opened
- IF( td_file%i_id == 0 )THEN
-
- CALL logger_error( &
- & " FILL VAR: no id associated to file "//TRIM(td_file%c_name))
-
- ELSE
-
- DO ji=1,td_file%i_nvar
- CALL iom_rstdimg_fill_var(td_file, ji, id_start, id_count)
- ENDDO
-
- ENDIF
- END SUBROUTINE iom_rstdimg__fill_var_all
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill variable value in an opened
- !> dimg file, given variable id.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] id_varid : variable id
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_rstdimg__fill_var_id(td_file, id_varid, id_start, id_count)
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- INTEGER(i4), INTENT(IN) :: id_varid
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
-
- ! local variable
- INTEGER(i4), DIMENSION(1) :: il_ind
- TYPE(TVAR) :: tl_var
- !----------------------------------------------------------------
- ! check if file opened
- IF( td_file%i_id == 0 )THEN
-
- CALL logger_error( &
- & " FILL VAR: no id associated to file "//TRIM(td_file%c_name))
-
- ELSE
-
- ! look for variable id
- il_ind(:) = MINLOC( td_file%t_var(:)%i_id, &
- & mask=(td_file%t_var(:)%i_id==id_varid))
- IF( il_ind(1) /= 0 )THEN
-
- IF( tl_var%i_ndim /= 0 )THEN
- !!! read variable value
- CALL iom_rstdimg__read_var_value(td_file, td_file%t_var(il_ind(1)), &
- & id_start, id_count)
-
- ELSE
- CALL logger_debug( " FILL VAR: variable 0d "//&
- & TRIM(td_file%t_var(il_ind(1))%c_name)//&
- & " should be already read ")
- ENDIF
-
- ELSE
- CALL logger_error( &
- & " FILL VAR: there is no variable with id "//&
- & TRIM(fct_str(id_varid))//" in file "//TRIM(td_file%c_name))
- ENDIF
-
- ENDIF
- END SUBROUTINE iom_rstdimg__fill_var_id
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine fill variable value in an opened
- !> dimg file, given variable name or standard name.
- !> start indices and number of indices selected along each dimension
- !> could be specify in a 4 dimension table (/'x','y','z','t'/)
- !
- !> @details
- !> look first for variable name. If it doesn't
- !> exist in file, look for variable standard name.
- !> If variable name is not present, check variable standard name.
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_file : file structure
- !> @param[in] cd_name : variable name or standard name
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @return variable structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE iom_rstdimg__fill_var_name(td_file, cd_name, id_start, id_count )
- IMPLICIT NONE
- ! Argument
- TYPE(TFILE), INTENT(INOUT) :: td_file
- CHARACTER(LEN=*), INTENT(IN) :: cd_name
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
- !CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
-
- ! local variable
- INTEGER(i4) :: il_ind
- !----------------------------------------------------------------
- ! check if file opened
- IF( td_file%i_id == 0 )THEN
-
- CALL logger_error( &
- & " FILL VAR: no id associated to file "//TRIM(td_file%c_name))
-
- ELSE
-
- il_ind=var_get_id(td_file%t_var, cd_name)
- IF( il_ind /= 0 )THEN
-
- IF( td_file%t_var(il_ind)%i_ndim /= 0 )THEN
- !!! read variable value
- CALL iom_rstdimg__read_var_value( td_file, td_file%t_var(il_ind), &
- & id_start, id_count)
-
- ELSE
- CALL logger_debug( " FILL VAR: variable 0d "//&
- & TRIM(td_file%t_var(il_ind)%c_name)//&
- & " should have been already read ")
- ENDIF
-
- ELSE
-
- CALL logger_error( &
- & " FILL VAR: there is no variable with "//&
- & " name or standard name "//TRIM(cd_name)//&
- & " in file "//TRIM(td_file%c_name))
-
- ENDIF
-
- ENDIF
-
- END SUBROUTINE iom_rstdimg__fill_var_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine read variable value in an opened dimg file, for
!> variable 1,2,3d.
- !
+ !> @details
+ !> Optionaly,start indices and number of indices selected along each dimension
+ !> could be specify in a 4 dimension array (/'x','y','z','t'/)
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[inout] td_var : variable structure
- !> @param[in] id_start : index in the variable from which the data values will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @return variable structure completed
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file structure
+ !> @param[inout] td_var variable structure
+ !> @param[in] id_start index in the variable from which the data values will be read
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg__read_var_value(td_file, td_var, &
& id_start, id_count )
@@ -1248,6 +1052,4 @@
INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
- !INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
! local variable
@@ -1273,5 +1075,5 @@
IF( SIZE(id_start(:)) /= ip_maxdim .OR. &
& SIZE(id_count(:)) /= ip_maxdim )THEN
- CALL logger_error("READ VAR: dimension of table start or count "//&
+ CALL logger_error("READ VAR: dimension of array start or count "//&
& " are invalid to read variable "//TRIM(td_var%c_name)//&
& " in file "//TRIM(td_file%c_name) )
@@ -1328,5 +1130,5 @@
& " READ VAR VALUE: not enough space to put variable "//&
& TRIM(td_var%c_name)//&
- & " in temporary table")
+ & " in temporary array")
ENDIF
@@ -1358,5 +1160,5 @@
ENDIF
ELSEIF( td_var%t_dim(3)%l_use )THEN
- ! 1d variable (Z)
+ ! 1D variable (Z)
READ(td_file%i_id, IOSTAT=il_status, REC=td_var%i_rec ) &
& dl_value(:,:,:,:)
@@ -1403,16 +1205,17 @@
END SUBROUTINE iom_rstdimg__read_var_value
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine write file structure in an opened dimg file.
+ !-------------------------------------------------------------------
+ !> @brief This subroutine write dimg file from file structure.
!
!> @details
- !
+ !> dimg file have to be already opened in write mode.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !> @date September, 2014
+ !> - use iom_rstdimg__get_rec
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg_write_file(td_file)
IMPLICIT NONE
@@ -1421,6 +1224,6 @@
! local variable
- INTEGER(i4) :: il_status
- INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_status
+ INTEGER(i4) :: il_ind
!----------------------------------------------------------------
! check if file opened
@@ -1433,17 +1236,36 @@
IF( td_file%l_wrt )THEN
+ ! check dimension
+ IF( td_file%t_dim(jp_L)%l_use .AND. &
+ & td_file%t_dim(jp_L)%i_len /= 1 )THEN
+ CALL logger_fatal("WRITE FILE: can not write dimg file with "//&
+ & " several time step.")
+ ENDIF
+
! close and open file with right record length
CALL iom_rstdimg_close(td_file)
+ ! compute record number to be used
+ ! and add variable no0d, no1d,.. if need be
+ CALL iom_rstdimg__get_rec(td_file)
+
! compute record length
- il_attid=att_get_id(td_file%t_att(:),"DOMAIN_number_total")
- IF( il_attid /= 0 )THEN
+ il_ind=att_get_index(td_file%t_att(:),"DOMAIN_number_total")
+ IF( il_ind /= 0 )THEN
td_file%i_recl = MAX( &
& td_file%t_dim(1)%i_len * td_file%t_dim(2)%i_len * 8, &
- & ( 8 * INT(td_file%t_att(il_attid)%d_value(1)) + 15 ) * 4 )
+ & ( 8 * INT(td_file%t_att(il_ind)%d_value(1)) + 15 ) * 4 )
ELSE
td_file%i_recl = td_file%t_dim(1)%i_len * &
& td_file%t_dim(2)%i_len * 8
ENDIF
+ ! check record length
+ IF( td_file%i_nvar*(im_vnl+dp) > td_file%i_recl )THEN
+ CALL logger_fatal("WRITE FILE: record length is too small. "//&
+ & " Try to reduce the output number of processor.")
+ ENDIF
+
+ ! get free unit
+ td_file%i_id=fct_getunit()
OPEN( td_file%i_id, FILE=TRIM(td_file%c_name),&
@@ -1456,8 +1278,8 @@
CALL fct_err(il_status)
IF( il_status /= 0 )THEN
- CALL logger_error("REPLACE: file "//TRIM(td_file%c_name)//&
+ CALL logger_error("WRITE FILE: REPLACE file "//TRIM(td_file%c_name)//&
& " with record length "//TRIM(fct_str(td_file%i_recl)))
ELSE
- CALL logger_debug("REPLACE: file "//TRIM(td_file%c_name)//&
+ CALL logger_debug("WRITE FILE: REPLACE file "//TRIM(td_file%c_name)//&
& " with record length "//TRIM(fct_str(td_file%i_recl)))
ENDIF
@@ -1479,5 +1301,111 @@
END SUBROUTINE iom_rstdimg_write_file
- !> @endcode
+ !-------------------------------------------------------------------
+ !> @brief This subroutine compute record number to be used.
+ !>
+ !> @details
+ !> Moreover it adds variable no0d, no1d, no2d and no3d if need be.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
+ SUBROUTINE iom_rstdimg__get_rec(td_file)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TFILE), INTENT(INOUT) :: td_file
+
+ ! local variable
+ INTEGER(i4) :: il_rec
+ TYPE(TVAR) :: tl_var
+
+ INTEGER(i4), DIMENSION(:) , ALLOCATABLE :: il_tmp1d
+ INTEGER(i4), DIMENSION(:,:) , ALLOCATABLE :: il_tmp2d
+ INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_tmp3d
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ ! add dummy variable if necessary
+ IF( td_file%i_n0d == 0 )THEN
+ ! create var
+ tl_var=var_init('no0d')
+
+ CALL file_add_var( td_file, tl_var )
+ ENDIF
+
+ IF( td_file%i_n1d == 0 )THEN
+ ! create var
+ ALLOCATE( il_tmp1d( td_file%t_dim(3)%i_len ) )
+ il_tmp1d(:)=-1
+
+ tl_var=var_init( 'no1d', il_tmp1d(:))
+
+ DEALLOCATE( il_tmp1d )
+
+ CALL file_add_var( td_file, tl_var )
+ ENDIF
+
+ IF( td_file%i_n2d == 0 )THEN
+ ! create var
+ ALLOCATE( il_tmp2d( td_file%t_dim(1)%i_len, &
+ & td_file%t_dim(2)%i_len ) )
+ il_tmp2d(:,:)=-1
+
+ tl_var=var_init('no2d', il_tmp2d(:,:) )
+
+ DEALLOCATE( il_tmp2d )
+
+ CALL file_add_var( td_file, tl_var )
+
+ ENDIF
+
+ IF( td_file%i_n3d == 0 )THEN
+ ! create var
+ ALLOCATE( il_tmp3d( td_file%t_dim(1)%i_len, &
+ & td_file%t_dim(2)%i_len, &
+ & td_file%t_dim(3)%i_len ) )
+ il_tmp3d(:,:,:)=-1
+
+ tl_var=var_init('no3d', il_tmp3d(:,:,:) )
+
+ DEALLOCATE( il_tmp3d )
+
+ CALL file_add_var( td_file, tl_var )
+ ENDIF
+
+ ! clean
+ CALL var_clean(tl_var)
+
+ il_rec=2
+ DO ji=1,td_file%i_nvar
+ SELECT CASE(td_file%t_var(ji)%i_ndim)
+ CASE(0)
+ IF( INDEX(td_file%t_var(ji)%c_name, 'no0d' ) == 0 )THEN
+ td_file%t_var(ji)%i_rec=il_rec
+ il_rec = il_rec + 0
+ ENDIF
+ CASE(1)
+ IF( INDEX(td_file%t_var(ji)%c_name, 'no1d' ) == 0 )THEN
+ td_file%t_var(ji)%i_rec=il_rec
+ il_rec = il_rec + 1
+ ENDIF
+ CASE(2)
+ IF( INDEX(td_file%t_var(ji)%c_name, 'no2d' ) == 0 )THEN
+ td_file%t_var(ji)%i_rec=il_rec
+ il_rec = il_rec + 1
+ ENDIF
+ CASE(3)
+ IF( INDEX(td_file%t_var(ji)%c_name, 'no3d' ) == 0 )THEN
+ td_file%t_var(ji)%i_rec=il_rec
+ il_rec = il_rec + td_file%t_dim(3)%i_len
+ ENDIF
+ END SELECT
+ ENDDO
+ td_file%i_rhd = il_rec
+
+ END SUBROUTINE iom_rstdimg__get_rec
!-------------------------------------------------------------------
!> @brief This subroutine write header in an opened dimg
@@ -1485,11 +1413,8 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file structure
- !> @param[in] td_dim : dimension structure
- !> @return dimension id
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_file file structure
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg__write_header(td_file)
IMPLICIT NONE
@@ -1499,5 +1424,5 @@
! local variable
INTEGER(i4) :: il_status
- INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_ind
INTEGER(i4) :: il_nproc
INTEGER(i4) :: il_niproc
@@ -1537,20 +1462,20 @@
! get domain decomposition
- il_attid=att_get_id( td_file%t_att, "DOMAIN_number_total" )
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_number_total" )
il_nproc = 1
- IF( il_attid /= 0 )THEN
- il_nproc = INT(td_file%t_att(il_attid)%d_value(1))
- ENDIF
-
- il_attid=att_get_id( td_file%t_att, "DOMAIN_I_number_total" )
+ IF( il_ind /= 0 )THEN
+ il_nproc = INT(td_file%t_att(il_ind)%d_value(1))
+ ENDIF
+
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_I_number_total" )
il_niproc = 0
- IF( il_attid /= 0 )THEN
- il_niproc = INT(td_file%t_att(il_attid)%d_value(1))
- ENDIF
-
- il_attid=att_get_id( td_file%t_att, "DOMAIN_J_number_total" )
+ IF( il_ind /= 0 )THEN
+ il_niproc = INT(td_file%t_att(il_ind)%d_value(1))
+ ENDIF
+
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_J_number_total" )
il_njproc = 0
- IF( il_attid /= 0 )THEN
- il_njproc = INT(td_file%t_att(il_attid)%d_value(1))
+ IF( il_ind /= 0 )THEN
+ il_njproc = INT(td_file%t_att(il_ind)%d_value(1))
ENDIF
@@ -1570,17 +1495,17 @@
! get domain number
- il_attid=att_get_id( td_file%t_att, "DOMAIN_number" )
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_number" )
il_area = 0
- IF( il_attid /= 0 )THEN
- il_area = INT(td_file%t_att(il_attid)%d_value(1))
+ IF( il_ind /= 0 )THEN
+ il_area = INT(td_file%t_att(il_ind)%d_value(1))
ENDIF
! get domain global size
- il_attid=att_get_id( td_file%t_att, "DOMAIN_size_global" )
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_size_global" )
il_iglo = 0
il_jglo = 0
- IF( il_attid /= 0 )THEN
- il_iglo = INT(td_file%t_att(il_attid)%d_value(1))
- il_jglo = INT(td_file%t_att(il_attid)%d_value(2))
+ IF( il_ind /= 0 )THEN
+ il_iglo = INT(td_file%t_att(il_ind)%d_value(1))
+ il_jglo = INT(td_file%t_att(il_ind)%d_value(2))
ENDIF
@@ -1600,19 +1525,19 @@
! allocate local variable
ALLOCATE( il_impp(il_nproc), il_jmpp(il_nproc),&
- & il_lci(il_niproc), il_lcj(il_njproc), &
- & il_ldi(il_niproc), il_ldj(il_njproc), &
- & il_lei(il_niproc), il_lej(il_njproc) )
+ & il_lci(il_nproc), il_lcj(il_nproc), &
+ & il_ldi(il_nproc), il_ldj(il_nproc), &
+ & il_lei(il_nproc), il_lej(il_nproc) )
! get domain first poistion
- il_attid=att_get_id( td_file%t_att, "DOMAIN_I_position_first" )
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_I_position_first" )
il_impp(:) = 0
- IF( il_attid /= 0 )THEN
- il_impp(:) = INT(td_file%t_att(il_attid)%d_value(:))
- ENDIF
-
- il_attid=att_get_id( td_file%t_att, "DOMAIN_J_position_first" )
+ IF( il_ind /= 0 )THEN
+ il_impp(:) = INT(td_file%t_att(il_ind)%d_value(:))
+ ENDIF
+
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_J_position_first" )
il_jmpp(:) = 0
- IF( il_attid /= 0 )THEN
- il_jmpp(:) = INT(td_file%t_att(il_attid)%d_value(:))
+ IF( il_ind /= 0 )THEN
+ il_jmpp(:) = INT(td_file%t_att(il_ind)%d_value(:))
ENDIF
@@ -1623,14 +1548,14 @@
! get domain last poistion
- il_attid=att_get_id( td_file%t_att, "DOMAIN_I_position_last" )
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_I_position_last" )
il_lci(:) = 0
- IF( il_attid /= 0 )THEN
- il_lci(:) = INT(td_file%t_att(il_attid)%d_value(:))
- ENDIF
-
- il_attid=att_get_id( td_file%t_att, "DOMAIN_J_position_last" )
+ IF( il_ind /= 0 )THEN
+ il_lci(:) = INT(td_file%t_att(il_ind)%d_value(:))
+ ENDIF
+
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_J_position_last" )
il_lcj(:) = 0
- IF( il_attid /= 0 )THEN
- il_lcj(:) = INT(td_file%t_att(il_attid)%d_value(:))
+ IF( il_ind /= 0 )THEN
+ il_lcj(:) = INT(td_file%t_att(il_ind)%d_value(:))
ENDIF
@@ -1641,14 +1566,14 @@
! get halo size start
- il_attid=att_get_id( td_file%t_att, "DOMAIN_I_halo_size_start" )
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_I_halo_size_start" )
il_ldi(:) = 0
- IF( il_attid /= 0 )THEN
- il_ldi(:) = INT(td_file%t_att(il_attid)%d_value(:))
- ENDIF
-
- il_attid=att_get_id( td_file%t_att, "DOMAIN_J_halo_size_start" )
+ IF( il_ind /= 0 )THEN
+ il_ldi(:) = INT(td_file%t_att(il_ind)%d_value(:))
+ ENDIF
+
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_J_halo_size_start" )
il_ldj(:) = 0
- IF( il_attid /= 0 )THEN
- il_ldj(:) = INT(td_file%t_att(il_attid)%d_value(:))
+ IF( il_ind /= 0 )THEN
+ il_ldj(:) = INT(td_file%t_att(il_ind)%d_value(:))
ENDIF
@@ -1659,14 +1584,14 @@
! get halo size end
- il_attid=att_get_id( td_file%t_att, "DOMAIN_I_halo_size_end" )
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_I_halo_size_end" )
il_lei(:) = 0
- IF( il_attid /= 0 )THEN
- il_lei(:) = INT(td_file%t_att(il_attid)%d_value(:))
- ENDIF
-
- il_attid=att_get_id( td_file%t_att, "DOMAIN_J_halo_size_end" )
+ IF( il_ind /= 0 )THEN
+ il_lei(:) = INT(td_file%t_att(il_ind)%d_value(:))
+ ENDIF
+
+ il_ind=att_get_index( td_file%t_att, "DOMAIN_J_halo_size_end" )
il_lej(:) = 0
- IF( il_attid /= 0 )THEN
- il_lej(:) = INT(td_file%t_att(il_attid)%d_value(:))
+ IF( il_ind /= 0 )THEN
+ il_lej(:) = INT(td_file%t_att(il_ind)%d_value(:))
ENDIF
@@ -1690,8 +1615,8 @@
& il_area, &
& il_iglo, il_jglo, &
- & il_impp(:), il_jmpp(:), &
& il_lci(:), il_lcj(:), &
& il_ldi(:), il_ldj(:), &
- & il_lei(:), il_lej(:)
+ & il_lei(:), il_lej(:), &
+ & il_impp(:), il_jmpp(:)
DEALLOCATE( il_impp, il_jmpp,&
@@ -1701,14 +1626,12 @@
END SUBROUTINE iom_rstdimg__write_header
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine write variables in an opened dimg file.
- !
+ !-------------------------------------------------------------------
+ !> @brief This subroutine write variables in an opened dimg file.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] id_fileid : file id
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] id_fileid file id
+ !-------------------------------------------------------------------
SUBROUTINE iom_rstdimg__write_var(td_file)
IMPLICIT NONE
@@ -1718,91 +1641,52 @@
! local variable
INTEGER(i4) :: il_status
- TYPE(TVAR) :: tl_var
+ INTEGER(i4) :: il_rec
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_start
INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_count
- CHARACTER(LEN=ip_vnl), DIMENSION(:), ALLOCATABLE :: cl_name
+ CHARACTER(LEN=im_vnl), DIMENSION(:), ALLOCATABLE :: cl_name
REAL(dp), DIMENSION(:), ALLOCATABLE :: dl_value
-
- INTEGER(i4), DIMENSION(:,:,:,:), ALLOCATABLE :: il_tmp
! loop indices
INTEGER(i4) :: ji
+ INTEGER(i4) :: jk
!----------------------------------------------------------------
-
- ! add dummy variable if necessary
- IF( td_file%i_n0d == 0 )THEN
- ! create var
- tl_var=var_init('no0d')
- ! add value
- ALLOCATE( il_tmp(1,1,1,1) )
- il_tmp(:,:,:,:)=-1
- CALL var_add_value(tl_var, il_tmp)
- DEALLOCATE( il_tmp )
-
- CALL file_add_var( td_file, tl_var )
- ENDIF
-
- IF( td_file%i_n1d == 0 )THEN
- ! create var
- tl_var=var_init('no1d')
- ! add dimension
- CALL var_add_dim(tl_var, td_file%t_dim(3))
- ! add value
- ALLOCATE( il_tmp(1,1,td_file%t_dim(3)%i_len, 1) )
- il_tmp(:,:,:,:)=-1
- CALL var_add_value(tl_var, il_tmp)
- DEALLOCATE( il_tmp )
-
- CALL file_add_var( td_file, tl_var )
- ENDIF
-
- IF( td_file%i_n2d == 0 )THEN
- ! create var
- tl_var=var_init('no2d' )
- ! add dimension
- CALL var_add_dim(tl_var, td_file%t_dim(1))
- CALL var_add_dim(tl_var, td_file%t_dim(2))
- ! add value
- ALLOCATE( il_tmp( td_file%t_dim(1)%i_len, &
- & td_file%t_dim(2)%i_len, &
- & 1, &
- & 1 ) )
- il_tmp(:,:,:,:)=-1
- CALL var_add_value(tl_var, il_tmp)
- DEALLOCATE( il_tmp )
-
- CALL file_add_var( td_file, tl_var )
- ENDIF
-
- IF( td_file%i_n3d == 0 )THEN
- ! create var
- tl_var=var_init('no3d' )
- ! add dimension
- CALL var_add_dim(tl_var, td_file%t_dim(1))
- CALL var_add_dim(tl_var, td_file%t_dim(2))
- CALL var_add_dim(tl_var, td_file%t_dim(3))
- ! add value
- ALLOCATE( il_tmp( td_file%t_dim(1)%i_len, &
- & td_file%t_dim(2)%i_len, &
- & td_file%t_dim(3)%i_len, &
- & 1 ) )
- il_tmp(:,:,:,:)=-1
- CALL var_add_value(tl_var, il_tmp)
- DEALLOCATE( il_tmp )
-
- CALL file_add_var( td_file, tl_var )
- ENDIF
! reform name and record
ALLOCATE( cl_name(td_file%i_nvar), dl_value(td_file%i_nvar) )
+
DO ji=1,td_file%i_nvar
+
+ ! change FillValue to 0.
+ CALL var_chg_FillValue(td_file%t_var(ji),0._dp)
+
cl_name(ji) = TRIM(td_file%t_var(ji)%c_name)
dl_value(ji) = REAL(td_file%t_var(ji)%i_rec,dp)
- ENDDO
-
- ! special case for 0d
- DO ji=1,td_file%i_n0d
- dl_value(ji)=td_file%t_var(ji)%d_value(1,1,1,1)
+
+ SELECT CASE (TRIM(td_file%t_var(ji)%c_name))
+ CASE('no0d','no1d','no2d','no3d')
+ CASE DEFAULT
+ DO jk=1,td_file%t_var(ji)%t_dim(3)%i_len
+ SELECT CASE (td_file%t_var(ji)%i_ndim)
+ CASE(0)
+ ! special case for 0d, value save in rec
+ dl_value(ji)=td_file%t_var(ji)%d_value(1,1,1,1)
+ il_rec = td_file%t_var(ji)%i_rec
+ CASE(1,2)
+ il_rec = td_file%t_var(ji)%i_rec
+ CASE(3)
+ il_rec = td_file%t_var(ji)%i_rec + jk -1
+ END SELECT
+ WRITE( td_file%i_id, IOSTAT=il_status, REC=il_rec ) &
+ & td_file%t_var(ji)%d_value(:,:,jk,1)
+ CALL fct_err(il_status)
+ IF( il_status /= 0 )THEN
+ CALL logger_error("IOM RSTDIMG WRITE VAR: can not "//&
+ & "write variable "//TRIM(td_file%t_var(ji)%c_name)//&
+ & " in record "//TRIM(fct_str(il_rec)))
+ ENDIF
+ ENDDO
+ END SELECT
+
ENDDO
@@ -1820,5 +1704,4 @@
il_start(4) = 1 + il_count(3)
il_count(4) = il_start(4) - 1 + td_file%i_n3d
-
WRITE(td_file%i_id, IOSTAT=il_status, REC=td_file%i_rhd )&
@@ -1827,8 +1710,14 @@
& cl_name(il_start(3):il_count(3)), dl_value(il_start(3):il_count(3)),&
& cl_name(il_start(4):il_count(4)), dl_value(il_start(4):il_count(4))
-
+ CALL fct_err(il_status)
+ IF( il_status /= 0 )THEN
+ CALL logger_error("IOM RSTDIMG WRITE VAR: can not "//&
+ & "write restart header in record "//TRIM(fct_str(td_file%i_rhd)))
+ ENDIF
+
+ ! clean
+ DEALLOCATE( cl_name, dl_value )
DEALLOCATE( il_start, il_count )
END SUBROUTINE iom_rstdimg__write_var
- !> @endcode
END MODULE iom_rstdimg
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/kind.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/kind.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/kind.f90 (revision 5214)
@@ -16,12 +16,11 @@
!> - add a standard length of character strings
!
-!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!
!> @todo
!> - check i8 max value
+!
+!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
!----------------------------------------------------------------------
MODULE kind
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/logger.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/logger.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/logger.f90 (revision 5214)
@@ -6,6 +6,7 @@
!
! DESCRIPTION:
-!> @brief This module create logger file and inform it depending
-!> of verbosity choose between :
+!> @brief This module create logger file and allow to fill it depending of verbosity.
+!> @details
+!> verbosity could be choosen between :
!> - trace : Most detailed information.
!> - debug : Detailed information on the flow through the system.
@@ -18,82 +19,108 @@
!> default verbosity is warning
!
-!> @details
-!> If total number of error exceeded maximum number
-!> authorized, program stop.
-!>
-!> to open/create logger file:
+!> If total number of error exceeded maximum number
+!> authorized, program stop.
+!>
+!> to open/create logger file:
+!> @code
!> CALL logger_open(cd_file, [cd_verbosity,] [id_loggerid,] [id_maxerror])
-!> - cd_file is logger file name
-!> - cd_verbosity is verbosity to be used (optional, default 'warning')
-!> - id_loggerid is file id (optional, use only to flush)
-!> - id_maxerror is the mximum number of error authorized before stop program (optional, default 5)
-!>
-!> to close logger file:
-!> CALL logger_close()
-!>
-!> to write header in logger file:
-!> CALL logger_header()
-!>
-!> to write footer in logger file:
-!> CALL logger_footer()
-!>
-!> to flushing output:
-!> CALL logger_flush()
-!>
-!> to write TRACE message in logger file:
-!> CALL logger_trace(cd_msg)
-!> - cd_msg is TRACE message
-!>
-!> to write DEBUG message in logger file:
-!> CALL logger_debug(cd_msg)
-!> - cd_msg is DEBUG message
-!>
-!> to write INFO message in logger file:
-!> CALL logger_info(cd_msg)
-!> - cd_msg is INFO message
-!>
-!> to write WARNING message in logger file:
-!> CALL logger_warn(cd_msg)
-!> - cd_msg is WARNING message
-!>
-!> to write ERROR message in logger file:
-!> CALL logger_error(cd_msg)
-!> - cd_msg is ERROR message
-!>
-!> to write FATAL message in logger file:
-!> CALL logger_fatal(cd_msg)
-!> - cd_msg is FATAL message
-!>
-!> Examples :
+!> @endcode
+!> - cd_file is logger file name
+!> - cd_verbosity is verbosity to be used [optional, default 'warning']
+!> - id_loggerid is file id [optional, use only to flush]
+!> - id_maxerror is the maximum number of error authorized before program stop [optional, default 5]
+!>
+!> to close logger file:
+!> @code
+!> CALL logger_close()
+!> @endcode
+!>
+!> to write header in logger file:
+!> @code
+!> CALL logger_header()
+!> @endcode
+!>
+!> to write footer in logger file:
+!> @code
+!> CALL logger_footer()
+!> @endcode
+!>
+!> to flushing output:
+!> @code
+!> CALL logger_flush()
+!> @endcode
+!>
+!> to write TRACE message in logger file:
+!> @code
+!> CALL logger_trace(cd_msg [,ld_flush])
+!> @endcode
+!> - cd_msg is TRACE message
+!> - ld_flush to flush output [optional]
+!>
+!> to write DEBUG message in logger file:
+!> @code
+!> CALL logger_debug(cd_msg [,ld_flush])
+!> @endcode
+!> - cd_msg is DEBUG message
+!> - ld_flush to flush output [optional]
+!>
+!> to write INFO message in logger file:
+!> @code
+!> CALL logger_info(cd_msg [,ld_flush])
+!> @endcode
+!> - cd_msg is INFO message
+!> - ld_flush to flush output [optional]
+!>
+!> to write WARNING message in logger file:
+!> @code
+!> CALL logger_warn(cd_msg [,ld_flush])
+!> @endcode
+!> - cd_msg is WARNING message
+!> - ld_flush to flush output [optional]
+!>
+!> to write ERROR message in logger file:
+!> @code
+!> CALL logger_error(cd_msg [,ld_flush])
+!> @endcode
+!> - cd_msg is ERROR message
+!> - ld_flush to flush output [optional]
+!>
+!> to write FATAL message in logger file:
+!> @code
+!> CALL logger_fatal(cd_msg)
+!> @endcode
+!> - cd_msg is FATAL message
+!>
+!> Examples :
+!> @code
!> CALL logger_open('loggerfile.txt','info')
!>
-!> CALL logger_header()
-!> CALL logger_info('une petite info')
-!> CALL logger_debug('une info de debug')
-!> CALL logger_warn('une info de warning')
-!> CALL logger_error('une info d erreur')
-!> CALL logger_footer()
-!> CALL logger_close()
-!>
-!> !--------------------------------------------------------------------
+!> CALL logger_header()
+!> CALL logger_debug('une info de debug')
+!> CALL logger_info('une info')
+!> CALL logger_warn('un warning')
+!> CALL logger_error('une erreur')
+!> CALL logger_footer()
+!> CALL logger_close()
+!> @endcode
+!>
+!> @code
!> CALL logger_open('loggerfile.txt')
!>
-!> CALL logger_header()
-!> CALL logger_info('une petite info')
-!> CALL logger_debug('une info de debug')
-!> CALL logger_warn('une info de warning')
-!> CALL logger_error('une info d erreur')
-!> CALL logger_footer()
-!> CALL logger_close()
+!> CALL logger_header()
+!> CALL logger_debug('une info de debug')
+!> CALL logger_info('une info')
+!> CALL logger_warn('un warning')
+!> CALL logger_error('une erreur')
+!> CALL logger_footer()
+!> CALL logger_close()
+!> @endcode
!
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013- Initial Version
+!> @date November, 2013- Initial Version
!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!>
-!> @todo
-!> - verifier flush remet pas compteur error à zero
!----------------------------------------------------------------------
MODULE logger
@@ -101,31 +128,33 @@
USE fct ! basic useful function
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! type and variable
- !PUBLIC :: TLOGGER ! logger structure
+ PRIVATE :: TLOGGER !< logger structure
+
+ PRIVATE :: tm_logger !< logger structure
+ PRIVATE :: im_nverbosity !< number of log level
+ PRIVATE :: cm_verbosity !< verbosity array
! function and subroutine
- PUBLIC :: logger_open ! create a log file with given verbosity
- PUBLIC :: logger_close ! close log file
- PUBLIC :: logger_flush ! flushing output
- PUBLIC :: logger_header ! write header on log file
- PUBLIC :: logger_footer ! write footer on log file
- PUBLIC :: logger_trace ! write trace message in log file
- PUBLIC :: logger_debug ! write debug message in log file
- PUBLIC :: logger_info ! write info message in log file
- PUBLIC :: logger_warn ! write warning message in log file
- PUBLIC :: logger_error ! write error message in log file
- PUBLIC :: logger_fatal ! write fatal message in log file, and stop
+ PUBLIC :: logger_open !< create a log file with given verbosity
+ PUBLIC :: logger_close !< close log file
+ PUBLIC :: logger_header !< write header on log file
+ PUBLIC :: logger_footer !< write footer on log file
+ PUBLIC :: logger_flush !< flushing output
+ PUBLIC :: logger_trace !< write trace message in log file
+ PUBLIC :: logger_debug !< write debug message in log file
+ PUBLIC :: logger_info !< write info message in log file
+ PUBLIC :: logger_warn !< write warning message in log file
+ PUBLIC :: logger_error !< write error message in log file
+ PUBLIC :: logger_fatal !< write fatal message in log file, and stop
PRIVATE :: logger__write ! cut message to get maximum of 80 character by line in log file
- !> @struct TLOG
- TYPE TLOGGER
+ TYPE TLOGGER !< logger structure
INTEGER(i4) :: i_id = 0 !< log file id
CHARACTER(LEN=lc) :: c_name !< log file name
CHARACTER(LEN=lc) :: c_verbosity = "warning" !< verbosity choose
- CHARACTER(LEN=lc) :: c_verb = "" !< table of "verbosities" to used
+ CHARACTER(LEN=lc) :: c_verb = "" !< array of "verbosities" to used
INTEGER(i4) :: i_nerror = 0 !< number of error
INTEGER(i4) :: i_nfatal = 0 !< number of fatal error
@@ -135,5 +164,5 @@
! module variable
INTEGER(i4), PARAMETER :: im_nverbosity=6 !< number of log level
- CHARACTER(len=*), DIMENSION(im_nverbosity), PARAMETER :: cm_verbosity= & !< verbosity table
+ CHARACTER(len=*), DIMENSION(im_nverbosity), PARAMETER :: cm_verbosity= & !< verbosity array
& (/ 'trace ',&
& 'debug ',&
@@ -147,15 +176,19 @@
CONTAINS
!-------------------------------------------------------------------
- !> @brief This subroutine create a log file with given verbosity.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_file : log file name
- !> @param[in] cd_verbosity : log file verbosity
- !> @param[in] id_logid : log file id (use to flush)
- !> @param[in] id_maxerror : maximum number of error
- !-------------------------------------------------------------------
- ! @code
+ !> @brief This subroutine create a log file with default verbosity
+ !> ('warning').
+ !> @details
+ !> Optionally verbosity could be change to
+ !> ('trace','debug','info',warning','error','fatal').
+ !> Optionally maximum number of error allowed could be change.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_file log file name
+ !> @param[in] cd_verbosity log file verbosity
+ !> @param[in] id_logid log file id (use to flush)
+ !> @param[in] id_maxerror maximum number of error
+ !-------------------------------------------------------------------
SUBROUTINE logger_open(cd_file, cd_verbosity, id_logid, id_maxerror)
IMPLICIT NONE
@@ -212,13 +245,10 @@
END SUBROUTINE logger_open
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine close a log file.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !-------------------------------------------------------------------
SUBROUTINE logger_close()
IMPLICIT NONE
@@ -227,4 +257,5 @@
!----------------------------------------------------------------
IF( tm_logger%i_id /= 0 )THEN
+ tm_logger%i_id = 0
CLOSE( tm_logger%i_id, &
& IOSTAT=il_status)
@@ -237,13 +268,10 @@
END SUBROUTINE logger_close
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine flushing output into log file.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !-------------------------------------------------------------------
SUBROUTINE logger_flush()
IMPLICIT NONE
@@ -260,25 +288,22 @@
END SUBROUTINE logger_flush
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write header on log file.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !-------------------------------------------------------------------
RECURSIVE SUBROUTINE logger_header()
IMPLICIT NONE
! local variable
- INTEGER(i4) :: il_status
+ INTEGER(i4) :: il_status
!----------------------------------------------------------------
IF( tm_logger%i_id /= 0 )THEN
WRITE( tm_logger%i_id, &
- & FMT='(a/a/a)', &
+ & FMT='(4(a/))', &
& IOSTAT=il_status ) &
- & "--------------------------------------------------", &
- & "INIT : log start with verbosity "//&
- & TRIM(tm_logger%c_verbosity), &
+ & "--------------------------------------------------",&
+ & "INIT : verbosity "//TRIM(tm_logger%c_verbosity),&
+ & "INIT : max error "//TRIM(fct_str(tm_logger%i_maxerror)), &
& "--------------------------------------------------"
CALL fct_err(il_status)
@@ -290,24 +315,21 @@
END SUBROUTINE logger_header
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write footer on log file.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !-------------------------------------------------------------------
SUBROUTINE logger_footer()
IMPLICIT NONE
! local variable
- INTEGER(i4) :: il_status
+ INTEGER(i4) :: il_status
!----------------------------------------------------------------
IF( tm_logger%i_id /= 0 )THEN
WRITE( tm_logger%i_id, &
- & FMT='(a/a/a/a/a)', &
+ & FMT='(4(/a))', &
& IOSTAT=il_status ) &
& "--------------------------------------------------",&
- & "END : log ended ", &
+ & "END : log ended ", &
& "END : "//TRIM(fct_str(tm_logger%i_nerror))// &
& " ERROR detected ", &
@@ -322,16 +344,15 @@
ENDIF
END SUBROUTINE logger_footer
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write trace message on log file.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_msg : message to write
- !> @param[in] ld_flush : flushing ouput
- !
- !-------------------------------------------------------------------
- ! @code
+ !> @details
+ !> Optionally you could flush output.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_msg message to write
+ !> @param[in] ld_flush flushing ouput
+ !-------------------------------------------------------------------
SUBROUTINE logger_trace(cd_msg, ld_flush)
IMPLICIT NONE
@@ -357,16 +378,15 @@
ENDIF
END SUBROUTINE logger_trace
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write debug message on log file.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_msg : message to write
- !> @param[in] ld_flush : flushing ouput
- !
- !-------------------------------------------------------------------
- ! @code
+ !> @details
+ !> Optionally you could flush output.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_msg message to write
+ !> @param[in] ld_flush flushing ouput
+ !-------------------------------------------------------------------
SUBROUTINE logger_debug(cd_msg, ld_flush)
IMPLICIT NONE
@@ -392,16 +412,15 @@
ENDIF
END SUBROUTINE logger_debug
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write info message on log file.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_msg : message to write
- !> @param[in] ld_flush : flushing ouput
- !
- !-------------------------------------------------------------------
- ! @code
+ !> @details
+ !> Optionally you could flush output.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_msg message to write
+ !> @param[in] ld_flush flushing ouput
+ !-------------------------------------------------------------------
SUBROUTINE logger_info(cd_msg, ld_flush)
IMPLICIT NONE
@@ -427,16 +446,15 @@
ENDIF
END SUBROUTINE logger_info
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write warning message on log file.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_msg : message to write
- !> @param[in] ld_flush : flushing ouput
- !
- !-------------------------------------------------------------------
- ! @code
+ !> @details
+ !> Optionally you could flush output.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_msg message to write
+ !> @param[in] ld_flush flushing ouput
+ !-------------------------------------------------------------------
SUBROUTINE logger_warn(cd_msg, ld_flush)
IMPLICIT NONE
@@ -462,16 +480,15 @@
ENDIF
END SUBROUTINE logger_warn
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write error message on log file.
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_msg : message to write
- !> @param[in] ld_flush : flushing ouput
- !
- !-------------------------------------------------------------------
- ! @code
+ !> @details
+ !> Optionally you could flush output.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_msg message to write
+ !> @param[in] ld_flush flushing ouput
+ !-------------------------------------------------------------------
SUBROUTINE logger_error(cd_msg, ld_flush)
IMPLICIT NONE
@@ -510,5 +527,4 @@
END SUBROUTINE logger_error
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine write fatal error message on log file,
@@ -516,10 +532,8 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_msg : message to write
- !
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_msg message to write
+ !-------------------------------------------------------------------
RECURSIVE SUBROUTINE logger_fatal(cd_msg)
IMPLICIT NONE
@@ -537,4 +551,5 @@
CALL logger_close()
+ WRITE(*,*) 'FATAL ERROR'
STOP
ENDIF
@@ -545,5 +560,4 @@
ENDIF
END SUBROUTINE logger_fatal
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine cut message to get maximum of 80 character
@@ -551,10 +565,9 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_verb : verbosity of the message to write
- !> @param[in] cd_msg : message to write
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_verb verbosity of the message to write
+ !> @param[in] cd_msg message to write
+ !-------------------------------------------------------------------
SUBROUTINE logger__write(cd_verb, cd_msg)
IMPLICIT NONE
@@ -602,5 +615,4 @@
END SUBROUTINE logger__write
- ! @endcode
END MODULE logger
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/merge_bathy.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/merge_bathy.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/merge_bathy.f90 (revision 5214)
@@ -7,25 +7,121 @@
!
! DESCRIPTION:
+!> @file
!> @brief
!> This program merge bathymetry file at boundaries.
!>
!> @details
+!> @section sec1 method
!> Coarse grid Bathymetry is interpolated on fine grid.
-!> Then fine Bathymetry and refined coarse bathymetry are merged at boundaries.
-!>
-!> BathyFine= weight * BathyCoarse + (1-weight)*BathyFine
-!>
-!> The weight function used is : 0.5 + 0.5*COS( (pi*dist) / width )
-!>
-!> @author
-!> J.Paul
+!> Then fine Bathymetry and refined coarse bathymetry are merged at boundaries.
+!> @f[BathyFine= Weight * BathyCoarse + (1-Weight)*BathyFine@f]
+!> The weight function used is :
+!> @f[Weight = 0.5 + 0.5*COS( \frac{\pi*dist}{width} )@f]
+!> with
+!> - dist : number of point to border
+!> - width : boundary size
+!>
+!> @section sec2 how to
+!> to merge bathymetry file:
+!> @code{.sh}
+!> ./SIREN/bin/merge_bathy merge_bathy.nam
+!> @endcode
+!>
+!> merge_bathy.nam comprise 8 namelists:
+!> - logger namelist (namlog)
+!> - config namelist (namcfg)
+!> - coarse grid namelist (namcrs)
+!> - fine grid namelist (namfin)
+!> - variable namelist (namvar)
+!> - nesting namelist (namnst)
+!> - boundary namelist (nambdy)
+!> - output namelist (namout)
+!>
+!> @note
+!> All namelists have to be in file merge_bathy.nam,
+!> however variables of those namelists are all optional.
+!>
+!> * _logger namelist (namlog)_:
+!> - cn_logfile : logger filename
+!> - cn_verbosity : verbosity ('trace','debug','info',
+!> 'warning','error','fatal')
+!> - in_maxerror : maximum number of error allowed
+!>
+!> * _config namelist (namcfg)_:
+!> - cn_varcfg : variable configuration file (see ./SIREN/cfg/variable.cfg)
+!>
+!> * _coarse grid namelist (namcrs)_:
+!> - cn_bathy0 : bathymetry file
+!> - in_perio0 : NEMO periodicity index (see Model Boundary Condition in
+!> [NEMO documentation](http://www.nemo-ocean.eu/About-NEMO/Reference-manuals))
+!>
+!> * _fine grid namelist (namfin)_:
+!> - cn_bathy1 : bathymetry file
+!> - in_perio1 : NEMO periodicity index
+!>
+!> * _variable namelist (namvar)_:
+!> - cn_varinfo : list of variable and extra information about request(s)
+!> to be used.
+!> each elements of *cn_varinfo* is a string character.
+!> it is composed of the variable name follow by ':',
+!> then request(s) to be used on this variable.
+!> request could be:
+!> - interpolation method
+!>
+!> requests must be separated by ';'.
+!> order of requests does not matter.
+!>
+!> informations about available method could be find in
+!> @ref interp modules.
+!> Example: 'bathymetry: cubic'
+!> @note
+!> If you do not specify a method which is required,
+!> default one is apply.
+!> @warning
+!> variable name must be __Bathymetry__ here.
+!>
+!> * _nesting namelist (namnst)_:
+!> - in_rhoi : refinement factor in i-direction
+!> - in_rhoj : refinement factor in j-direction
+!>
+!> * _boundary namelist (nambdy)_:
+!> - ln_north : use north boundary or not
+!> - ln_south : use south boundary or not
+!> - ln_east : use east boundary or not
+!> - ln_west : use west boundary or not
+!> - cn_north : north boundary indices on fine grid
+!> *cn_north* is a string character defining boundary
+!> segmentation.
+!> segments are separated by '|'.
+!> each segments of the boundary is composed of:
+!> - orthogonal indice (.ie. for north boundary,
+!> J-indice where boundary are).
+!> - first indice of boundary (I-indice for north boundary)
+!> - last indice of boundary (I-indice for north boundary)
+!> indices must be separated by ',' .
+!> - optionally, boundary size could be added between '(' and ')'
+!> in the first segment defined.
+!> @note
+!> boundary size is the same for all segments of one boundary.
+!>
+!> Examples:
+!> - cn_north='index1,first1,last1(width)'
+!> - cn_north='index1(width),first1,last1|index2,first2,last2'
+!> - cn_south : south boundary indices on fine grid
+!> - cn_east : east boundary indices on fine grid
+!> - cn_west : west boundary indices on fine grid
+!> - ln_oneseg: use only one segment for each boundary or not
+!>
+!> * _output namelist (namout)_:
+!> - cn_fileout : merged bathymetry file
+!>
+!> @author J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
+!> @date November, 2013 - Initial Version
+!> @date Sepember, 2014
+!> - add header for user
+!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!>
-!> @todo
!----------------------------------------------------------------------
-!> @code
PROGRAM merge_bathy
@@ -43,5 +139,4 @@
USE boundary ! boundary manager
USE iom ! I/O manager
- USE dom ! domain manager
USE grid ! grid manager
USE extrap ! extrapolation manager
@@ -49,5 +144,7 @@
USE filter ! filter manager
USE mpp ! MPP manager
+ USE dom ! domain manager
USE iom_mpp ! MPP I/O manager
+ USE iom_dom ! DOM I/O manager
IMPLICIT NONE
@@ -60,5 +157,5 @@
INTEGER(i4) :: il_status
INTEGER(i4) :: il_fileid
- INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_attind
INTEGER(i4) :: il_imin0
INTEGER(i4) :: il_imax0
@@ -66,7 +163,5 @@
INTEGER(i4) :: il_jmax0
INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho
- INTEGER(i4) , DIMENSION(2,2) :: il_offset
- INTEGER(i4) , DIMENSION(2,2,2) :: il_ind
-! INTEGER(i4) , DIMENSION(:,:,:,:), ALLOCATABLE :: il_value
+ INTEGER(i4) , DIMENSION(2,2) :: il_ind
LOGICAL :: ll_exist
@@ -76,6 +171,6 @@
REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_weight
- TYPE(TFILE) :: tl_bathy0
- TYPE(TFILE) :: tl_bathy1
+ TYPE(TMPP) :: tl_bathy0
+ TYPE(TMPP) :: tl_bathy1
TYPE(TFILE) :: tl_fileout
@@ -85,6 +180,4 @@
TYPE(TVAR) :: tl_lon
TYPE(TVAR) :: tl_lat
-! TYPE(TVAR) :: tl_depth
-! TYPE(TVAR) :: tl_time
TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
@@ -98,24 +191,28 @@
! namelist variable
+ ! namlog
CHARACTER(LEN=lc) :: cn_logfile = 'merge_bathy.log'
CHARACTER(LEN=lc) :: cn_verbosity = 'warning'
-
+ INTEGER(i4) :: in_maxerror = 5
+
+ ! namcfg
+ CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg'
+
+ ! namcrs
CHARACTER(LEN=lc) :: cn_bathy0 = ''
INTEGER(i4) :: in_perio0 = -1
+ ! namfin
CHARACTER(LEN=lc) :: cn_bathy1 = ''
INTEGER(i4) :: in_perio1 = -1
- CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg'
-
- CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varinfo = ''
-
- INTEGER(i4) :: in_imin0 = 0
- INTEGER(i4) :: in_imax0 = 0
- INTEGER(i4) :: in_jmin0 = 0
- INTEGER(i4) :: in_jmax0 = 0
+ ! namvar
+ CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''
+
+ ! namnst
INTEGER(i4) :: in_rhoi = 0
INTEGER(i4) :: in_rhoj = 0
+ ! nambdy
LOGICAL :: ln_north = .TRUE.
LOGICAL :: ln_south = .TRUE.
@@ -128,4 +225,5 @@
CHARACTER(LEN=lc) :: cn_west = ''
+ ! namout
CHARACTER(LEN=lc) :: cn_fileout = 'bathy_merged.nc'
!-------------------------------------------------------------------
@@ -152,8 +250,4 @@
NAMELIST /namnst/ & !< nesting namelist
- & in_imin0, & !< i-direction lower left point indice on coarse grid
- & in_imax0, & !< i-direction upper right point indice on coarse grid
- & in_jmin0, & !< j-direction lower left point indice on coarse grid
- & in_jmax0, & !< j-direction upper right point indice on coarse grid
& in_rhoi, & !< refinement factor in i-direction
& in_rhoj !< refinement factor in j-direction
@@ -171,9 +265,9 @@
NAMELIST /namout/ & !< output namelist
- & cn_fileout !< fine grid merged bathymetry file
+ & cn_fileout !< fine grid merged bathymetry file
!-------------------------------------------------------------------
- !1- namelist
- !1-1 get namelist
+ ! namelist
+ ! get namelist
il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
IF( il_narg/=1 )THEN
@@ -184,5 +278,5 @@
ENDIF
- !1-2 read namelist
+ ! read namelist
INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist)
IF( ll_exist )THEN
@@ -203,10 +297,10 @@
READ( il_fileid, NML = namlog )
- !1-2-1 define log file
- CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity))
+ ! define log file
+ CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity), in_maxerror)
CALL logger_header()
READ( il_fileid, NML = namcfg )
- !1-2-2 get variable extra information
+ ! get variable extra information
CALL var_def_extra(TRIM(cn_varcfg))
@@ -214,5 +308,5 @@
READ( il_fileid, NML = namfin )
READ( il_fileid, NML = namvar )
- !1-2-3 add user change in extra information
+ ! add user change in extra information
CALL var_chg_extra(cn_varinfo)
@@ -234,8 +328,8 @@
ENDIF
- !2- open files
+ ! open files
IF( TRIM(cn_bathy0) /= '' )THEN
- tl_bathy0=file_init(TRIM(cn_bathy0),id_perio=in_perio0)
- CALL iom_open(tl_bathy0)
+ tl_bathy0=mpp_init( file_init(TRIM(cn_bathy0)), id_perio=in_perio0)
+ CALL grid_get_info(tl_bathy0)
ELSE
CALL logger_fatal("MERGE BATHY: can not find coarse grid bathymetry "//&
@@ -244,6 +338,6 @@
IF( TRIM(cn_bathy1) /= '' )THEN
- tl_bathy1=file_init(TRIM(cn_bathy1),id_perio=in_perio1)
- CALL iom_open(tl_bathy1)
+ tl_bathy1=mpp_init( file_init(TRIM(cn_bathy1)), id_perio=in_perio1)
+ CALL grid_get_info(tl_bathy1)
ELSE
CALL logger_fatal("MERGE BATHY: can not find fine grid bathymetry "//&
@@ -251,6 +345,6 @@
ENDIF
- !3- check
- !3-1 check output file do not already exist
+ ! check
+ ! check output file do not already exist
INQUIRE(FILE=TRIM(cn_fileout), EXIST=ll_exist)
IF( ll_exist )THEN
@@ -259,6 +353,6 @@
ENDIF
- !3-2 check namelist
- !3-2-1 check refinament factor
+ ! check namelist
+ ! check refinament factor
il_rho(:)=1
IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN
@@ -270,25 +364,16 @@
ENDIF
- !3-2-2 check domain indices
- IF( in_imin0 < 1 .OR. in_imax0 < 1 .OR. in_jmin0 < 1 .OR. in_jmax0 < 1)THEN
- ! compute coarse grid indices around fine grid
- il_ind(:,:,:)=grid_get_coarse_index(tl_bathy0, tl_bathy1 )
-
- il_imin0=il_ind(1,1,1) ; il_imax0=il_ind(1,2,1)
- il_jmin0=il_ind(2,1,1) ; il_jmax0=il_ind(2,2,1)
-
- il_offset(:,:)=il_ind(:,:,2)
- ELSE
- il_imin0=in_imin0 ; il_imax0=in_imax0
- il_jmin0=in_jmin0 ; il_jmax0=in_jmax0
-
- il_offset(1,:)=FLOOR(REAL(il_rho(jp_I)-1,dp)*0.5)
- il_offset(2,:)=FLOOR(REAL(il_rho(jp_J)-1,dp)*0.5)
- ENDIF
-
- !3-3 check domain validity
+ ! check domain indices
+ ! compute coarse grid indices around fine grid
+ il_ind(:,:)=grid_get_coarse_index(tl_bathy0, tl_bathy1, &
+ & id_rho=il_rho(:) )
+
+ il_imin0=il_ind(1,1) ; il_imax0=il_ind(1,2)
+ il_jmin0=il_ind(2,1) ; il_jmax0=il_ind(2,2)
+
+ ! check domain validity
CALL grid_check_dom(tl_bathy0, il_imin0, il_imax0, il_jmin0, il_jmax0)
- !3-4 check coincidence between coarse and fine grid
+ ! check coincidence between coarse and fine grid
CALL grid_check_coincidence( tl_bathy0, tl_bathy1, &
& il_imin0, il_imax0, &
@@ -296,6 +381,12 @@
& il_rho(:) )
- !4- read or compute boundary
- tl_var=iom_read_var(tl_bathy1,'Bathymetry')
+ ! open mpp files
+ CALL iom_mpp_open(tl_bathy1)
+
+ ! read or compute boundary
+ tl_var=iom_mpp_read_var(tl_bathy1,'Bathymetry')
+
+ ! close mpp files
+ CALL iom_mpp_close(tl_bathy1)
tl_bdy(:)=boundary_init(tl_var, ln_north, ln_south, ln_east, ln_west, &
@@ -303,6 +394,6 @@
& ln_oneseg )
- !5- get boundary on coarse grid
- !5-1 define refined bathymetry table (for coarse grid)
+ ! get boundary on coarse grid
+ ! define refined bathymetry array (for coarse grid)
dl_fill=tl_var%d_fill
ALLOCATE( dl_refined(tl_var%t_dim(1)%i_len, &
@@ -313,5 +404,5 @@
dl_refined(:,:,:,:)=dl_fill
- !5-2 define weight table
+ ! define weight array
ALLOCATE( dl_weight(tl_var%t_dim(1)%i_len, &
& tl_var%t_dim(2)%i_len, &
@@ -320,7 +411,6 @@
dl_weight(:,:,:,:)=dl_fill
- !5-3 compute coarse grid refined bathymetry on boundary.
+ ! compute coarse grid refined bathymetry on boundary.
DO jk=1,ip_ncard
-
CALL merge_bathy_get_boundary(tl_bathy0, tl_bathy1, tl_bdy(jk), &
& il_rho(:), &
@@ -330,5 +420,5 @@
ENDDO
- !6- merge bathy on boundary
+ ! merge bathy on boundary
DO jl=1,tl_var%t_dim(4)%i_len
DO jk=1,tl_var%t_dim(3)%i_len
@@ -348,9 +438,9 @@
DEALLOCATE(dl_refined)
- !7- create file
+ ! create file
tl_fileout=file_init(TRIM(cn_fileout),id_perio=in_perio1)
- !7-1 add dimension
- tl_dim(:)=tl_var%t_dim(:)
+ ! add dimension
+ tl_dim(:)=dim_copy(tl_var%t_dim(:))
DO ji=1,ip_maxdim
@@ -358,15 +448,21 @@
ENDDO
- !7-2 add variables
+ ! add variables
IF( ALL( tl_dim(1:2)%l_use ) )THEN
-
- tl_lon=iom_read_var(tl_bathy1,'longitude')
+ ! open mpp files
+ CALL iom_mpp_open(tl_bathy1)
+
+ ! add longitude
+ tl_lon=iom_mpp_read_var(tl_bathy1,'longitude')
CALL file_add_var(tl_fileout, tl_lon)
CALL var_clean(tl_lon)
- tl_lat=iom_read_var(tl_bathy1,'latitude')
+ ! add latitude
+ tl_lat=iom_mpp_read_var(tl_bathy1,'latitude')
CALL file_add_var(tl_fileout, tl_lat)
CALL var_clean(tl_lat)
+ ! close mpp files
+ CALL iom_mpp_close(tl_bathy1)
ENDIF
@@ -375,5 +471,5 @@
! only 2 first dimension to be used
- tl_dim(:)=tl_fileout%t_dim(:)
+ tl_dim(:)=dim_copy(tl_fileout%t_dim(:))
tl_dim(3:4)%l_use=.FALSE.
tl_var=var_init('weight',dl_weight(:,:,:,:),td_dim=tl_dim(:),dd_fill=dl_fill)
@@ -381,5 +477,5 @@
CALL var_clean(tl_var)
- !7-3 add some attribute
+ ! add some attribute
tl_att=att_init("Created_by","SIREN merge_bathy")
CALL file_add_att(tl_fileout, tl_att)
@@ -395,40 +491,37 @@
CALL file_add_att(tl_fileout, tl_att)
- ! a voir
! add attribute periodicity
- il_attid=0
+ il_attind=0
IF( ASSOCIATED(tl_fileout%t_att) )THEN
- il_attid=att_get_id(tl_fileout%t_att(:),'periodicity')
- ENDIF
- IF( tl_bathy1%i_perio >= 0 .AND. il_attid == 0 )THEN
+ il_attind=att_get_index(tl_fileout%t_att(:),'periodicity')
+ ENDIF
+ IF( tl_bathy1%i_perio >= 0 .AND. il_attind == 0 )THEN
tl_att=att_init('periodicity',tl_bathy1%i_perio)
CALL file_add_att(tl_fileout,tl_att)
ENDIF
- il_attid=0
+ il_attind=0
IF( ASSOCIATED(tl_fileout%t_att) )THEN
- il_attid=att_get_id(tl_fileout%t_att(:),'ew_overlap')
- ENDIF
- IF( tl_bathy1%i_ew >= 0 .AND. il_attid == 0 )THEN
+ il_attind=att_get_index(tl_fileout%t_att(:),'ew_overlap')
+ ENDIF
+ IF( tl_bathy1%i_ew >= 0 .AND. il_attind == 0 )THEN
tl_att=att_init('ew_overlap',tl_bathy1%i_ew)
CALL file_add_att(tl_fileout,tl_att)
ENDIF
- !7-4 create file
+ ! create file
CALL iom_create(tl_fileout)
- !7-5 write file
+ ! write file
CALL iom_write_file(tl_fileout)
- !7-6 close file
+ ! close file
CALL iom_close(tl_fileout)
- CALL iom_close(tl_bathy1)
- CALL iom_close(tl_bathy0)
-
- !8- clean
+ ! clean
+ CALL att_clean(tl_att)
CALL file_clean(tl_fileout)
- CALL file_clean(tl_bathy1)
- CALL file_clean(tl_bathy0)
+ CALL mpp_clean(tl_bathy1)
+ CALL mpp_clean(tl_bathy0)
DEALLOCATE(dl_weight)
@@ -437,19 +530,20 @@
CALL logger_close()
-!> @endcode
CONTAINS
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This subroutine compute refined bathymetry on boundary from coarse grid.
!>
- !> @details
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
!>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !> @param[in]
- !> @todo
+ !> @param[in] td_bathy0 coarse grid bathymetry file structure
+ !> @param[in] td_bathy1 fine grid bathymetry file structure
+ !> @param[in] td_bdy boundary structure
+ !> @param[in] id_rho array of refinement factor
+ !> @param[inout] dd_refined array of refined bathymetry
+ !> @param[inout] dd_weight array of weight
+ !> @param[in] dd_fill fillValue
!-------------------------------------------------------------------
- !> @code
SUBROUTINE merge_bathy_get_boundary( td_bathy0, td_bathy1, td_bdy, &
& id_rho, &
@@ -459,6 +553,6 @@
! Argument
- TYPE(TFILE) , INTENT(IN ) :: td_bathy0
- TYPE(TFILE) , INTENT(IN ) :: td_bathy1
+ TYPE(TMPP) , INTENT(IN ) :: td_bathy0
+ TYPE(TMPP) , INTENT(IN ) :: td_bathy1
TYPE(TBDY) , INTENT(IN ) :: td_bdy
INTEGER(i4), DIMENSION(:) , INTENT(IN ) :: id_rho
@@ -478,11 +572,6 @@
INTEGER(i4) :: il_jmax0
- INTEGER(i4) :: il_imin
- INTEGER(i4) :: il_imax
- INTEGER(i4) :: il_jmin
- INTEGER(i4) :: il_jmax
-
INTEGER(i4), DIMENSION(2,2) :: il_offset
- INTEGER(i4), DIMENSION(2,2,2) :: il_ind
+ INTEGER(i4), DIMENSION(2,2) :: il_ind
REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_tmp1d
@@ -494,9 +583,6 @@
TYPE(TVAR) :: tl_lat1
- TYPE(TFILE) :: tl_bathy1
- TYPE(TFILE) :: tl_bathy0
-
- TYPE(TMPP) :: tl_mppbathy1
- TYPE(TMPP) :: tl_mppbathy0
+ TYPE(TMPP) :: tl_bathy1
+ TYPE(TMPP) :: tl_bathy0
TYPE(TDOM) :: tl_dom1
@@ -510,6 +596,5 @@
IF( td_bdy%l_use )THEN
DO jl=1,td_bdy%i_nseg
-
- !1- get boundary definition
+ ! get boundary definition
SELECT CASE(TRIM(td_bdy%c_card))
CASE('north')
@@ -520,9 +605,4 @@
il_jmax1=td_bdy%t_seg(jl)%i_index
- il_imin=1
- il_imax=il_imax1-il_imin1+1
- il_jmin=td_bdy%t_seg(jl)%i_width
- il_jmax=1
-
CASE('south')
@@ -532,9 +612,4 @@
il_jmax1=td_bdy%t_seg(jl)%i_index+(td_bdy%t_seg(jl)%i_width-1)
- il_imin=1
- il_imax=il_imax1-il_imin1+1
- il_jmin=1
- il_jmax=td_bdy%t_seg(jl)%i_width
-
CASE('east')
@@ -544,9 +619,4 @@
il_jmax1=td_bdy%t_seg(jl)%i_last
- il_imin=td_bdy%t_seg(jl)%i_width
- il_imax=1
- il_jmin=1
- il_jmax=il_jmax1-il_jmin1+1
-
CASE('west')
@@ -556,117 +626,102 @@
il_jmax1=td_bdy%t_seg(jl)%i_last
- il_imin=1
- il_imax=td_bdy%t_seg(jl)%i_width
- il_jmin=1
- il_jmax=il_jmax1-il_jmin1+1
-
END SELECT
- !2 -read fine grid domain
- tl_bathy1=td_bathy1
- CALL iom_open(tl_bathy1)
-
- !2-1 compute domain
+ ! -read fine grid domain
+ tl_bathy1=mpp_copy(td_bathy1)
+
+ ! compute domain
tl_dom1=dom_init( tl_bathy1, &
& il_imin1, il_imax1,&
- & il_jmin1, il_jmax1 )
-
- !2-2 close file
- CALL iom_close(tl_bathy1)
-
- !2-3 read variables on domain (ugly way to do it, have to work on it)
- !2-3-1 init mpp structure
- tl_mppbathy1=mpp_init(tl_bathy1)
-
- CALL file_clean(tl_bathy1)
-
- !2-3-2 get processor to be used
- CALL mpp_get_use( tl_mppbathy1, tl_dom1 )
-
- !2-3-3 open mpp files
- CALL iom_mpp_open(tl_mppbathy1)
-
- !2-3-4 read variable value on domain
- tl_lon1=iom_mpp_read_var(tl_mppbathy1,'longitude',td_dom=tl_dom1)
- tl_lat1=iom_mpp_read_var(tl_mppbathy1,'latitude' ,td_dom=tl_dom1)
-
- !2-3-5 close mpp files
- CALL iom_mpp_close(tl_mppbathy1)
-
- !2-3-6 clean structure
- CALL mpp_clean(tl_mppbathy1)
-
- !3- get coarse grid indices
- il_ind(:,:,:)=grid_get_coarse_index(td_bathy0, tl_lon1, tl_lat1, &
- & id_rho=id_rho(:))
-
- il_imin0=il_ind(1,1,1)
- il_imax0=il_ind(1,2,1)
-
- il_jmin0=il_ind(2,1,1)
- il_jmax0=il_ind(2,2,1)
-
- il_offset(:,:)=il_ind(:,:,2)
-
- !4- read coarse grid bathymetry on domain
- tl_bathy0=td_bathy0
- CALL iom_open(tl_bathy0)
-
- !4-1 compute domain
+ & il_jmin1, il_jmax1,&
+ & TRIM(td_bdy%c_card))
+
+ ! add extra band to fine grid domain (if possible)
+ ! to avoid dimension of one and so be able to compute offset
+ CALL dom_add_extra(tl_dom1, id_rho(jp_I), id_rho(jp_J))
+
+ ! open mpp files over domain
+ CALL iom_dom_open(tl_bathy1, tl_dom1)
+
+ ! read variable value on domain
+ tl_lon1=iom_dom_read_var(tl_bathy1,'longitude',tl_dom1)
+ tl_lat1=iom_dom_read_var(tl_bathy1,'latitude' ,tl_dom1)
+
+ ! close mpp files
+ CALL iom_dom_close(tl_bathy1)
+
+ ! clean structure
+ CALL mpp_clean(tl_bathy1)
+
+ ! get coarse grid indices
+ il_ind(:,:)=grid_get_coarse_index(td_bathy0, tl_lon1, tl_lat1, &
+ & id_rho=id_rho(:))
+
+ il_imin0=il_ind(1,1)
+ il_imax0=il_ind(1,2)
+
+ il_jmin0=il_ind(2,1)
+ il_jmax0=il_ind(2,2)
+
+ ! read coarse grid bathymetry on domain
+ tl_bathy0=mpp_copy(td_bathy0)
+
+ ! compute domain
tl_dom0=dom_init( tl_bathy0, &
& il_imin0, il_imax0,&
& il_jmin0, il_jmax0 )
- !4-2 close file
- CALL iom_close(tl_bathy0)
-
- !4-3 add extra band (if possible) to compute interpolation
+ il_offset(:,:)= grid_get_fine_offset(tl_bathy0, &
+ & il_imin0, il_jmin0,&
+ & il_imax0, il_jmax0,&
+ & tl_lon1%d_value(:,:,1,1), &
+ & tl_lat1%d_value(:,:,1,1), &
+ & id_rho=id_rho(:))
+
+ ! clean
+ CALL var_clean(tl_lon1)
+ CALL var_clean(tl_lat1)
+
+ ! add extra band (if possible) to compute interpolation
CALL dom_add_extra(tl_dom0)
- !4-4 read variables on domain (ugly way to do it, have to work on it)
- !4-4-1 init mpp structure
- tl_mppbathy0=mpp_init(tl_bathy0)
-
- CALL file_clean(tl_bathy0)
-
- !4-4-2 get processor to be used
- CALL mpp_get_use( tl_mppbathy0, tl_dom0 )
-
- !4-4-3 open mpp files
- CALL iom_mpp_open(tl_mppbathy0)
-
- !4-4-4 read variable value on domain
- tl_var0=iom_mpp_read_var(tl_mppbathy0,'Bathymetry',td_dom=tl_dom0)
-
- !4-4-5 close mpp files
- CALL iom_mpp_close(tl_mppbathy0)
-
- !4-4-6 clean structure
- CALL mpp_clean(tl_mppbathy0)
-
- !5- interpolate variable
+ ! open mpp files over domain
+ CALL iom_dom_open(tl_bathy0, tl_dom0)
+
+ ! read variable value on domain
+ tl_var0=iom_dom_read_var(tl_bathy0,'Bathymetry',tl_dom0)
+
+ ! close mpp files
+ CALL iom_dom_close(tl_bathy0)
+
+ ! clean structure
+ CALL mpp_clean(tl_bathy0)
+
+ ! interpolate variable
CALL merge_bathy_interp( tl_var0, &
& id_rho(:), &
& il_offset(:,:) )
- !6- remove extraband added to domain
+ ! remove extraband added to domain
CALL dom_del_extra( tl_var0, tl_dom0, id_rho(:) )
- !6-1 remove extraband added to domain
+ ! remove extraband added to domain
CALL dom_clean_extra( tl_dom0 )
- !7- fill refined table
- !7-1 keep only useful point
- ! interpolation could create more point than necessary
- CALL boundary_clean_interp(tl_var0, td_bdy )
-
- ! use add request ????
-
- !7-2 fill refined table
+ ! remove extraband added to fine grid domain
+ CALL dom_del_extra( tl_var0, tl_dom1 )
+
+ ! remove extraband added to fine grid domain
+ CALL dom_clean_extra( tl_dom1 )
+
+ ! fill refined array
dd_refined( il_imin1:il_imax1, &
& il_jmin1:il_jmax1, &
& :,: )= tl_var0%d_value(:,:,:,:)
- !8- compute weight function
+ ! clean
+ CALL var_clean(tl_var0)
+
+ ! compute weight function
ALLOCATE( dl_tmp1d(td_bdy%t_seg(jl)%i_width) )
@@ -678,5 +733,5 @@
! compute weight on segment
- dl_tmp1d(:)= 0.5 + 0.5*COS( (dg_pi*dl_tmp1d(:)) / &
+ dl_tmp1d(:)= 0.5 + 0.5*COS( (dp_pi*dl_tmp1d(:)) / &
& (td_bdy%t_seg(jl)%i_width) )
@@ -694,5 +749,5 @@
! compute weight on segment
- dl_tmp1d(:)= 0.5 + 0.5*COS( (dg_pi*dl_tmp1d(:)) / &
+ dl_tmp1d(:)= 0.5 + 0.5*COS( (dp_pi*dl_tmp1d(:)) / &
& (td_bdy%t_seg(jl)%i_width) )
@@ -710,5 +765,5 @@
! compute weight on segment
- dl_tmp1d(:)= 0.5 + 0.5*COS( (dg_pi*dl_tmp1d(:)) / &
+ dl_tmp1d(:)= 0.5 + 0.5*COS( (dp_pi*dl_tmp1d(:)) / &
& (td_bdy%t_seg(jl)%i_width) )
@@ -726,5 +781,5 @@
! compute weight on segment
- dl_tmp1d(:)= 0.5 + 0.5*COS( (dg_pi*dl_tmp1d(:)) / &
+ dl_tmp1d(:)= 0.5 + 0.5*COS( (dp_pi*dl_tmp1d(:)) / &
& (td_bdy%t_seg(jl)%i_width) )
@@ -740,5 +795,5 @@
DEALLOCATE( dl_tmp1d )
- !8-1 fill weight table
+ ! fill weight array
ALLOCATE( dl_tmp2d( tl_dom1%t_dim(1)%i_len, &
& tl_dom1%t_dim(2)%i_len) )
@@ -764,18 +819,17 @@
ENDIF
END SUBROUTINE merge_bathy_get_boundary
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine
+ !> This subroutine interpolate variable.
!>
- !> @details
+ !> @author J.Paul
+ !> @date November, 2013 - Initial Version
!>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !>
- !> @param[in]
- !> @todo
+ !> @param[inout] td_var variable structure
+ !> @param[in] id_rho array of refinment factor
+ !> @param[in] id_offset array of offset between fine and coarse grid
+ !> @param[in] id_iext i-direction size of extra bands (default=im_minext)
+ !> @param[in] id_jext j-direction size of extra bands (default=im_minext)
!-------------------------------------------------------------------
- !> @code
SUBROUTINE merge_bathy_interp( td_var, &
& id_rho, &
@@ -793,5 +847,4 @@
! local variable
- TYPE(TVAR) :: tl_var
TYPE(TVAR) :: tl_mask
@@ -803,7 +856,4 @@
! loop indices
!----------------------------------------------------------------
-
- ! copy variable
- tl_var=td_var
!WARNING: two extrabands are required for cubic interpolation
@@ -815,5 +865,5 @@
IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
- CALL logger_warn("CREATE BATHY INTERP: at least extrapolation "//&
+ CALL logger_warn("MERGE BATHY INTERP: at least extrapolation "//&
& "on two points are required with cubic interpolation ")
il_iext=2
@@ -821,64 +871,57 @@
IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
- CALL logger_warn("CREATE BATHY INTERP: at least extrapolation "//&
+ CALL logger_warn("MERGE BATHY INTERP: at least extrapolation "//&
& "on two points are required with cubic interpolation ")
il_jext=2
ENDIF
- !1- work on mask
- !1-1 create mask
- ALLOCATE(bl_mask(tl_var%t_dim(1)%i_len, &
- & tl_var%t_dim(2)%i_len, &
- & tl_var%t_dim(3)%i_len, &
- & tl_var%t_dim(4)%i_len) )
+ ! work on mask
+ ! create mask
+ ALLOCATE(bl_mask(td_var%t_dim(1)%i_len, &
+ & td_var%t_dim(2)%i_len, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len) )
bl_mask(:,:,:,:)=1
- WHERE(tl_var%d_value(:,:,:,:)==tl_var%d_fill) bl_mask(:,:,:,:)=0
-
- SELECT CASE(TRIM(tl_var%c_point))
+ WHERE(td_var%d_value(:,:,:,:)==td_var%d_fill) bl_mask(:,:,:,:)=0
+
+ SELECT CASE(TRIM(td_var%c_point))
CASE DEFAULT ! 'T'
- tl_mask=var_init('tmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
- CASE('U')
- tl_mask=var_init('umask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
- CASE('V')
- tl_mask=var_init('vmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
- CASE('F')
- tl_mask=var_init('fmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
+ tl_mask=var_init('tmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),&
+ & id_ew=td_var%i_ew )
+ CASE('U','V','F')
+ CALL logger_fatal("MERGE BATHY INTERP: can not computed "//&
+ & "interpolation on "//TRIM(td_var%c_point)//&
+ & " grid point (variable "//TRIM(td_var%c_name)//&
+ & "). check namelist.")
END SELECT
DEALLOCATE(bl_mask)
- !1-2 interpolate mask
+ ! interpolate mask
CALL interp_fill_value( tl_mask, id_rho(:), &
& id_offset=id_offset(:,:) )
- !2- work on variable
- !2-0 add extraband
- CALL extrap_add_extrabands(tl_var, il_iext, il_iext)
-
- !2-1 extrapolate variable
- CALL extrap_fill_value( tl_var, id_offset=id_offset(:,:), &
+ ! work on variable
+ ! add extraband
+ CALL extrap_add_extrabands(td_var, il_iext, il_iext)
+
+ ! extrapolate variable
+ CALL extrap_fill_value( td_var, id_offset=id_offset(:,:), &
& id_rho=id_rho(:), &
& id_iext=il_iext, id_jext=il_jext )
- !2-2 interpolate Bathymetry
- CALL interp_fill_value( tl_var, id_rho(:), &
+ ! interpolate Bathymetry
+ CALL interp_fill_value( td_var, id_rho(:), &
& id_offset=id_offset(:,:) )
- !2-3 remove extraband
- CALL extrap_del_extrabands(tl_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
-
- !2-4 keep original mask
+ ! remove extraband
+ CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
+
+ ! keep original mask
WHERE( tl_mask%d_value(:,:,:,:) == 0 )
- tl_var%d_value(:,:,:,:)=tl_var%d_fill
+ td_var%d_value(:,:,:,:)=td_var%d_fill
END WHERE
- !3- save result
- td_var=tl_var
-
- ! clean variable structure
- CALL var_clean(tl_var)
-
END SUBROUTINE merge_bathy_interp
- !> @endcode
END PROGRAM merge_bathy
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/mpp.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/mpp.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/mpp.f90 (revision 5214)
@@ -5,32 +5,47 @@
! MODULE: mpp
!
-!
! DESCRIPTION:
-!> This module manage massively parallel processing
+!> @brief
+!> This module manage massively parallel processing.
!
!> @details
!> define type TMPP:
-!> TYPE(TMPP) :: tl_mpp
+!> @code
+!> TYPE(TMPP) :: tl_mpp
+!> @endcode
!>
!> to initialise a mpp structure:
-!> - tl_mpp=mpp_init( cd_file, id_mask, [id_niproc,] [id_njproc,]
-!> [id_nproc] [id_preci,] [id_precj,] [cd_type])
-!> - tl_mpp=mpp_init( cd_file, td_var, [id_niproc,] [id_njproc,]
-!> [id_nproc] [id_preci,] [id_precj,] [cd_type])
-!> - tl_mpp=mpp_init( td_file )
+!> @code
+!> tl_mpp=mpp_init( cd_file, id_mask,
+!> [id_niproc,] [id_njproc,] [id_nproc,]
+!> [id_preci,] [id_precj,]
+!> [cd_type,] [id_ew])
+!> @endcode
+!> or
+!> @code
+!> tl_mpp=mpp_init( cd_file, td_var,
+!> [id_niproc,] [id_njproc,] [id_nproc,]
+!> [id_preci,] [id_precj,]
+!> [cd_type] )
+!> @endcode
+!> or
+!> @code
+!> tl_mpp=mpp_init( td_file [,id_ew] )
+!> @endcode
!> - cd_file is the filename of the global domain file, in which
!> MPP will be done (example: Bathymetry)
!> - td_file is the file structure of one processor file composing an MPP
-!> - id_mask is the 2D mask of global domain
+!> - id_mask is the 2D mask of global domain [optional]
!> - td_var is a variable structure (on T-point) from global domain file.
-!> mask of the domain will be computed using FillValue
+!> mask of the domain will be computed using FillValue [optional]
!> - id_niproc is the number of processor following I-direction to be used
-!> (optional)
+!> [optional]
!> - id_njproc is the number of processor following J-direction to be used
-!> (optional)
-!> - id_nproc is the total number of processor to be used (optional)
-!> - id_preci is the size of the overlap region following I-direction
-!> - id_precj is the size of the overlap region following J-direction
-!> - cd_type is the type of files composing MPP
+!> [optional]
+!> - id_nproc is the total number of processor to be used [optional]
+!> - id_preci is the size of the overlap region following I-direction [optional]
+!> - id_precj is the size of the overlap region following J-direction [optional]
+!> - cd_type is the type of files composing MPP [optional]
+!> - id_ew is east-west overlap [optional]
!>
!> to get mpp name:
@@ -62,5 +77,5 @@
!> - tl_mpp\%i_ndim
!>
-!> to get the table of dimension structure (4 elts) associated to the
+!> to get the array of dimension structure (4 elts) associated to the
!> mpp structure:
!> - tl_mpp\%t_dim(:)
@@ -70,50 +85,110 @@
!>
!> to clean a mpp structure:
-!> - CALL mpp_clean(tl_mpp)
+!> @code
+!> CALL mpp_clean(tl_mpp)
+!> @endcode
!>
!> to print information about mpp:
+!> @code
!> CALL mpp_print(tl_mpp)
+!> @endcode
!>
!> to add variable to mpp:
+!> @code
!> CALL mpp_add_var(td_mpp, td_var)
+!> @endcode
!> - td_var is a variable structure
!>
!> to add dimension to mpp:
+!> @code
!> CALL mpp_add_dim(td_mpp, td_dim)
+!> @endcode
!> - td_dim is a dimension structure
!>
-!> to delete variable to mpp:
+!> to add attribute to mpp:
+!> @code
+!> CALL mpp_add_att(td_mpp, td_att)
+!> @endcode
+!> - td_att is a attribute structure
+!>
+!> to delete variable from mpp:
+!> @code
!> CALL mpp_del_var(td_mpp, td_var)
+!> @endcode
+!> or
+!> @code
+!> CALL mpp_del_var(td_mpp, cd_name)
+!> @endcode
!> - td_var is a variable structure
+!> - cd_name is variable name or standard name
!>
-!> to delete dimension to mpp:
+!> to delete dimension from mpp:
+!> @code
!> CALL mpp_del_dim(td_mpp, td_dim)
+!> @endcode
!> - td_dim is a dimension structure
!>
+!> to delete attribute from mpp:
+!> @code
+!> CALL mpp_del_att(td_mpp, td_att)
+!> @endcode
+!> or
+!> @code
+!> CALL mpp_del_att(td_mpp, cd_name)
+!> @endcode
+!> - td_att is a attribute structure
+!> - cd_name is attribute name
+!>
!> to overwrite variable to mpp:
+!> @code
!> CALL mpp_move_var(td_mpp, td_var)
+!> @endcode
!> - td_var is a variable structure
!>
!> to overwrite dimension to mpp:
+!> @code
!> CALL mpp_move_dim(td_mpp, td_dim)
+!> @endcode
!> - td_dim is a dimension structure
!>
+!> to overwrite attribute to mpp:
+!> @code
+!> CALL mpp_move_att(td_mpp, td_att)
+!> @endcode
+!> - td_att is a attribute structure
+!>
!> to determine domain decomposition type:
+!> @code
!> CALL mpp_get_dom(td_mpp)
+!> @endcode
!>
!> to get processors to be used:
-!> CALL mpp_get_use( td_mpp, td_dom )
-!> - td_dom is a domain structure
+!> @code
+!> CALL mpp_get_use( td_mpp, id_imin, id_imax, id_idim, &
+!> & id_jmin, id_jmax, id_jdim )
+!> @endcode
+!> - id_imin
+!> - id_imax
+!> - id_idim
+!> - id_jmin
+!> - id_jmax
+!> - id_jdim
!>
!> to get sub domains which form global domain contour:
+!> @code
!> CALL mpp_get_contour( td_mpp )
+!> @endcode
!>
!> to get global domain indices of one processor:
+!> @code
!> il_ind(1:4)=mpp_get_proc_index( td_mpp, id_procid )
+!> @endcode
!> - il_ind(1:4) are global domain indices (i1,i2,j1,j2)
!> - id_procid is the processor id
!>
!> to get the processor domain size:
+!> @code
!> il_size(1:2)=mpp_get_proc_size( td_mpp, id_procid )
+!> @endcode
!> - il_size(1:2) are the size of domain following I and J
!> - id_procid is the processor id
@@ -122,16 +197,13 @@
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!> @todo
-!> - add description generique de l'objet mpp
-!> - mpp_print
-!> - voir pour mettre cd_file systematiquement pour mpp_init
-!> + modifier utilisation la haut
+!> @date November, 2013 - Initial Version
+!> @date November, 2014 - Fix memory leaks bug
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
!----------------------------------------------------------------------
MODULE mpp
+ USE global ! global parameter
USE kind ! F90 kind parameter
- USE logger ! log file manager
+ USE logger ! log file manager
USE fct ! basic useful function
USE dim ! dimension manager
@@ -140,15 +212,12 @@
USE file ! file manager
USE iom ! I/O manager
-! USE proc ! proc manager
- USE dom ! domain manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! type and variable
- PUBLIC :: TMPP ! mpp structure
+ PUBLIC :: TMPP !< mpp structure
! function and subroutine
- PUBLIC :: ASSIGNMENT(=) !< copy mpp structure
+ PUBLIC :: mpp_copy !< copy mpp structure
PUBLIC :: mpp_init !< initialise mpp structure
PUBLIC :: mpp_clean !< clean mpp strcuture
@@ -163,4 +232,6 @@
PUBLIC :: mpp_move_dim !< overwrite one dimension strucutre in mpp structure
PUBLIC :: mpp_move_att !< overwrite one attribute strucutre in mpp structure
+ PUBLIC :: mpp_recombine_var !< recombine variable from mpp structure
+ PUBLIC :: mpp_get_index !< return index of mpp
PUBLIC :: mpp_get_dom !< determine domain decomposition type (full, overlap, noverlap)
@@ -170,40 +241,66 @@
PUBLIC :: mpp_get_proc_size !< get processor domain size
- PRIVATE :: mpp__add_proc !< add one proc strucutre in mpp structure
- PRIVATE :: mpp__del_proc !< delete one proc strucutre in mpp structure
- PRIVATE :: mpp__move_proc !< overwrite proc strucutre in mpp structure
- PRIVATE :: mpp__compute !< compute domain decomposition
- PRIVATE :: mpp__del_land !< remove land sub domain from domain decomposition
- PRIVATE :: mpp__optimiz !< compute optimum domain decomposition
- PRIVATE :: mpp__land_proc !< check if processor is a land processor
- PRIVATE :: mpp__check_dim !< check mpp structure dimension with proc or variable dimension
- PRIVATE :: mpp__del_var_name !< delete variable in mpp structure, given variable name
- PRIVATE :: mpp__del_var_str !< delete variable in mpp structure, given variable structure
- PRIVATE :: mpp__del_att_name !< delete variable in mpp structure, given variable name
- PRIVATE :: mpp__del_att_str !< delete variable in mpp structure, given variable structure
- PRIVATE :: mpp__split_var !< extract variable part that will be written in processor
- PRIVATE :: mpp__copy !< copy mpp structure
-
- !> @struct TMPP
- TYPE TMPP
+ PRIVATE :: mpp__add_proc ! add one proc strucutre in mpp structure
+ PRIVATE :: mpp__del_proc ! delete one proc strucutre in mpp structure
+ PRIVATE :: mpp__del_proc_id ! delete one proc strucutre in mpp structure, given procesor id
+ PRIVATE :: mpp__del_proc_str ! delete one proc strucutre in mpp structure, given procesor file structure
+ PRIVATE :: mpp__move_proc ! overwrite proc strucutre in mpp structure
+ PRIVATE :: mpp__compute ! compute domain decomposition
+ PRIVATE :: mpp__del_land ! remove land sub domain from domain decomposition
+ PRIVATE :: mpp__optimiz ! compute optimum domain decomposition
+ PRIVATE :: mpp__land_proc ! check if processor is a land processor
+ PRIVATE :: mpp__check_dim ! check mpp structure dimension with proc or variable dimension
+ PRIVATE :: mpp__check_proc_dim ! check if processor and mpp structure use same dimension
+ PRIVATE :: mpp__check_var_dim ! check if variable and mpp structure use same dimension
+ PRIVATE :: mpp__del_var_name ! delete variable in mpp structure, given variable name
+ PRIVATE :: mpp__del_var_mpp ! delete all variable in mpp structure
+ PRIVATE :: mpp__del_var_str ! delete variable in mpp structure, given variable structure
+ PRIVATE :: mpp__del_att_name ! delete variable in mpp structure, given variable name
+ PRIVATE :: mpp__del_att_str ! delete variable in mpp structure, given variable structure
+ PRIVATE :: mpp__split_var ! extract variable part that will be written in processor
+ PRIVATE :: mpp__copy_unit ! copy mpp structure
+ PRIVATE :: mpp__copy_arr ! copy array of mpp structure
+ PRIVATE :: mpp__get_use_unit ! get sub domains to be used (which cover "zoom domain")
+ PRIVATE :: mpp__init_mask ! initialise mpp structure, given file name
+ PRIVATE :: mpp__init_var ! initialise mpp structure, given variable strcuture
+ PRIVATE :: mpp__init_file ! initialise a mpp structure, given file structure
+ PRIVATE :: mpp__init_file_cdf ! initialise a mpp structure with cdf file
+ PRIVATE :: mpp__init_file_rstdimg ! initialise a mpp structure with rstdimg file
+ PRIVATE :: mpp__clean_unit ! clean mpp strcuture
+ PRIVATE :: mpp__clean_arr ! clean array of mpp strcuture
+
+ TYPE TMPP !< mpp structure
! general
- CHARACTER(LEN=lc) :: c_name = '' !< base name ???
-
- INTEGER(i4) :: i_niproc = 0 !< number of processors following i
- INTEGER(i4) :: i_njproc = 0 !< number of processors following j
- INTEGER(i4) :: i_nproc = 0 !< total number of proccessors used
- INTEGER(i4) :: i_preci = 1 !< i-direction overlap region length
- INTEGER(i4) :: i_precj = 1 !< j-direction overlap region length
-
- CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg)
- CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, overlap, nooverlap)
-
- INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp
- TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< global domain dimension
-
- TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp
+ CHARACTER(LEN=lc) :: c_name = '' !< base name
+ INTEGER(i4) :: i_id = 0 !< mpp id
+
+ INTEGER(i4) :: i_niproc = 0 !< number of processors following i
+ INTEGER(i4) :: i_njproc = 0 !< number of processors following j
+ INTEGER(i4) :: i_nproc = 0 !< total number of proccessors used
+ INTEGER(i4) :: i_preci = 1 !< i-direction overlap region length
+ INTEGER(i4) :: i_precj = 1 !< j-direction overlap region length
+ INTEGER(i4) :: i_ew = -1 !< east-west overlap
+ INTEGER(i4) :: i_perio = -1 !< NEMO periodicity index
+ INTEGER(i4) :: i_pivot = -1 !< NEMO pivot point index F(0),T(1)
+
+ CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg)
+ CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, overlap, nooverlap)
+
+ INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp
+ TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< global domain dimension
+
+ TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp
END TYPE
+
+ INTERFACE mpp_get_use
+ MODULE PROCEDURE mpp__get_use_unit
+ END INTERFACE mpp_get_use
+
+ INTERFACE mpp_clean
+ MODULE PROCEDURE mpp__clean_unit
+ MODULE PROCEDURE mpp__clean_arr
+ END INTERFACE mpp_clean
INTERFACE mpp__check_dim
@@ -220,4 +317,5 @@
MODULE PROCEDURE mpp__del_var_name
MODULE PROCEDURE mpp__del_var_str
+ MODULE PROCEDURE mpp__del_var_mpp
END INTERFACE mpp_del_var
@@ -230,9 +328,10 @@
MODULE PROCEDURE mpp__init_mask
MODULE PROCEDURE mpp__init_var
- MODULE PROCEDURE mpp__init_read
+ MODULE PROCEDURE mpp__init_file
END INTERFACE mpp_init
- INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE mpp__copy ! copy mpp structure
+ INTERFACE mpp_copy
+ MODULE PROCEDURE mpp__copy_unit ! copy mpp structure
+ MODULE PROCEDURE mpp__copy_arr ! copy array of mpp structure
END INTERFACE
@@ -240,23 +339,34 @@
!-------------------------------------------------------------------
!> @brief
- !> This subroutine copy mpp structure in another mpp
- !> structure
+ !> This subroutine copy mpp structure in another one
!> @details
- !> mpp file are copied in a temporary table,
+ !> mpp file are copied in a temporary array,
!> so input and output mpp structure do not point on the same
!> "memory cell", and so on are independant.
!>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[out] td_mpp1 : mpp structure
- !> @param[in] td_mpp2 : mpp structure
- !-------------------------------------------------------------------
- ! @code
- SUBROUTINE mpp__copy( td_mpp1, td_mpp2 )
+ !> @warning do not use on the output of a function who create or read an
+ !> structure (ex: tl_file=file_copy(file_init()) is forbidden).
+ !> This will create memory leaks.
+ !> @warning to avoid infinite loop, do not use any function inside
+ !> this subroutine
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator
+ !> (to avoid memory leak)
+ !
+ !> @param[in] td_mpp mpp structure
+ !> @return copy of input mpp structure
+ !-------------------------------------------------------------------
+ FUNCTION mpp__copy_unit( td_mpp )
IMPLICIT NONE
! Argument
- TYPE(TMPP), INTENT(OUT) :: td_mpp1
- TYPE(TMPP), INTENT(IN) :: td_mpp2
+ TYPE(TMPP), INTENT(IN) :: td_mpp
+ ! function
+ TYPE(TMPP) :: mpp__copy_unit
+
+ ! local variable
+ TYPE(TFILE) :: tl_file
! loop indices
@@ -264,31 +374,80 @@
!----------------------------------------------------------------
- CALL logger_trace("COPY: mpp "//TRIM(td_mpp2%c_name)//" in "//&
- & TRIM(td_mpp1%c_name))
+ CALL logger_trace("MPP COPY: "//TRIM(td_mpp%c_name)//" in "//&
+ & TRIM(mpp__copy_unit%c_name))
+
! copy mpp variable
- td_mpp1%c_name = TRIM(td_mpp2%c_name)
- td_mpp1%i_niproc = td_mpp2%i_niproc
- td_mpp1%i_njproc = td_mpp2%i_njproc
- td_mpp1%i_nproc = td_mpp2%i_nproc
- td_mpp1%i_preci = td_mpp2%i_preci
- td_mpp1%i_precj = td_mpp2%i_precj
- td_mpp1%c_type = TRIM(td_mpp2%c_type)
- td_mpp1%c_dom = TRIM(td_mpp2%c_dom)
- td_mpp1%i_ndim = td_mpp2%i_ndim
+ mpp__copy_unit%c_name = TRIM(td_mpp%c_name)
+ mpp__copy_unit%i_niproc = td_mpp%i_niproc
+ mpp__copy_unit%i_njproc = td_mpp%i_njproc
+ mpp__copy_unit%i_nproc = td_mpp%i_nproc
+ mpp__copy_unit%i_preci = td_mpp%i_preci
+ mpp__copy_unit%i_precj = td_mpp%i_precj
+ mpp__copy_unit%c_type = TRIM(td_mpp%c_type)
+ mpp__copy_unit%c_dom = TRIM(td_mpp%c_dom)
+ mpp__copy_unit%i_ndim = td_mpp%i_ndim
+ mpp__copy_unit%i_ew = td_mpp%i_ew
+ mpp__copy_unit%i_perio = td_mpp%i_perio
+ mpp__copy_unit%i_pivot = td_mpp%i_pivot
! copy dimension
- td_mpp1%t_dim(:) = td_mpp2%t_dim(:)
+ mpp__copy_unit%t_dim(:) = dim_copy(td_mpp%t_dim(:))
! copy file structure
- IF( ASSOCIATED(td_mpp1%t_proc) ) DEALLOCATE(td_mpp1%t_proc)
- IF( ASSOCIATED(td_mpp2%t_proc) )THEN
- ALLOCATE( td_mpp1%t_proc(td_mpp1%i_nproc) )
- DO ji=1,td_mpp1%i_nproc
- td_mpp1%t_proc(ji) = td_mpp2%t_proc(ji)
+ IF( ASSOCIATED(mpp__copy_unit%t_proc) )THEN
+ CALL file_clean(mpp__copy_unit%t_proc(:))
+ DEALLOCATE(mpp__copy_unit%t_proc)
+ ENDIF
+ IF( ASSOCIATED(td_mpp%t_proc) .AND. mpp__copy_unit%i_nproc > 0 )THEN
+ ALLOCATE( mpp__copy_unit%t_proc(mpp__copy_unit%i_nproc) )
+ DO ji=1,mpp__copy_unit%i_nproc
+ tl_file = file_copy(td_mpp%t_proc(ji))
+ mpp__copy_unit%t_proc(ji) = file_copy(tl_file)
ENDDO
- ENDIF
-
- END SUBROUTINE mpp__copy
- ! @endcode
+ ! clean
+ CALL file_clean(tl_file)
+ ENDIF
+
+ END FUNCTION mpp__copy_unit
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine copy an array of mpp structure in another one
+ !> @details
+ !> mpp file are copied in a temporary array,
+ !> so input and output mpp structure do not point on the same
+ !> "memory cell", and so on are independant.
+ !>
+ !> @warning do not use on the output of a function who create or read an
+ !> structure (ex: tl_file=file_copy(file_init()) is forbidden).
+ !> This will create memory leaks.
+ !> @warning to avoid infinite loop, do not use any function inside
+ !> this subroutine
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator
+ !> (to avoid memory leak)
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @return copy of input array of mpp structure
+ !-------------------------------------------------------------------
+ FUNCTION mpp__copy_arr( td_mpp )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), DIMENSION(:), INTENT(IN) :: td_mpp
+ ! function
+ TYPE(TMPP), DIMENSION(SIZE(td_mpp(:))) :: mpp__copy_arr
+
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ DO ji=1,SIZE(td_mpp(:))
+ mpp__copy_arr(ji)=mpp_copy(td_mpp(ji))
+ ENDDO
+
+ END FUNCTION mpp__copy_arr
!-------------------------------------------------------------------
!> @brief This subroutine print some information about mpp strucutre.
@@ -297,7 +456,6 @@
!> - Nov, 2013- Initial Version
!
- !> @param[in] td_mpp : mpp structure
- !-------------------------------------------------------------------
- ! @code
+ !> @param[in] td_mpp mpp structure
+ !-------------------------------------------------------------------
SUBROUTINE mpp_print(td_mpp)
IMPLICIT NONE
@@ -307,5 +465,5 @@
! local variable
- INTEGER(i4), PARAMETER :: ip_freq = 4
+ INTEGER(i4), PARAMETER :: il_freq = 4
INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_proc
@@ -321,5 +479,5 @@
!----------------------------------------------------------------
- WRITE(*,'((a,a),2(/3x,a,a),6(/3x,a,i0))')&
+ WRITE(*,'((a,a),2(/3x,a,a),9(/3x,a,i0))')&
& "MPP : ",TRIM(td_mpp%c_name), &
& " type : ",TRIM(td_mpp%c_type), &
@@ -330,5 +488,8 @@
& " preci : ",td_mpp%i_preci, &
& " precj : ",td_mpp%i_precj, &
- & " ndim : ",td_mpp%i_ndim
+ & " ndim : ",td_mpp%i_ndim, &
+ & " overlap: ",td_mpp%i_ew, &
+ & " perio : ",td_mpp%i_perio, &
+ & " pivot : ",td_mpp%i_pivot
! print dimension
@@ -363,11 +524,12 @@
& td_mpp%t_proc(ji)%i_lej
- !! attribute
- !DO jj=1, td_mpp%t_proc(ji)%i_natt
- ! CALL att_print(td_mpp%t_proc(ji)%t_att(jj))
- !ENDDO
-
-
ENDDO
+
+ IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN
+ WRITE(*,'(/a)') " Variable(s) used : "
+ DO ji=1,td_mpp%t_proc(1)%i_nvar
+ WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)
+ ENDDO
+ ENDIF
ELSE
@@ -387,11 +549,13 @@
& td_mpp%t_proc(ji)%i_lej
- !! attribute
- !DO jj=1, td_mpp%t_proc(ji)%i_natt
- ! CALL att_print(td_mpp%t_proc(ji)%t_att(jj))
- !ENDDO
-
ENDDO
+ IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN
+ WRITE(*,'(/a)') " Variable(s) used : "
+ DO ji=1,td_mpp%t_proc(1)%i_nvar
+ WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)
+ ENDDO
+ ENDIF
+
ALLOCATE( il_proc(td_mpp%i_niproc,td_mpp%i_njproc) )
ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) )
@@ -407,6 +571,6 @@
jl = 1
- DO jk = 1,(td_mpp%i_niproc-1)/ip_freq+1
- jm = MIN(td_mpp%i_niproc, jl+ip_freq-1)
+ DO jk = 1,(td_mpp%i_niproc-1)/il_freq+1
+ jm = MIN(td_mpp%i_niproc, jl+il_freq-1)
WRITE(*,*)
WRITE(*,9401) (ji, ji = jl,jm)
@@ -419,5 +583,5 @@
WRITE(*,9400) ('***', ji = jl,jm-1)
ENDDO
- jl = jl+ip_freq
+ jl = jl+il_freq
ENDDO
@@ -439,9 +603,8 @@
END SUBROUTINE mpp_print
- ! @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function initialised mpp structure, given file name, mask and number of
- !> processor following I and J
+ !> This function initialise mpp structure, given file name,
+ !> and optionaly mask and number of processor following I and J
!> @detail
!> - If no total number of processor is defined (id_nproc), optimize
@@ -452,25 +615,27 @@
!
!> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[in] cd_file : file name of one file composing mpp domain
- !> @param[in] id_mask : domain mask
- !> @param[in] id_niproc : number of processors following i
- !> @param[in] id_njproc : number of processors following j
- !> @param[in] id_nproc : total number of processors
- !> @param[in] id_preci : i-direction overlap region
- !> @param[in] id_precj : j-direction overlap region
- !> @param[in] cd_type : type of the files (cdf, cdf4, dimg)
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[in] cd_file file name of one file composing mpp domain
+ !> @param[in] id_mask domain mask
+ !> @param[in] id_niproc number of processors following i
+ !> @param[in] id_njproc number of processors following j
+ !> @param[in] id_nproc total number of processors
+ !> @param[in] id_preci i-direction overlap region
+ !> @param[in] id_precj j-direction overlap region
+ !> @param[in] cd_type type of the files (cdf, cdf4, dimg)
+ !> @param[in] id_ew east-west overlap
+ !> @param[in] id_perio NEMO periodicity index
+ !> @param[in] id_pivot NEMO pivot point index F(0),T(1)
!> @return mpp structure
!-------------------------------------------------------------------
- !> @code
TYPE(TMPP) FUNCTION mpp__init_mask(cd_file, id_mask, &
& id_niproc, id_njproc, id_nproc,&
& id_preci, id_precj, &
- cd_type)
+ cd_type, id_ew, id_perio, id_pivot)
IMPLICIT NONE
! Argument
CHARACTER(LEN=*), INTENT(IN) :: cd_file
- INTEGER(i4), DIMENSION(:,:), INTENT(IN), OPTIONAL :: id_mask
+ INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc
INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc
@@ -479,4 +644,7 @@
INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
! local variable
@@ -494,7 +662,4 @@
! clean mpp
CALL mpp_clean(mpp__init_mask)
-
- ! get mpp name
- mpp__init_mask%c_name=TRIM(file_rename(cd_file))
! check type
@@ -518,14 +683,18 @@
ENDIF
- IF( PRESENT(id_mask) )THEN
- ! get global domain dimension
- il_shape(:)=SHAPE(id_mask)
-
- tl_dim=dim_init('X',il_shape(1))
- CALL mpp_add_dim(mpp__init_mask, tl_dim)
-
- tl_dim=dim_init('Y',il_shape(2))
- CALL mpp_add_dim(mpp__init_mask,tl_dim)
- ENDIF
+ ! get mpp name
+ mpp__init_mask%c_name=TRIM(file_rename(cd_file))
+
+ ! get global domain dimension
+ il_shape(:)=SHAPE(id_mask)
+
+ tl_dim=dim_init('X',il_shape(1))
+ CALL mpp_add_dim(mpp__init_mask, tl_dim)
+
+ tl_dim=dim_init('Y',il_shape(2))
+ CALL mpp_add_dim(mpp__init_mask, tl_dim)
+
+ ! clean
+ CALL dim_clean(tl_dim)
IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_niproc))) .OR. &
@@ -546,4 +715,10 @@
IF( PRESENT(id_precj) ) mpp__init_mask%i_precj= id_precj
+ ! east-west overlap
+ IF( PRESENT(id_ew) ) mpp__init_mask%i_ew= id_ew
+ ! NEMO periodicity
+ IF( PRESENT(id_perio) ) mpp__init_mask%i_perio= id_perio
+ IF( PRESENT(id_pivot) ) mpp__init_mask%i_pivot= id_pivot
+
IF( mpp__init_mask%i_nproc /= 0 .AND. &
& mpp__init_mask%i_niproc /= 0 .AND. &
@@ -560,5 +735,6 @@
ELSE
- IF( mpp__init_mask%i_niproc /= 0 .AND. mpp__init_mask%i_njproc /= 0 )THEN
+ IF( mpp__init_mask%i_niproc /= 0 .AND. &
+ & mpp__init_mask%i_njproc /= 0 )THEN
! compute domain decomposition
CALL mpp__compute( mpp__init_mask )
@@ -570,9 +746,14 @@
ELSE
- CALL logger_error("MPP INIT: can't define domain decomposition")
- CALL logger_debug ("MPP INIT: maximum number of processor to be used "//&
- & "or number of processor following I and J direction must "//&
- & "be specified.")
+ CALL logger_warn("MPP INIT: number of processor to be used "//&
+ & "not specify. force to one.")
+ mpp__init_mask%i_nproc = 1
+ ! optimiz
+ CALL mpp__optimiz( mpp__init_mask, id_mask )
ENDIF
+ CALL logger_info("MPP INIT: domain decoposition : "//&
+ & 'niproc('//TRIM(fct_str(mpp__init_mask%i_niproc))//') * '//&
+ & 'njproc('//TRIM(fct_str(mpp__init_mask%i_njproc))//') = '//&
+ & 'nproc('//TRIM(fct_str(mpp__init_mask%i_nproc))//')' )
! get domain type
@@ -593,4 +774,6 @@
mpp__init_mask%t_proc(ji)%c_type=TRIM(mpp__init_mask%c_type)
+ ! clean
+ CALL dim_clean(tl_dim)
ENDDO
@@ -640,12 +823,13 @@
CALL mpp_add_att(mpp__init_mask, tl_att)
+ ! clean
+ CALL att_clean(tl_att)
ENDIF
END FUNCTION mpp__init_mask
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function initialised mpp structure, given variable strcuture
- !> and number of processor following I and J
+ !> This function initialise mpp structure, given variable strcuture
+ !> and optionaly number of processor following I and J
!> @detail
!> - If no total number of processor is defined (id_nproc), optimize
@@ -656,20 +840,22 @@
!
!> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[in] cd_file : file name of one file composing mpp domain
- !> @param[in] td_var : variable structure
- !> @param[in] id_niproc : number of processors following i
- !> @param[in] id_njproc : number of processors following j
- !> @param[in] id_nproc : total number of processors
- !> @param[in] id_preci : i-direction overlap region
- !> @param[in] id_precj : j-direction overlap region
- !> @param[in] cd_type : type of the files (cdf, cdf4, dimg)
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[in] cd_file file name of one file composing mpp domain
+ !> @param[in] td_var variable structure
+ !> @param[in] id_niproc number of processors following i
+ !> @param[in] id_njproc number of processors following j
+ !> @param[in] id_nproc total number of processors
+ !> @param[in] id_preci i-direction overlap region
+ !> @param[in] id_precj j-direction overlap region
+ !> @param[in] cd_type type of the files (cdf, cdf4, dimg)
+ !> @param[in] id_perio NEMO periodicity index
+ !> @param[in] id_pivot NEMO pivot point index F(0),T(1)
!> @return mpp structure
!-------------------------------------------------------------------
- !> @code
TYPE(TMPP) FUNCTION mpp__init_var( cd_file, td_var, &
& id_niproc, id_njproc, id_nproc,&
- & id_preci, id_precj, cd_type )
+ & id_preci, id_precj, cd_type, &
+ & id_perio, id_pivot )
IMPLICIT NONE
! Argument
@@ -682,16 +868,22 @@
INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
! local variable
- INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask
+ INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_mask
!----------------------------------------------------------------
IF( ASSOCIATED(td_var%d_value) )THEN
- ALLOCATE( il_mask(td_var%t_dim(1)%i_len, td_var%t_dim(2)%i_len) )
- il_mask(:,:)=var_get_mask(td_var)
+ ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
+ & td_var%t_dim(2)%i_len, &
+ & td_var%t_dim(3)%i_len) )
+ il_mask(:,:,:)=var_get_mask(td_var)
- mpp__init_var=mpp_init( cd_file, il_mask(:,:), &
+ mpp__init_var=mpp_init( cd_file, il_mask(:,:,1), &
& id_niproc, id_njproc, id_nproc,&
- & id_preci, id_precj, cd_type )
+ & id_preci, id_precj, cd_type, &
+ & id_ew=td_var%i_ew, &
+ & id_perio=id_perio, id_pivot=id_pivot)
DEALLOCATE(il_mask)
@@ -701,31 +893,49 @@
END FUNCTION mpp__init_var
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a mpp structure,
- !> reading one restart dimg file, or some netcdf files.
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initalise a mpp structure given file structure.
!> @details
- !>
- !> @warning td_file should be not opened
- !>
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file strcuture
+ !> It reads restart dimg files, or some netcdf files.
+ !>
+ !> @warning
+ !> netcdf file must contains some attributes:
+ !> - DOMAIN_number_total
+ !> - DOMAIN_size_global
+ !> - DOMAIN_number
+ !> - DOMAIN_position_first
+ !> - DOMAIN_position_last
+ !> - DOMAIN_halo_size_start
+ !> - DOMAIN_halo_size_end
+ !> or the file is assume to be no mpp file.
+ !>
+ !>
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file strcuture
+ !> @param[in] id_ew east-west overlap
+ !> @param[in] id_perio NEMO periodicity index
+ !> @param[in] id_pivot NEMO pivot point index F(0),T(1)
!> @return mpp structure
!-------------------------------------------------------------------
- ! @code
- TYPE(TMPP) FUNCTION mpp__init_read( td_file )
+ TYPE(TMPP) FUNCTION mpp__init_file( td_file, id_ew, id_perio, id_pivot )
IMPLICIT NONE
! Argument
TYPE(TFILE), INTENT(IN) :: td_file
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
! local variable
TYPE(TMPP) :: tl_mpp
+
TYPE(TFILE) :: tl_file
+
TYPE(TDIM) :: tl_dim
+
TYPE(TATT) :: tl_att
+
INTEGER(i4) :: il_nproc
INTEGER(i4) :: il_attid
@@ -737,5 +947,5 @@
! clean mpp
- CALL mpp_clean(mpp__init_read)
+ CALL mpp_clean(mpp__init_file)
! check file type
@@ -743,6 +953,5 @@
CASE('cdf')
! need to read all file to get domain decomposition
-
- tl_file=td_file
+ tl_file=file_copy(td_file)
! open file
@@ -750,5 +959,5 @@
! read first file domain decomposition
- tl_mpp=mpp__init_read_cdf(tl_file)
+ tl_mpp=mpp__init_file_cdf(tl_file)
! get number of processor/file to be read
@@ -779,19 +988,19 @@
! read domain decomposition
- tl_mpp = mpp__init_read_cdf(tl_file)
+ tl_mpp = mpp__init_file_cdf(tl_file)
IF( ji == 1 )THEN
- mpp__init_read=tl_mpp
+ mpp__init_file=mpp_copy(tl_mpp)
ELSE
- IF( ANY( mpp__init_read%t_dim(1:2)%i_len /= &
+ IF( ANY( mpp__init_file%t_dim(1:2)%i_len /= &
tl_mpp%t_dim(1:2)%i_len) )THEN
- CALL logger_error("INIT READ: dimension from file "//&
+ CALL logger_error("MPP INIT READ: dimension from file "//&
& TRIM(tl_file%c_name)//" and mpp strcuture "//&
- & TRIM(mpp__init_read%c_name)//"differ ")
+ & TRIM(mpp__init_file%c_name)//"differ ")
ELSE
! add processor to mpp strcuture
- CALL mpp__add_proc(mpp__init_read, tl_mpp%t_proc(1))
+ CALL mpp__add_proc(mpp__init_file, tl_mpp%t_proc(1))
ENDIF
@@ -802,74 +1011,84 @@
ENDDO
- IF( mpp__init_read%i_nproc /= il_nproc )THEN
- CALL logger_error("INIT READ: some processors can't be added &
+ IF( mpp__init_file%i_nproc /= il_nproc )THEN
+ CALL logger_error("MPP INIT READ: some processors can't be added &
& to mpp structure")
ENDIF
ELSE
- mpp__init_read=tl_mpp
+ mpp__init_file=mpp_copy(tl_mpp)
ENDIF
! mpp type
- mpp__init_read%c_type=TRIM(td_file%c_type)
+ mpp__init_file%c_type=TRIM(td_file%c_type)
! mpp domain type
- CALL mpp_get_dom(mpp__init_read)
+ CALL mpp_get_dom(mpp__init_file)
! create some attributes for domain decomposition (use with dimg file)
- tl_att=att_init( "DOMAIN_number_total", mpp__init_read%i_nproc )
- CALL mpp_add_att(mpp__init_read, tl_att)
-
- tl_att=att_init( "DOMAIN_I_position_first", mpp__init_read%t_proc(:)%i_impp )
- CALL mpp_add_att(mpp__init_read, tl_att)
-
- tl_att=att_init( "DOMAIN_J_position_first", mpp__init_read%t_proc(:)%i_jmpp )
- CALL mpp_add_att(mpp__init_read, tl_att)
-
- tl_att=att_init( "DOMAIN_I_position_last", mpp__init_read%t_proc(:)%i_lci )
- CALL mpp_add_att(mpp__init_read, tl_att)
-
- tl_att=att_init( "DOMAIN_J_position_last", mpp__init_read%t_proc(:)%i_lcj )
- CALL mpp_add_att(mpp__init_read, tl_att)
-
- tl_att=att_init( "DOMAIN_I_halo_size_start", mpp__init_read%t_proc(:)%i_ldi )
- CALL mpp_add_att(mpp__init_read, tl_att)
-
- tl_att=att_init( "DOMAIN_J_halo_size_start", mpp__init_read%t_proc(:)%i_ldj )
- CALL mpp_add_att(mpp__init_read, tl_att)
-
- tl_att=att_init( "DOMAIN_I_halo_size_end", mpp__init_read%t_proc(:)%i_lei )
- CALL mpp_add_att(mpp__init_read, tl_att)
-
- tl_att=att_init( "DOMAIN_J_halo_size_end", mpp__init_read%t_proc(:)%i_lej )
- CALL mpp_add_att(mpp__init_read, tl_att)
+ tl_att=att_init( "DOMAIN_number_total", mpp__init_file%i_nproc )
+ CALL mpp_add_att(mpp__init_file, tl_att)
+
+ tl_att=att_init( "DOMAIN_I_position_first", mpp__init_file%t_proc(:)%i_impp )
+ CALL mpp_add_att(mpp__init_file, tl_att)
+
+ tl_att=att_init( "DOMAIN_J_position_first", mpp__init_file%t_proc(:)%i_jmpp )
+ CALL mpp_add_att(mpp__init_file, tl_att)
+
+ tl_att=att_init( "DOMAIN_I_position_last", mpp__init_file%t_proc(:)%i_lci )
+ CALL mpp_add_att(mpp__init_file, tl_att)
+
+ tl_att=att_init( "DOMAIN_J_position_last", mpp__init_file%t_proc(:)%i_lcj )
+ CALL mpp_add_att(mpp__init_file, tl_att)
+
+ tl_att=att_init( "DOMAIN_I_halo_size_start", mpp__init_file%t_proc(:)%i_ldi )
+ CALL mpp_add_att(mpp__init_file, tl_att)
+
+ tl_att=att_init( "DOMAIN_J_halo_size_start", mpp__init_file%t_proc(:)%i_ldj )
+ CALL mpp_add_att(mpp__init_file, tl_att)
+
+ tl_att=att_init( "DOMAIN_I_halo_size_end", mpp__init_file%t_proc(:)%i_lei )
+ CALL mpp_add_att(mpp__init_file, tl_att)
+
+ tl_att=att_init( "DOMAIN_J_halo_size_end", mpp__init_file%t_proc(:)%i_lej )
+ CALL mpp_add_att(mpp__init_file, tl_att)
+ ! clean
+ CALL mpp_clean(tl_mpp)
+ CALL att_clean(tl_att)
CASE('dimg')
! domain decomposition could be read in one file
- tl_file=td_file
+ tl_file=file_copy(td_file)
! open file
+ CALL logger_debug("MPP INIT READ: open file "//TRIM(tl_file%c_name))
CALL iom_open(tl_file)
+ CALL logger_debug("MPP INIT READ: read mpp structure ")
! read mpp structure
- mpp__init_read=mpp__init_read_rstdimg(tl_file)
+ mpp__init_file=mpp__init_file_rstdimg(tl_file)
! mpp type
- mpp__init_read%c_type=TRIM(td_file%c_type)
+ mpp__init_file%c_type=TRIM(td_file%c_type)
! mpp domain type
- CALL mpp_get_dom(mpp__init_read)
+ CALL logger_debug("MPP INIT READ: mpp_get_dom ")
+ CALL mpp_get_dom(mpp__init_file)
! get processor size
- DO ji=1,mpp__init_read%i_nproc
-
- il_shape(:)=mpp_get_proc_size( mpp__init_read, ji )
+ CALL logger_debug("MPP INIT READ: get processor size ")
+ DO ji=1,mpp__init_file%i_nproc
+
+ il_shape(:)=mpp_get_proc_size( mpp__init_file, ji )
tl_dim=dim_init('X',il_shape(1))
- CALL file_add_dim(mpp__init_read%t_proc(ji), tl_dim)
+ CALL file_add_dim(mpp__init_file%t_proc(ji), tl_dim)
tl_dim=dim_init('Y',il_shape(2))
- CALL file_add_dim(mpp__init_read%t_proc(ji), tl_dim)
+ CALL file_add_dim(mpp__init_file%t_proc(ji), tl_dim)
+
+ ! clean
+ CALL dim_clean(tl_dim)
ENDDO
@@ -879,10 +1098,30 @@
CASE DEFAULT
- CALL logger_error("INIT READ: invalid type for file "//&
+ CALL logger_error("MPP INIT READ: invalid type for file "//&
& TRIM(tl_file%c_name))
END SELECT
- END FUNCTION mpp__init_read
- ! @endcode
+ ! east west overlap
+ IF( PRESENT(id_ew) ) mpp__init_file%i_ew=id_ew
+ ! NEMO periodicity
+ IF( PRESENT(id_perio) )THEN
+ mpp__init_file%i_perio= id_perio
+ SELECT CASE(id_perio)
+ CASE(3,4)
+ mpp__init_file%i_pivot=1
+ CASE(5,6)
+ mpp__init_file%i_pivot=0
+ CASE DEFAULT
+ mpp__init_file%i_pivot=1
+ END SELECT
+ ENDIF
+
+ IF( PRESENT(id_pivot) ) mpp__init_file%i_pivot= id_pivot
+
+ ! clean
+ CALL file_clean(tl_file)
+
+ CALL logger_debug("MPP INIT READ: fin init_read ")
+ END FUNCTION mpp__init_file
!-------------------------------------------------------------------
!> @brief This function initalise a mpp structure,
@@ -892,11 +1131,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file strcuture
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] td_file file strcuture
!> @return mpp structure
!-------------------------------------------------------------------
- ! @code
- TYPE(TMPP) FUNCTION mpp__init_read_cdf( td_file )
+ TYPE(TMPP) FUNCTION mpp__init_file_cdf( td_file )
IMPLICIT NONE
@@ -906,12 +1144,16 @@
! local variable
INTEGER(i4) :: il_attid ! attribute id
+
LOGICAL :: ll_exist
LOGICAL :: ll_open
TYPE(TATT) :: tl_att
+
+ TYPE(TDIM) :: tl_dim
+
TYPE(TFILE) :: tl_proc
!----------------------------------------------------------------
- CALL logger_trace(" INIT READ: netcdf file "//TRIM(td_file%c_name))
+ CALL logger_trace("MPP INIT READ: netcdf file "//TRIM(td_file%c_name))
INQUIRE( FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open )
@@ -921,13 +1163,13 @@
IF( td_file%i_id == 0 )THEN
CALL logger_info(" id "//TRIM(fct_str(td_file%i_id)))
- CALL logger_error("INIT READ: netcdf file "//TRIM(td_file%c_name)//&
+ CALL logger_error("MPP INIT READ: netcdf file "//TRIM(td_file%c_name)//&
& " not opened")
ELSE
! get mpp name
- mpp__init_read_cdf%c_name=TRIM( file_rename(td_file%c_name) )
+ mpp__init_file_cdf%c_name=TRIM( file_rename(td_file%c_name) )
! add type
- mpp__init_read_cdf%c_type="cdf"
+ mpp__init_file_cdf%c_type="cdf"
! global domain size
@@ -937,22 +1179,24 @@
ENDIF
IF( il_attid /= 0 )THEN
- mpp__init_read_cdf%t_dim(1)= &
- & dim_init('X',INT(td_file%t_att(il_attid)%d_value(1)))
- mpp__init_read_cdf%t_dim(2)= &
- & dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2)))
- ELSE
- mpp__init_read_cdf%t_dim(1)= &
- & dim_init( td_file%t_dim(1)%c_name, td_file%t_dim(1)%i_len)
- mpp__init_read_cdf%t_dim(2)= &
- & dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len)
-
- ENDIF
- mpp__init_read_cdf%t_dim(3)= &
- & dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(1)%i_len)
- mpp__init_read_cdf%t_dim(4)= &
- & dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(2)%i_len)
+ tl_dim=dim_init('X',INT(td_file%t_att(il_attid)%d_value(1)))
+ CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
+
+ tl_dim=dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2)))
+ CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
+ ELSE ! assume only one file (not mpp)
+ tl_dim=dim_init( td_file%t_dim(1)%c_name, td_file%t_dim(1)%i_len)
+ CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
+
+ tl_dim=dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len)
+ CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
+ ENDIF
+ tl_dim=dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(3)%i_len)
+ CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
+
+ tl_dim=dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(4)%i_len)
+ CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
! initialise file/processor
- tl_proc=td_file
+ tl_proc=file_copy(td_file)
! processor id
@@ -968,5 +1212,5 @@
! processor dimension
- tl_proc%t_dim(:)=td_file%t_dim(:)
+ tl_proc%t_dim(:)=dim_copy(td_file%t_dim(:))
! DOMAIN_position_first
@@ -992,6 +1236,6 @@
tl_proc%i_lcj = INT(td_file%t_att(il_attid)%d_value(2)) + tl_proc%i_jmpp
ELSE
- tl_proc%i_lci = mpp__init_read_cdf%t_dim(1)%i_len
- tl_proc%i_lcj = mpp__init_read_cdf%t_dim(2)%i_len
+ tl_proc%i_lci = mpp__init_file_cdf%t_dim(1)%i_len
+ tl_proc%i_lcj = mpp__init_file_cdf%t_dim(2)%i_len
ENDIF
@@ -1018,11 +1262,11 @@
tl_proc%i_lej = INT(td_file%t_att(il_attid)%d_value(2))
ELSE
- tl_proc%i_lei = mpp__init_read_cdf%t_dim(1)%i_len
- tl_proc%i_lej = mpp__init_read_cdf%t_dim(2)%i_len
+ tl_proc%i_lei = mpp__init_file_cdf%t_dim(1)%i_len
+ tl_proc%i_lej = mpp__init_file_cdf%t_dim(2)%i_len
ENDIF
! add attributes
tl_att=att_init( "DOMAIN_size_global", &
- & mpp__init_read_cdf%t_dim(:)%i_len)
+ & mpp__init_file_cdf%t_dim(:)%i_len)
CALL file_move_att(tl_proc, tl_att)
@@ -1047,16 +1291,18 @@
! add processor to mpp structure
- CALL mpp__add_proc(mpp__init_read_cdf, tl_proc)
-
+ CALL mpp__add_proc(mpp__init_file_cdf, tl_proc)
+
+ ! clean
+ CALL file_clean(tl_proc)
+ CALL att_clean(tl_att)
ENDIF
ELSE
- CALL logger_error("INIT READ: netcdf file "//TRIM(td_file%c_name)//&
+ CALL logger_error("MPP INIT READ: netcdf file "//TRIM(td_file%c_name)//&
& " do not exist")
ENDIF
- END FUNCTION mpp__init_read_cdf
- ! @endcode
+ END FUNCTION mpp__init_file_cdf
!-------------------------------------------------------------------
!> @brief This function initalise a mpp structure,
@@ -1066,11 +1312,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_file : file strcuture
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file file strcuture
!> @return mpp structure
!-------------------------------------------------------------------
- ! @code
- TYPE(TMPP) FUNCTION mpp__init_read_rstdimg( td_file )
+ TYPE(TMPP) FUNCTION mpp__init_file_rstdimg( td_file )
IMPLICIT NONE
@@ -1079,20 +1324,21 @@
! local variable
- INTEGER(i4) :: il_status
- INTEGER(i4) :: il_recl ! record length
- INTEGER(i4) :: il_nx, il_ny, il_nz ! x,y,z dimension
- INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d ! number of 0/1/2/3D variables
- INTEGER(i4) :: il_iglo, il_jglo ! domain global size
- INTEGER(i4) :: il_rhd ! record of the header infos
- INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition
- INTEGER(i4) :: il_area ! domain index
-
- LOGICAL :: ll_exist
- LOGICAL :: ll_open
+ INTEGER(i4) :: il_status
+ INTEGER(i4) :: il_recl ! record length
+ INTEGER(i4) :: il_nx, il_ny, il_nz ! x,y,z dimension
+ INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d ! number of 0/1/2/3D variables
+ INTEGER(i4) :: il_iglo, il_jglo ! domain global size
+ INTEGER(i4) :: il_rhd ! record of the header infos
+ INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition
+ INTEGER(i4) :: il_area ! domain index
+
+ LOGICAL :: ll_exist
+ LOGICAL :: ll_open
CHARACTER(LEN=lc) :: cl_file
- TYPE(TDIM) :: tl_dim ! dimension structure
- TYPE(TATT) :: tl_att
+ TYPE(TDIM) :: tl_dim ! dimension structure
+ TYPE(TATT) :: tl_att
+ TYPE(TFILE) :: tl_proc
! loop indices
@@ -1104,5 +1350,5 @@
IF( .NOT. ll_open )THEN
- CALL logger_error("INIT READ: dimg file "//TRIM(td_file%c_name)//&
+ CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//&
& " not opened")
ELSE
@@ -1118,22 +1364,35 @@
CALL fct_err(il_status)
IF( il_status /= 0 )THEN
- CALL logger_error("INIT READ: read first line header of "//&
+ CALL logger_error("MPP INIT READ: read first line header of "//&
& TRIM(td_file%c_name))
ENDIF
! get mpp name
- mpp__init_read_rstdimg%c_name=TRIM( file_rename(td_file%c_name) )
+ mpp__init_file_rstdimg%c_name=TRIM( file_rename(td_file%c_name) )
+
+ ! add type
+ mpp__init_file_rstdimg%c_type="dimg"
! number of processors to be read
- mpp__init_read_rstdimg%i_nproc = il_pnij
- mpp__init_read_rstdimg%i_niproc = il_pni
- mpp__init_read_rstdimg%i_njproc = il_pnj
-
- IF( ASSOCIATED(mpp__init_read_rstdimg%t_proc) )THEN
- DEALLOCATE(mpp__init_read_rstdimg%t_proc)
- ENDIF
- ALLOCATE( mpp__init_read_rstdimg%t_proc(il_pnij) , stat=il_status )
+ mpp__init_file_rstdimg%i_nproc = il_pnij
+ mpp__init_file_rstdimg%i_niproc = il_pni
+ mpp__init_file_rstdimg%i_njproc = il_pnj
+
+ IF( ASSOCIATED(mpp__init_file_rstdimg%t_proc) )THEN
+ CALL file_clean(mpp__init_file_rstdimg%t_proc(:))
+ DEALLOCATE(mpp__init_file_rstdimg%t_proc)
+ ENDIF
+ ALLOCATE( mpp__init_file_rstdimg%t_proc(il_pnij) , stat=il_status )
+
+ tl_proc=file_copy(td_file)
+ ! remove dimension from file
+ CALL dim_clean(tl_proc%t_dim(:))
+ ! initialise file/processors
+ DO ji=1,mpp__init_file_rstdimg%i_nproc
+ mpp__init_file_rstdimg%t_proc(ji)=file_copy(tl_proc)
+ ENDDO
+
IF( il_status /= 0 )THEN
- CALL logger_error("INIT READ: not enough space to read domain &
+ CALL logger_error("MPP INIT READ: not enough space to read domain &
& decomposition in file "//TRIM(td_file%c_name))
ENDIF
@@ -1148,132 +1407,135 @@
& il_area, &
& il_iglo, il_jglo, &
- & mpp__init_read_rstdimg%t_proc(:)%i_lci, &
- & mpp__init_read_rstdimg%t_proc(:)%i_lcj, &
- & mpp__init_read_rstdimg%t_proc(:)%i_ldi, &
- & mpp__init_read_rstdimg%t_proc(:)%i_ldj, &
- & mpp__init_read_rstdimg%t_proc(:)%i_lei, &
- & mpp__init_read_rstdimg%t_proc(:)%i_lej, &
- & mpp__init_read_rstdimg%t_proc(:)%i_impp, &
- & mpp__init_read_rstdimg%t_proc(:)%i_jmpp
+ & mpp__init_file_rstdimg%t_proc(:)%i_lci, &
+ & mpp__init_file_rstdimg%t_proc(:)%i_lcj, &
+ & mpp__init_file_rstdimg%t_proc(:)%i_ldi, &
+ & mpp__init_file_rstdimg%t_proc(:)%i_ldj, &
+ & mpp__init_file_rstdimg%t_proc(:)%i_lei, &
+ & mpp__init_file_rstdimg%t_proc(:)%i_lej, &
+ & mpp__init_file_rstdimg%t_proc(:)%i_impp, &
+ & mpp__init_file_rstdimg%t_proc(:)%i_jmpp
CALL fct_err(il_status)
IF( il_status /= 0 )THEN
- CALL logger_error("INIT READ: read first line of "//&
+ CALL logger_error("MPP INIT READ: read first line of "//&
& TRIM(td_file%c_name))
ENDIF
- ! mpp dimension
+ ! global domain size
tl_dim=dim_init('X',il_iglo)
- CALL mpp_add_dim(mpp__init_read_rstdimg,tl_dim)
+ CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim)
tl_dim=dim_init('Y',il_jglo)
- CALL mpp_add_dim(mpp__init_read_rstdimg,tl_dim)
-
- DO ji=1,mpp__init_read_rstdimg%i_nproc
+ CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim)
+
+ tl_dim=dim_init('Z',il_nz)
+ CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim)
+
+ DO ji=1,mpp__init_file_rstdimg%i_nproc
! get file name
cl_file = file_rename(td_file%c_name,ji)
- mpp__init_read_rstdimg%t_proc(ji)%c_name = TRIM(cl_file)
+ mpp__init_file_rstdimg%t_proc(ji)%c_name = TRIM(cl_file)
! update processor id
- mpp__init_read_rstdimg%t_proc(ji)%i_pid=ji
+ mpp__init_file_rstdimg%t_proc(ji)%i_pid=ji
! add attributes
tl_att=att_init( "DOMAIN_number", ji )
- CALL file_move_att(mpp__init_read_rstdimg%t_proc(ji), tl_att)
+ CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)
tl_att=att_init( "DOMAIN_position_first", &
- & (/mpp__init_read_rstdimg%t_proc(ji)%i_impp, &
- & mpp__init_read_rstdimg%t_proc(ji)%i_jmpp /) )
- CALL file_move_att(mpp__init_read_rstdimg%t_proc(ji), tl_att)
+ & (/mpp__init_file_rstdimg%t_proc(ji)%i_impp, &
+ & mpp__init_file_rstdimg%t_proc(ji)%i_jmpp /) )
+ CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)
tl_att=att_init( "DOMAIN_position_last", &
- & (/mpp__init_read_rstdimg%t_proc(ji)%i_lci, &
- & mpp__init_read_rstdimg%t_proc(ji)%i_lcj /) )
- CALL file_move_att(mpp__init_read_rstdimg%t_proc(ji), tl_att)
+ & (/mpp__init_file_rstdimg%t_proc(ji)%i_lci, &
+ & mpp__init_file_rstdimg%t_proc(ji)%i_lcj /) )
+ CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)
tl_att=att_init( "DOMAIN_halo_size_start", &
- & (/mpp__init_read_rstdimg%t_proc(ji)%i_ldi, &
- & mpp__init_read_rstdimg%t_proc(ji)%i_ldj /) )
- CALL file_move_att(mpp__init_read_rstdimg%t_proc(ji), tl_att)
+ & (/mpp__init_file_rstdimg%t_proc(ji)%i_ldi, &
+ & mpp__init_file_rstdimg%t_proc(ji)%i_ldj /) )
+ CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)
tl_att=att_init( "DOMAIN_halo_size_end", &
- & (/mpp__init_read_rstdimg%t_proc(ji)%i_lei, &
- & mpp__init_read_rstdimg%t_proc(ji)%i_lej /) )
- CALL file_move_att(mpp__init_read_rstdimg%t_proc(ji), tl_att)
+ & (/mpp__init_file_rstdimg%t_proc(ji)%i_lei, &
+ & mpp__init_file_rstdimg%t_proc(ji)%i_lej /) )
+ CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)
ENDDO
-
+
! add type
- mpp__init_read_rstdimg%t_proc(:)%c_type="dimg"
+ mpp__init_file_rstdimg%t_proc(:)%c_type="dimg"
! add attributes
tl_att=att_init( "DOMAIN_size_global", &
- & mpp__init_read_rstdimg%t_dim(:)%i_len)
- CALL mpp_move_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%t_dim(:)%i_len)
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_number_total", &
- & mpp__init_read_rstdimg%i_nproc )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%i_nproc )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_I_number_total", &
- & mpp__init_read_rstdimg%i_niproc )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%i_niproc )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_J_number_total", &
- & mpp__init_read_rstdimg%i_njproc )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%i_njproc )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_I_position_first", &
- & mpp__init_read_rstdimg%t_proc(:)%i_impp )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%t_proc(:)%i_impp )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_J_position_first", &
- & mpp__init_read_rstdimg%t_proc(:)%i_jmpp )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%t_proc(:)%i_jmpp )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_I_position_last", &
- & mpp__init_read_rstdimg%t_proc(:)%i_lci )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%t_proc(:)%i_lci )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_J_position_last", &
- & mpp__init_read_rstdimg%t_proc(:)%i_lcj )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%t_proc(:)%i_lcj )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_I_halo_size_start", &
- & mpp__init_read_rstdimg%t_proc(:)%i_ldi )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%t_proc(:)%i_ldi )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_J_halo_size_start", &
- & mpp__init_read_rstdimg%t_proc(:)%i_ldj )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%t_proc(:)%i_ldj )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_I_halo_size_end", &
- & mpp__init_read_rstdimg%t_proc(:)%i_lei )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%t_proc(:)%i_lei )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
tl_att=att_init( "DOMAIN_J_halo_size_end", &
- & mpp__init_read_rstdimg%t_proc(:)%i_lej )
- CALL mpp_add_att(mpp__init_read_rstdimg, tl_att)
+ & mpp__init_file_rstdimg%t_proc(:)%i_lej )
+ CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
+
+ ! clean
+ CALL dim_clean(tl_dim)
+ CALL att_clean(tl_att)
ENDIF
ELSE
- CALL logger_error("INIT READ: dimg file "//TRIM(td_file%c_name)//&
+ CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//&
& " do not exist")
ENDIF
- END FUNCTION mpp__init_read_rstdimg
- ! @endcode
+ END FUNCTION mpp__init_file_rstdimg
!-------------------------------------------------------------------
!> @brief This function check if variable and mpp structure use same
!> dimension.
!
- !> @details
- !
!> @author J.Paul
!> - Nov, 2013- Initial Version
!
- !> @param[in] td_mpp : mpp structure
- !> @param[in] td_proc : processor structure
+ !> @param[in] td_mpp mpp structure
+ !> @param[in] td_proc processor structure
!> @return dimension of processor and mpp structure agree (or not)
!-------------------------------------------------------------------
- ! @code
LOGICAL FUNCTION mpp__check_proc_dim(td_mpp, td_proc)
IMPLICIT NONE
@@ -1301,5 +1563,5 @@
mpp__check_proc_dim=.FALSE.
- CALL logger_error( " CHECK DIM: processor and mpp dimension differ" )
+ CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" )
ENDIF
@@ -1312,5 +1574,5 @@
mpp__check_proc_dim=.FALSE.
- CALL logger_error( " CHECK DIM: processor and mpp dimension differ" )
+ CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" )
ENDIF
@@ -1318,20 +1580,14 @@
END FUNCTION mpp__check_proc_dim
- ! @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine add variable to mpp structure.
- !>
- !> @detail
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] td_var : variable strcuture
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> This subroutine add variable in all files of mpp structure.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] td_var variable strcuture
+ !-------------------------------------------------------------------
SUBROUTINE mpp_add_var( td_mpp, td_var )
IMPLICIT NONE
@@ -1350,11 +1606,6 @@
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
- CALL logger_error( "MPP ADD VAR: domain decomposition not define "//&
- & "for mpp "//TRIM(td_mpp%c_name))
-
- ELSEIF( td_mpp%i_ndim == 0 )THEN
-
- CALL logger_error( " MPP ADD VAR: no dimension define for "//&
- & " mpp strcuture "//TRIM(td_mpp%c_name))
+ CALL logger_error( "MPP ADD VAR: processor decomposition not "//&
+ & "define for mpp "//TRIM(td_mpp%c_name))
ELSE
@@ -1367,6 +1618,6 @@
il_varid=0
IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
- il_varid=var_get_id( td_mpp%t_proc(1)%t_var(:), &
- & td_var%c_name, td_var%c_stdname )
+ il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
+ & td_var%c_name, td_var%c_stdname )
ENDIF
@@ -1393,4 +1644,12 @@
IF( mpp__check_dim(td_mpp, td_var) )THEN
+ ! update dimension if need be
+ DO ji=1,ip_maxdim
+ IF( td_var%t_dim(ji)%l_use .AND. &
+ & .NOT. td_mpp%t_dim(ji)%l_use )THEN
+ CALL mpp_add_dim(td_mpp,td_var%t_dim(ji))
+ ENDIF
+ ENDDO
+
! add variable in each processor
DO ji=1,td_mpp%i_nproc
@@ -1401,4 +1660,6 @@
CALL file_add_var(td_mpp%t_proc(ji), tl_var)
+ ! clean
+ CALL var_clean(tl_var)
ENDDO
@@ -1409,20 +1670,16 @@
END SUBROUTINE mpp_add_var
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function extract from variable structure, part that will
+ !-------------------------------------------------------------------
+ !> @brief This function extract, from variable structure, part that will
!> be written in processor id_procid.
!
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[in] td_var : variable structure
- !> @param[in] id_procid : processor id
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_mpp mpp structure
+ !> @param[in] td_var variable structure
+ !> @param[in] id_procid processor id
!> @return variable structure
!-------------------------------------------------------------------
- ! @code
TYPE(TVAR) FUNCTION mpp__split_var(td_mpp, td_var, id_procid)
IMPLICIT NONE
@@ -1444,45 +1701,76 @@
! copy mpp
- mpp__split_var=td_var
-
- ! remove value over global domain from pointer
- CALL var_del_value( mpp__split_var )
-
- ! get processor dimension
- il_size(:)=mpp_get_proc_size( td_mpp, id_procid )
-
- ! define new dimension in variable structure
- IF( td_var%t_dim(1)%l_use )THEN
- tl_dim=dim_init( TRIM(td_var%t_dim(1)%c_name), il_size(1) )
- CALL var_move_dim( mpp__split_var, tl_dim )
- ENDIF
- IF( td_var%t_dim(2)%l_use )THEN
- tl_dim=dim_init( TRIM(td_var%t_dim(2)%c_name), il_size(2) )
- CALL var_move_dim( mpp__split_var, tl_dim )
- ENDIF
-
- ! get processor indices
- il_ind(:)=mpp_get_proc_index( td_mpp, id_procid )
- il_i1 = il_ind(1)
- il_i2 = il_ind(2)
- il_j1 = il_ind(3)
- il_j2 = il_ind(4)
-
- IF( .NOT. td_var%t_dim(1)%l_use )THEN
- il_i1=1
- il_i2=1
- ENDIF
-
- IF( .NOT. td_var%t_dim(2)%l_use )THEN
- il_j1=1
- il_j2=1
- ENDIF
-
- ! add variable value on processor
- CALL var_add_value( mpp__split_var, &
- & td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) )
+ mpp__split_var=var_copy(td_var)
+
+ IF( ASSOCIATED(td_var%d_value) )THEN
+ ! remove value over global domain from pointer
+ CALL var_del_value( mpp__split_var )
+
+ ! get processor dimension
+ il_size(:)=mpp_get_proc_size( td_mpp, id_procid )
+
+ ! define new dimension in variable structure
+ IF( td_var%t_dim(1)%l_use )THEN
+ tl_dim=dim_init( TRIM(td_var%t_dim(1)%c_name), il_size(1) )
+ CALL var_move_dim( mpp__split_var, tl_dim )
+ ENDIF
+ IF( td_var%t_dim(2)%l_use )THEN
+ tl_dim=dim_init( TRIM(td_var%t_dim(2)%c_name), il_size(2) )
+ CALL var_move_dim( mpp__split_var, tl_dim )
+ ENDIF
+
+ ! get processor indices
+ il_ind(:)=mpp_get_proc_index( td_mpp, id_procid )
+ il_i1 = il_ind(1)
+ il_i2 = il_ind(2)
+ il_j1 = il_ind(3)
+ il_j2 = il_ind(4)
+
+ IF( .NOT. td_var%t_dim(1)%l_use )THEN
+ il_i1=1
+ il_i2=1
+ ENDIF
+
+ IF( .NOT. td_var%t_dim(2)%l_use )THEN
+ il_j1=1
+ il_j2=1
+ ENDIF
+
+ ! add variable value on processor
+ CALL var_add_value( mpp__split_var, &
+ & td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) )
+ ENDIF
END FUNCTION mpp__split_var
- !> @endcode
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine delete all variable in mpp strcuture.
+ !>
+ !> @author J.Paul
+ !> @date October, 2014 - Initial version
+ !>
+ !> @param[inout] td_mpp mpp strcuture
+ !-------------------------------------------------------------------
+ SUBROUTINE mpp__del_var_mpp( td_mpp )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), INTENT(INOUT) :: td_mpp
+
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ CALL logger_info( &
+ & "MPP CLEAN VAR: reset all variable "//&
+ & "in mpp strcuture "//TRIM(td_mpp%c_name) )
+
+ IF( ASSOCIATED(td_mpp%t_proc) )THEN
+ DO ji=td_mpp%t_proc(1)%i_nvar,1,-1
+ CALL mpp_del_var(td_mpp, td_mpp%t_proc(1)%t_var(ji))
+ ENDDO
+ ENDIF
+
+ END SUBROUTINE mpp__del_var_mpp
!-------------------------------------------------------------------
!> @brief
@@ -1490,15 +1778,10 @@
!> structure.
!>
- !> @detail
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] td_var : variable strcuture
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] td_var variable strcuture
+ !-------------------------------------------------------------------
SUBROUTINE mpp__del_var_str( td_mpp, td_var )
IMPLICIT NONE
@@ -1517,5 +1800,5 @@
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
- CALL logger_error( " DEL VAR: domain decomposition not define "//&
+ CALL logger_error( "MPP DEL VAR: domain decomposition not define "//&
& " in mpp strcuture "//TRIM(td_mpp%c_name))
@@ -1525,14 +1808,14 @@
il_varid = 0
IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
- il_varid=var_get_id( td_mpp%t_proc(1)%t_var(:), &
- & td_var%c_name, td_var%c_stdname )
+ il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
+ & td_var%c_name, td_var%c_stdname )
ENDIF
IF( il_varid == 0 )THEN
CALL logger_error( &
- & " DEL VAR: no variable "//TRIM(td_var%c_name)//&
+ & "MPP DEL VAR: no variable "//TRIM(td_var%c_name)//&
& ", in mpp structure "//TRIM(td_mpp%c_name) )
DO ji=1,td_mpp%t_proc(1)%i_nvar
- CALL logger_debug( " DEL VAR: in mpp structure : &
+ CALL logger_debug( "MPP DEL VAR: in mpp structure : &
& variable : "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)//&
& ", standard name "//&
@@ -1551,20 +1834,14 @@
ENDIF
END SUBROUTINE mpp__del_var_str
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine delete variable in mpp structure, given variable name.
!>
- !> @detail
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] cd_name: variable name
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] cd_name variable name
+ !-------------------------------------------------------------------
SUBROUTINE mpp__del_var_name( td_mpp, cd_name )
IMPLICIT NONE
@@ -1579,5 +1856,5 @@
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
- CALL logger_error( " DEL VAR: domain decomposition not define "//&
+ CALL logger_error( "MPP DEL VAR: domain decomposition not define "//&
& " in mpp strcuture "//TRIM(td_mpp%c_name))
@@ -1585,5 +1862,5 @@
IF( td_mpp%t_proc(1)%i_nvar == 0 )THEN
- CALL logger_debug( " DEL VAR NAME: no variable associated to mpp &
+ CALL logger_debug( "MPP DEL VAR NAME: no variable associated to mpp &
& structure "//TRIM(td_mpp%c_name) )
ELSE
@@ -1592,11 +1869,12 @@
il_varid=0
IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
- il_varid=var_get_id( td_mpp%t_proc(1)%t_var(:), &
- & cd_name )
- ENDIF
+ il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
+ & cd_name )
+ ENDIF
+
IF( il_varid == 0 )THEN
CALL logger_warn( &
- & "DEL VAR : there is no variable with name "//&
+ & "MPP DEL VAR : there is no variable with name "//&
& "or standard name "//TRIM(ADJUSTL(cd_name))//&
& " in mpp structure "//TRIM(td_mpp%c_name))
@@ -1611,22 +1889,14 @@
ENDIF
END SUBROUTINE mpp__del_var_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine overwrite variable in mpp structure.
!>
- !> @detail
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] td_var : variable structure
- !> @todo
- !> - voir si il ne faut pas redefinir (__copy) variable si elle vient de mpp
- !> exemple CALL mpp_move_var( td_mpp, td_mpp%t_proc()%t_var )
- !> remarque cas probabelement impossible puisque td_var doit avoir dim de td_mpp
- !-------------------------------------------------------------------
- !> @code
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE mpp_move_var( td_mpp, td_var )
IMPLICIT NONE
@@ -1639,5 +1909,5 @@
!----------------------------------------------------------------
! copy variable
- tl_var=td_var
+ tl_var=var_copy(td_var)
! remove processor
@@ -1647,4 +1917,7 @@
CALL mpp_add_var(td_mpp, tl_var)
+ ! clean
+ CALL var_clean(tl_var)
+
END SUBROUTINE mpp_move_var
!> @endcode
@@ -1653,16 +1926,13 @@
!> This subroutine add processor to mpp structure.
!>
- !> @detail
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] td_proc : processor strcuture
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] td_proc processor strcuture
!
!> @todo
!> - check proc type
!-------------------------------------------------------------------
- !> @code
SUBROUTINE mpp__add_proc( td_mpp, td_proc )
IMPLICIT NONE
@@ -1698,10 +1968,10 @@
CALL logger_error( &
- & " ADD PROC: processor "//TRIM(fct_str(td_proc%i_pid))//&
+ & "MPP ADD PROC: processor "//TRIM(fct_str(td_proc%i_pid))//&
& ", already in mpp structure " )
ELSE
-
- CALL logger_trace("ADD PROC: add processor "//&
+
+ CALL logger_trace("MPP ADD PROC: add processor "//&
& TRIM(fct_str(td_mpp%i_nproc+1))//" in mpp structure")
@@ -1716,16 +1986,17 @@
IF(il_status /= 0 )THEN
- CALL logger_error( " ADD PROC: not enough space to put processor &
+ CALL logger_error( "MPP ADD PROC: not enough space to put processor &
& in mpp structure")
ELSE
! save temporary mpp structure
- tl_proc(:)=td_mpp%t_proc(:)
-
- DEALLOCATE( td_mpp%t_proc )
+ tl_proc(:)=file_copy(td_mpp%t_proc(:))
+
+ CALL file_clean( td_mpp%t_proc(:) )
+ DEALLOCATE(td_mpp%t_proc)
ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc+1), stat=il_status)
IF(il_status /= 0 )THEN
- CALL logger_error( " ADD PROC: not enough space to put "//&
+ CALL logger_error( "MPP ADD PROC: not enough space to put "//&
& "processor in mpp structure ")
@@ -1733,11 +2004,13 @@
! copy processor in mpp before
- ! processor with lesser id than new processor
- td_mpp%t_proc( 1:il_procid ) = tl_proc( 1:il_procid )
+ ! processor with lower id than new processor
+ td_mpp%t_proc( 1:il_procid ) = file_copy(tl_proc( 1:il_procid ))
! processor with greater id than new processor
td_mpp%t_proc( il_procid+1 : td_mpp%i_nproc+1 ) = &
- & tl_proc( il_procid : td_mpp%i_nproc )
-
+ & file_copy(tl_proc( il_procid : td_mpp%i_nproc ))
+
+ ! clean
+ CALL file_clean(tl_proc(:))
DEALLOCATE(tl_proc)
ENDIF
@@ -1746,4 +2019,5 @@
! no processor in mpp structure
IF( ASSOCIATED(td_mpp%t_proc) )THEN
+ CALL file_clean(td_mpp%t_proc(:))
DEALLOCATE(td_mpp%t_proc)
ENDIF
@@ -1751,5 +2025,5 @@
IF(il_status /= 0 )THEN
- CALL logger_error( " ADD PROC: not enough space to put "//&
+ CALL logger_error( "MPP ADD PROC: not enough space to put "//&
& "processor in mpp structure " )
@@ -1759,10 +2033,10 @@
! check dimension
IF( ANY(td_mpp%t_dim(1:2)%i_len < td_proc%t_dim(1:2)%i_len) )THEN
- CALL logger_error( "ADD PROC: mpp structure and new processor "//&
+ CALL logger_error( "MPP ADD PROC: mpp structure and new processor "//&
& " dimension differ. ")
- CALL logger_debug("ADD PROC: mpp dimension ("//&
+ CALL logger_debug("MPP ADD PROC: mpp dimension ("//&
& TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
& TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")" )
- CALL logger_debug("ADD PROC: processor dimension ("//&
+ CALL logger_debug("MPP ADD PROC: processor dimension ("//&
& TRIM(fct_str(td_proc%t_dim(1)%i_len))//","//&
& TRIM(fct_str(td_proc%t_dim(2)%i_len))//")" )
@@ -1771,25 +2045,19 @@
! add new processor
- td_mpp%t_proc(td_mpp%i_nproc)=td_proc
+ td_mpp%t_proc(td_mpp%i_nproc)=file_copy(td_proc)
ENDIF
ENDIF
END SUBROUTINE mpp__add_proc
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine delete processor in mpp structure, given processor id.
!>
- !> @detail
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] id_procid : processor id
- !
- !> @todo check proc id exist
- !-------------------------------------------------------------------
- !> @code
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !>
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] id_procid processor id
+ !-------------------------------------------------------------------
SUBROUTINE mpp__del_proc_id( td_mpp, id_procid )
IMPLICIT NONE
@@ -1803,4 +2071,6 @@
INTEGER(i4), DIMENSION(1) :: il_ind
TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc
+
+ ! loop indices
!----------------------------------------------------------------
@@ -1808,14 +2078,16 @@
il_procid=il_ind(1)
IF( il_procid == 0 )THEN
- CALL logger_error("DEL PROC: no processor "//TRIM(fct_str(id_procid))//&
- & " associated to mpp structure")
+ CALL logger_error("MPP DEL PROC: no processor "//&
+ & TRIM(fct_str(id_procid))//&
+ & " associated to mpp structure")
ELSE
- CALL logger_trace("DEL PROC: remove processor "//TRIM(fct_str(id_procid)))
+ CALL logger_trace("DEL PROC: remove processor "//&
+ & TRIM(fct_str(id_procid)))
IF( td_mpp%i_nproc > 1 )THEN
ALLOCATE( tl_proc(td_mpp%i_nproc-1), stat=il_status )
IF(il_status /= 0 )THEN
- CALL logger_error( " DEL PROC: not enough space to put processor &
- & in temporary mpp structure")
+ CALL logger_error( "MPP DEL PROC: not enough space to put &
+ & processor in temporary mpp structure")
ELSE
@@ -1823,22 +2095,26 @@
! save temporary processor's mpp structure
IF( il_procid > 1 )THEN
- tl_proc(1:il_procid-1)=td_mpp%t_proc(1:il_procid-1)
+ tl_proc(1:il_procid-1)=file_copy(td_mpp%t_proc(1:il_procid-1))
ENDIF
- tl_proc(il_procid:)=td_mpp%t_proc(il_procid+1:)
+
+ IF( il_procid < td_mpp%i_nproc )THEN
+ tl_proc(il_procid:)=file_copy(td_mpp%t_proc(il_procid+1:))
+ ENDIF
! new number of processor in mpp
td_mpp%i_nproc=td_mpp%i_nproc-1
- DEALLOCATE( td_mpp%t_proc )
+ CALL file_clean( td_mpp%t_proc(:) )
+ DEALLOCATE(td_mpp%t_proc)
ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc), stat=il_status )
IF(il_status /= 0 )THEN
- CALL logger_error( " DEL PROC: not enough space to put processors &
- & in mpp structure " )
+ CALL logger_error( "MPP DEL PROC: not enough space &
+ & to put processors in mpp structure " )
ELSE
! copy processor in mpp before
- td_mpp%t_proc(:)=tl_proc(:)
+ td_mpp%t_proc(:)=file_copy(tl_proc(:))
! update processor id
@@ -1848,6 +2124,10 @@
ENDIF
ENDIF
+ ! clean
+ CALL file_clean( tl_proc(:) )
+ DEALLOCATE(tl_proc)
ELSE
- DEALLOCATE( td_mpp%t_proc )
+ CALL file_clean( td_mpp%t_proc(:) )
+ DEALLOCATE(td_mpp%t_proc)
! new number of processor in mpp
@@ -1856,5 +2136,4 @@
ENDIF
END SUBROUTINE mpp__del_proc_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -1862,15 +2141,10 @@
!> structure.
!>
- !> @detail
- !
- !> @author J.Paul
- !> @date Nov, 2013
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
!
!> @param[inout] td_mpp : mpp strcuture
!> @param[in] td_proc : file/processor structure
- !
- !> @todo check proc id exist
- !-------------------------------------------------------------------
- !> @code
+ !-------------------------------------------------------------------
SUBROUTINE mpp__del_proc_str( td_mpp, td_proc )
IMPLICIT NONE
@@ -1883,9 +2157,8 @@
CALL mpp__del_proc( td_mpp, td_proc%i_pid )
ELSE
- CALL logger_error("DEL PROC: processor not defined")
+ CALL logger_error("MPP DEL PROC: processor not defined")
ENDIF
END SUBROUTINE mpp__del_proc_str
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -1895,13 +2168,9 @@
!
!> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] id_procid : processor id
- !> @todo
- !> - voir si il ne faut pas redefinir (__copy) proc si il vient de mpp
- !> exemple CALL mpp_move_proc( td_mpp, td_mpp%t_proc )
- !-------------------------------------------------------------------
- !> @code
+ !> @date Nov, 2013 - Initial version
+ !
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] id_procid processor id
+ !-------------------------------------------------------------------
SUBROUTINE mpp__move_proc( td_mpp, td_proc )
IMPLICIT NONE
@@ -1918,21 +2187,15 @@
END SUBROUTINE mpp__move_proc
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine add a dimension structure in a mpp
!> structure.
!> Do not overwrite, if dimension already in mpp structure.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_mpp : mpp structure
- !> @param[in] td_dim : dimension structure
- !
- !> @todo
- !-------------------------------------------------------------------
- ! @code
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_mpp mpp structure
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
SUBROUTINE mpp_add_dim(td_mpp, td_dim)
IMPLICIT NONE
@@ -1942,47 +2205,52 @@
! local variable
- INTEGER(i4) :: il_dimid
+ INTEGER(i4) :: il_ind
! loop indices
- !----------------------------------------------------------------
- IF( td_mpp%i_ndim <= 4 )THEN
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ IF( td_mpp%i_ndim <= ip_maxdim )THEN
! check if dimension already in mpp structure
- il_dimid=dim_get_id(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname)
- IF( il_dimid /= 0 )THEN
-
- CALL logger_error( &
- & " ADD DIM: dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", already in mpp "//TRIM(td_mpp%c_name) )
+ il_ind=dim_get_index(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname)
+ IF( il_ind /= 0 )THEN
+
+ IF( td_mpp%t_dim(il_ind)%l_use )THEN
+ CALL logger_error( &
+ & "MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//&
+ & ", short name "//TRIM(td_dim%c_sname)//&
+ & ", already used in mpp "//TRIM(td_mpp%c_name) )
+ ELSE
+ ! replace dimension
+ td_mpp%t_dim(il_ind)=dim_copy(td_dim)
+ td_mpp%t_dim(il_ind)%i_id=il_ind
+ td_mpp%t_dim(il_ind)%l_use=.TRUE.
+ ENDIF
ELSE
- CALL logger_debug( &
- & " ADD DIM: add dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", in mpp "//TRIM(td_mpp%c_name) )
-
- IF( td_mpp%i_ndim == 4 )THEN
+ IF( td_mpp%i_ndim == ip_maxdim )THEN
+ CALL logger_error( &
+ & "MPP ADD DIM: can not add dimension "//TRIM(td_dim%c_name)//&
+ & ", short name "//TRIM(td_dim%c_sname)//&
+ & ", in mpp "//TRIM(td_mpp%c_name)//". Already "//&
+ & TRIM(fct_str(ip_maxdim))//" dimensions." )
+ ELSE
! search empty dimension
- il_dimid=dim_get_void_id(td_mpp%t_dim(:),TRIM(td_dim%c_name), &
- & TRIM(td_dim%c_sname))
- ! replace empty dimension
- td_mpp%t_dim(il_dimid)=td_dim
- td_mpp%t_dim(il_dimid)%i_id=il_dimid
- td_mpp%t_dim(il_dimid)%l_use=.TRUE.
- ELSE
- il_dimid=dim_get_void_id(td_mpp%t_dim(:),TRIM(td_dim%c_name), &
- & TRIM(td_dim%c_sname))
- ! add new dimension
- td_mpp%t_dim(il_dimid)=td_dim
- td_mpp%t_dim(il_dimid)%i_id=td_mpp%i_ndim+1
- td_mpp%t_dim(il_dimid)%l_use=.TRUE.
+ DO ji=1,ip_maxdim
+ IF( td_mpp%t_dim(ji)%i_id == 0 )THEN
+ il_ind=ji
+ EXIT
+ ENDIF
+ ENDDO
+
+ ! add new dimension
+ td_mpp%t_dim(il_ind)=dim_copy(td_dim)
! update number of attribute
td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use)
- ENDIF
-
- ! reorder dimension to ('x','y','z','t')
- CALL dim_reorder(td_mpp%t_dim)
+
+ td_mpp%t_dim(il_ind)%l_use=.TRUE.
+ td_mpp%t_dim(il_ind)%i_id=td_mpp%i_ndim
+ ENDIF
ENDIF
@@ -1990,25 +2258,19 @@
ELSE
CALL logger_error( &
- & " ADD DIM: too much dimension in mpp "//&
+ & "MPP ADD DIM: too much dimension in mpp "//&
& TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
ENDIF
END SUBROUTINE mpp_add_dim
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine delete a dimension structure in a mpp
!> structure.
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_mpp : mpp structure
- !> @param[in] td_dim : dimension structure
- !
- !> @todo
- !-------------------------------------------------------------------
- ! @code
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_mpp mpp structure
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
SUBROUTINE mpp_del_dim(td_mpp, td_dim)
IMPLICIT NONE
@@ -2019,97 +2281,68 @@
! local variable
INTEGER(i4) :: il_status
- INTEGER(i4) :: il_dimid
+ INTEGER(i4) :: il_ind
TYPE(TDIM), DIMENSION(:), ALLOCATABLE :: tl_dim
! loop indices
- !----------------------------------------------------------------
- IF( td_mpp%i_ndim <= 4 )THEN
-
- ! check if dimension already in mpp structure
- il_dimid=dim_get_id(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname)
- IF( il_dimid == 0 )THEN
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ ! check if dimension already in mpp structure
+ il_ind=dim_get_index(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname)
+ IF( il_ind == 0 )THEN
+
+ CALL logger_error( &
+ & "MPP DEL DIM: no dimension "//TRIM(td_dim%c_name)//&
+ & ", short name "//TRIM(td_dim%c_sname)//&
+ & ", in mpp "//TRIM(td_mpp%c_name) )
+
+ ELSE
+
+ ALLOCATE( tl_dim(td_mpp%i_ndim-1), stat=il_status )
+ IF(il_status /= 0 )THEN
CALL logger_error( &
- & " DEL DIM: no dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", in mpp "//TRIM(td_mpp%c_name) )
+ & "MPP DEL DIM: not enough space to put dimensions from "//&
+ & TRIM(td_mpp%c_name)//" in temporary dimension structure")
ELSE
- CALL logger_debug( &
- & " DEL DIM: delete dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", in mpp "//TRIM(td_mpp%c_name) )
-
- IF( td_mpp%i_ndim == 4 )THEN
- ALLOCATE( tl_dim(1), stat=il_status )
- IF(il_status /= 0 )THEN
- CALL logger_error( &
- & " DEL DIM: not enough space to put dimensions from "//&
- & TRIM(td_mpp%c_name)//" in temporary dimension structure")
- ELSE
- ! replace dimension by empty one
- td_mpp%t_dim(il_dimid)=tl_dim(1)
- ENDIF
- DEALLOCATE(tl_dim)
- ELSE
- !
- ALLOCATE( tl_dim(td_mpp%i_ndim), stat=il_status )
- IF(il_status /= 0 )THEN
-
- CALL logger_error( &
- & " DEL DIM: not enough space to put dimensions from "//&
- & TRIM(td_mpp%c_name)//" in temporary dimension structure")
-
- ELSE
-
- ! save temporary dimension's mpp structure
- tl_dim( 1 : il_dimid-1 ) = td_mpp%t_dim( 1 : il_dimid-1 )
- tl_dim( il_dimid : td_mpp%i_ndim-1 ) = &
- & td_mpp%t_dim( il_dimid+1 : td_mpp%i_ndim )
-
- ! copy dimension in file, except one
- td_mpp%t_dim(1:td_mpp%i_ndim)=tl_dim(:)
-
- ! update number of dimension
- td_mpp%i_ndim=td_mpp%i_ndim-1
-
- ENDIF
- ENDIF
-
- ! reorder dimension to ('x','y','z','t')
- CALL dim_reorder(td_mpp%t_dim)
-
- !IF( ASSOCIATED(td_mpp%t_proc) )THEN
- ! ! del dimension of processor
- ! DO ji=1,td_mpp%i_nproc
- ! CALL file_del_dim(td_mpp%t_proc(ji), td_dim)
- ! ENDDO
- !ENDIF
+ ! save temporary dimension's mpp structure
+ tl_dim( 1 : il_ind-1 ) = dim_copy(td_mpp%t_dim( 1 : il_ind-1 ))
+ tl_dim( il_ind : td_mpp%i_ndim-1 ) = &
+ & dim_copy(td_mpp%t_dim( il_ind+1 : td_mpp%i_ndim ))
+
+ ! remove dimension from file
+ CALL dim_clean(td_mpp%t_dim(:))
+ ! copy dimension in file, except one
+ td_mpp%t_dim(1:td_mpp%i_ndim)=dim_copy(tl_dim(:))
+
+ ! update number of dimension
+ td_mpp%i_ndim=td_mpp%i_ndim-1
+
+ ! update dimension id
+ DO ji=1,td_mpp%i_ndim
+ td_mpp%t_dim(ji)%i_id=ji
+ ENDDO
+
+ ! clean
+ CALL dim_clean(tl_dim(:))
+ DEALLOCATE(tl_dim)
ENDIF
- ELSE
- CALL logger_error( &
- & " DEL DIM: too much dimension in mpp "//&
- & TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
+
ENDIF
END SUBROUTINE mpp_del_dim
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine move a dimension structure
!> in mpp structure.
!> @warning dimension order may have changed
- !
- !> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_mpp : mpp structure
- !> @param[in] td_dim : dimension structure
- !> @todo
- !-------------------------------------------------------------------
- ! @code
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_mpp mpp structure
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
SUBROUTINE mpp_move_dim(td_mpp, td_dim)
IMPLICIT NONE
@@ -2119,35 +2352,39 @@
! local variable
+ INTEGER(i4) :: il_ind
INTEGER(i4) :: il_dimid
-
- !----------------------------------------------------------------
-
- il_dimid=dim_get_id(td_mpp%t_dim(:), TRIM(td_dim%c_name), &
- & TRIM(td_dim%c_sname))
- IF( il_dimid /= 0 )THEN
- ! remove dimension with same name
- CALL mpp_del_dim(td_mpp, td_dim)
- ENDIF
-
- ! add new dimension
- CALL mpp_add_dim(td_mpp, td_dim)
-
+ !----------------------------------------------------------------
+ IF( td_mpp%i_ndim <= ip_maxdim )THEN
+
+ ! check if dimension already in mpp structure
+ il_ind=dim_get_index(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname)
+ IF( il_ind /= 0 )THEN
+
+ il_dimid=td_mpp%t_dim(il_ind)%i_id
+ ! replace dimension
+ td_mpp%t_dim(il_ind)=dim_copy(td_dim)
+ td_mpp%t_dim(il_ind)%i_id=il_dimid
+ td_mpp%t_dim(il_ind)%l_use=.TRUE.
+
+ ELSE
+ CALL mpp_add_dim(td_mpp, td_dim)
+ ENDIF
+
+ ELSE
+ CALL logger_error( &
+ & "MPP MOVE DIM: too much dimension in mpp "//&
+ & TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
+ ENDIF
END SUBROUTINE mpp_move_dim
- ! @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine add global attribute to mpp structure.
!>
- !> @detail
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] td_att : attribute strcuture
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !>
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] td_att attribute strcuture
+ !-------------------------------------------------------------------
SUBROUTINE mpp_add_att( td_mpp, td_att )
IMPLICIT NONE
@@ -2176,11 +2413,12 @@
il_attid=0
IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
- il_attid=att_get_id( td_mpp%t_proc(1)%t_att(:), &
+ il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), &
& td_att%c_name )
ENDIF
IF( il_attid /= 0 )THEN
- CALL logger_error( " MPP ADD ATT: attribute "//TRIM(td_att%c_name)//&
- & ", already in mpp "//TRIM(td_mpp%c_name) )
+ CALL logger_error( " MPP ADD ATT: attribute "//&
+ & TRIM(td_att%c_name)//&
+ & ", already in mpp "//TRIM(td_mpp%c_name) )
DO ji=1,td_mpp%t_proc(1)%i_natt
@@ -2192,5 +2430,5 @@
CALL logger_info( &
- & " MPP ADD VAR: add attribute "//TRIM(td_att%c_name)//&
+ & " MPP ADD ATT: add attribute "//TRIM(td_att%c_name)//&
& ", in mpp "//TRIM(td_mpp%c_name) )
@@ -2207,5 +2445,4 @@
END SUBROUTINE mpp_add_att
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -2213,19 +2450,10 @@
!> structure.
!>
- !> @detail
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] td_att : attribute strcuture
- !
- !> @todo
- !> - check proc id exist
- !> - check proc dimension
- !> - check proc file name
- !> - check proc type
- !-------------------------------------------------------------------
- !> @code
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !>
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] td_att attribute strcuture
+ !-------------------------------------------------------------------
SUBROUTINE mpp__del_att_str( td_mpp, td_att )
IMPLICIT NONE
@@ -2244,5 +2472,5 @@
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
- CALL logger_error( " DEL VAR: domain decomposition not define "//&
+ CALL logger_warn( "MPP DEL VAR: domain decomposition not define "//&
& " in mpp strcuture "//TRIM(td_mpp%c_name))
@@ -2252,20 +2480,24 @@
il_attid=0
IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
- il_attid=att_get_id( td_mpp%t_proc(1)%t_att(:), &
+ il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), &
& td_att%c_name )
ENDIF
IF( il_attid == 0 )THEN
- CALL logger_error( &
- & " DEL VAR: no attribute "//TRIM(td_att%c_name)//&
+ CALL logger_warn( &
+ & "MPP DEL VAR: no attribute "//TRIM(td_att%c_name)//&
& ", in mpp structure "//TRIM(td_mpp%c_name) )
- DO ji=1,td_mpp%t_proc(1)%i_natt
- CALL logger_debug( " DEL ATT: in mpp structure : &
- & attribute : "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name) )
- ENDDO
+ IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
+ DO ji=1,td_mpp%t_proc(1)%i_natt
+ CALL logger_debug( "MPP DEL ATT: in mpp structure : &
+ & attribute : "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name) )
+ ENDDO
+ ENDIF
ELSE
cl_name=TRIM(td_att%c_name)
+ CALL logger_debug( "MPP DEL ATT: delete in mpp structure : &
+ & attribute : "//TRIM(cl_name) )
DO ji=1,td_mpp%i_nproc
CALL file_del_att(td_mpp%t_proc(ji), TRIM(cl_name))
@@ -2276,5 +2508,4 @@
ENDIF
END SUBROUTINE mpp__del_att_str
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -2284,16 +2515,9 @@
!
!> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] cd_name: attribute name
- !
- !> @todo
- !> - check proc id exist
- !> - check proc dimension
- !> - check proc file name
- !> - check proc type
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] cd_name attribute name
+ !-------------------------------------------------------------------
SUBROUTINE mpp__del_att_name( td_mpp, cd_name )
IMPLICIT NONE
@@ -2308,5 +2532,5 @@
IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
- CALL logger_error( " DEL ATT: domain decomposition not define "//&
+ CALL logger_warn( "MPP DEL ATT: domain decomposition not define "//&
& " in mpp strcuture "//TRIM(td_mpp%c_name))
@@ -2314,5 +2538,5 @@
IF( td_mpp%t_proc(1)%i_natt == 0 )THEN
- CALL logger_debug( " DEL ATT NAME: no attribute associated to mpp &
+ CALL logger_debug( "MPP DEL ATT NAME: no attribute associated to mpp &
& structure "//TRIM(td_mpp%c_name) )
ELSE
@@ -2328,5 +2552,5 @@
CALL logger_warn( &
- & " DEL ATT : there is no attribute with "//&
+ & "MPP DEL ATT : there is no attribute with "//&
& "name "//TRIM(cd_name)//" in mpp structure "//&
& TRIM(td_mpp%c_name))
@@ -2341,19 +2565,14 @@
ENDIF
END SUBROUTINE mpp__del_att_name
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine overwrite attribute in mpp structure.
!>
- !> @detail
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] td_att : attribute structure
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] td_att attribute structure
+ !-------------------------------------------------------------------
SUBROUTINE mpp_move_att( td_mpp, td_att )
IMPLICIT NONE
@@ -2363,8 +2582,8 @@
!local variable
- TYPE(TATT) :: tl_att
+ TYPE(TATT) :: tl_att
!----------------------------------------------------------------
! copy variable
- tl_att=td_att
+ tl_att=att_copy(td_att)
! remove processor
@@ -2374,6 +2593,8 @@
CALL mpp_add_att(td_mpp, tl_att)
+ ! clean
+ CALL att_clean(tl_att)
+
END SUBROUTINE mpp_move_att
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -2388,9 +2609,8 @@
!
!> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[inout] td_mpp mpp strcuture
+ !-------------------------------------------------------------------
SUBROUTINE mpp__compute( td_mpp )
IMPLICIT NONE
@@ -2410,5 +2630,5 @@
CHARACTER(LEN=lc) :: cl_file
TYPE(TFILE) :: tl_proc
- TYPE(TATT) ::tl_att
+ TYPE(TATT) :: tl_att
! loop indices
@@ -2421,5 +2641,5 @@
td_mpp%i_nproc=0
- CALL logger_trace( "COMPUTE: compute domain decomposition with "//&
+ CALL logger_trace( "MPP COMPUTE: compute domain decomposition with "//&
& TRIM(fct_str(td_mpp%i_niproc))//" x "//&
& TRIM(fct_str(td_mpp%i_njproc))//" processors")
@@ -2498,5 +2718,4 @@
& (/tl_proc%i_lci, tl_proc%i_lcj/) )
CALL file_add_att(tl_proc, tl_att)
-
! compute first and last indoor indices
@@ -2544,4 +2763,8 @@
CALL mpp__add_proc(td_mpp, tl_proc)
+ ! clean
+ CALL att_clean(tl_att)
+ CALL file_clean(tl_proc)
+
ENDDO
ENDDO
@@ -2551,16 +2774,14 @@
END SUBROUTINE mpp__compute
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine remove land processor from domain decomposition.
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] id_mask : sub domain mask (sea=1, land=0)
- !-------------------------------------------------------------------
- !> @code
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !>
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] id_mask sub domain mask (sea=1, land=0)
+ !-------------------------------------------------------------------
SUBROUTINE mpp__del_land( td_mpp, id_mask )
IMPLICIT NONE
@@ -2583,9 +2804,8 @@
ENDDO
ELSE
- CALL logger_error("DEL LAND: domain decomposition not define.")
+ CALL logger_error("MPP DEL LAND: domain decomposition not define.")
ENDIF
END SUBROUTINE mpp__del_land
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -2596,9 +2816,9 @@
!
!> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013 - Initial version
+ !
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] id_mask sub domain mask (sea=1, land=0)
+ !-------------------------------------------------------------------
SUBROUTINE mpp__optimiz( td_mpp, id_mask )
IMPLICIT NONE
@@ -2617,6 +2837,6 @@
!----------------------------------------------------------------
- CALL logger_trace("OPTIMIZ: look for best domain decomposition")
- tl_mpp=td_mpp
+ CALL logger_trace("MPP OPTIMIZ: look for best domain decomposition")
+ tl_mpp=mpp_copy(td_mpp)
! save maximum number of processor to be used
@@ -2629,4 +2849,5 @@
! clean mpp processor
IF( ASSOCIATED(tl_mpp%t_proc) )THEN
+ CALL file_clean(tl_mpp%t_proc(:))
DEALLOCATE(tl_mpp%t_proc)
ENDIF
@@ -2641,5 +2862,5 @@
CALL mpp__del_land( tl_mpp, id_mask )
- CALL logger_info("OPTIMIZ: number of processor "//&
+ CALL logger_info("MPP OPTIMIZ: number of processor "//&
& TRIM(fct_str(tl_mpp%i_nproc)) )
IF( tl_mpp%i_nproc > td_mpp%i_nproc .AND. &
@@ -2650,18 +2871,22 @@
CALL mpp_clean(td_mpp)
- ! save processor table
+ ! save processor array
ALLOCATE( tl_proc(tl_mpp%i_nproc) )
- tl_proc(:)=tl_mpp%t_proc(:)
-
- ! remove pointer on processor table
+ tl_proc(:)=file_copy(tl_mpp%t_proc(:))
+
+ ! remove pointer on processor array
+ CALL file_clean(tl_mpp%t_proc(:))
DEALLOCATE(tl_mpp%t_proc)
- ! save data except processor table
- td_mpp=tl_mpp
- ! save processor table
+ ! save data except processor array
+ td_mpp=mpp_copy(tl_mpp)
+
+ ! save processor array
ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc) )
- td_mpp%t_proc(:)=tl_proc(:)
-
- DEALLOCATE( tl_proc )
+ td_mpp%t_proc(:)=file_copy(tl_proc(:))
+
+ ! clean
+ CALL file_clean( tl_proc(:) )
+ DEALLOCATE(tl_proc)
ENDIF
@@ -2670,18 +2895,19 @@
ENDDO
+ ! clean
+ CALL mpp_clean(tl_mpp)
+
END SUBROUTINE mpp__optimiz
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function check if processor is a land processor.
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[in] td_mpp : mpp strcuture
- !> @param[in] id_proc : processor id
- !> @param[in] id_mask : sub domain mask (sea=1, land=0)
- !-------------------------------------------------------------------
- !> @code
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !>
+ !> @param[in] td_mpp mpp strcuture
+ !> @param[in] id_proc processor id
+ !> @param[in] id_mask sub domain mask (sea=1, land=0)
+ !-------------------------------------------------------------------
LOGICAL FUNCTION mpp__land_proc( td_mpp , id_proc, id_mask )
IMPLICIT NONE
@@ -2695,5 +2921,5 @@
!----------------------------------------------------------------
- CALL logger_trace("LAND PROC: check processor "//TRIM(fct_str(id_proc))//&
+ CALL logger_trace("MPP LAND PROC: check processor "//TRIM(fct_str(id_proc))//&
& " of mpp "//TRIM(td_mpp%c_name) )
mpp__land_proc=.FALSE.
@@ -2703,5 +2929,11 @@
IF( il_shape(1) /= td_mpp%t_dim(1)%i_len .OR. &
& il_shape(2) /= td_mpp%t_dim(2)%i_len )THEN
- CALL logger_error("LAND PROC: mask and domain size differ")
+ CALL logger_debug("MPP LAND PROC: mask size ("//&
+ & TRIM(fct_str(il_shape(1)))//","//&
+ & TRIM(fct_str(il_shape(2)))//")")
+ CALL logger_debug("MPP LAND PROC: domain size ("//&
+ & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
+ & TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")")
+ CALL logger_error("MPP LAND PROC: mask and domain size differ")
ELSE
IF( ALL(id_mask( td_mpp%t_proc(id_proc)%i_impp + &
@@ -2715,5 +2947,5 @@
& /= 1 ) )THEN
! land domain
- CALL logger_info(" LAND PROC: processor "//TRIM(fct_str(id_proc))//&
+ CALL logger_info("MPP LAND PROC: processor "//TRIM(fct_str(id_proc))//&
& " is land processor")
mpp__land_proc=.TRUE.
@@ -2722,20 +2954,18 @@
ELSE
- CALL logger_error("LAND PROC: domain decomposition not define.")
+ CALL logger_error("MPP LAND PROC: domain decomposition not define.")
ENDIF
END FUNCTION mpp__land_proc
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine clean mpp strcuture.
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE mpp_clean( td_mpp )
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !>
+ !> @param[inout] td_mpp mpp strcuture
+ !-------------------------------------------------------------------
+ SUBROUTINE mpp__clean_unit( td_mpp )
IMPLICIT NONE
! Argument
@@ -2746,52 +2976,80 @@
! loop indices
- INTEGER(i4) :: ji
!----------------------------------------------------------------
CALL logger_info( &
- & " CLEAN: reset mpp "//TRIM(td_mpp%c_name) )
+ & "MPP CLEAN: reset mpp "//TRIM(td_mpp%c_name) )
! del dimension
IF( td_mpp%i_ndim /= 0 )THEN
- DO ji=td_mpp%i_ndim,1,-1
- CALL dim_clean( td_mpp%t_dim(ji) )
- ENDDO
+ CALL dim_clean( td_mpp%t_dim(:) )
ENDIF
IF( ASSOCIATED(td_mpp%t_proc) )THEN
- ! clean each proc
- DO ji=1,td_mpp%i_nproc
- CALL file_clean( td_mpp%t_proc(ji) )
- ENDDO
+ ! clean array of file processor
+ CALL file_clean( td_mpp%t_proc(:) )
DEALLOCATE(td_mpp%t_proc)
ENDIF
! replace by empty structure
- td_mpp=tl_mpp
-
- END SUBROUTINE mpp_clean
- !> @endcode
+ td_mpp=mpp_copy(tl_mpp)
+
+ END SUBROUTINE mpp__clean_unit
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine clean mpp strcuture.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !>
+ !> @param[inout] td_mpp mpp strcuture
+ !-------------------------------------------------------------------
+ SUBROUTINE mpp__clean_arr( td_mpp )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP), DIMENSION(:), INTENT(INOUT) :: td_mpp
+
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ DO ji=SIZE(td_mpp(:)),1,-1
+ CALL mpp_clean(td_mpp(ji))
+ ENDDO
+
+ END SUBROUTINE mpp__clean_arr
!-------------------------------------------------------------------
!> @brief
!> This subroutine get sub domains which cover "zoom domain".
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @param[in] td_dom : domain strcuture
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE mpp_get_use( td_mpp, td_dom )
+ !>
+ !> @author J.Paul
+ !> @date November, 2013 - Initial version
+ !>
+ !> @param[inout] td_mpp mpp strcuture
+ !> @param[in] id_imin i-direction lower indice
+ !> @param[in] id_imax i-direction upper indice
+ !> @param[in] id_jmin j-direction lower indice
+ !> @param[in] id_jmax j-direction upper indice
+ !-------------------------------------------------------------------
+ SUBROUTINE mpp__get_use_unit( td_mpp, id_imin, id_imax, &
+ & id_jmin, id_jmax )
IMPLICIT NONE
! Argument
- TYPE(TMPP), INTENT(INOUT) :: td_mpp
- TYPE(TDOM), INTENT(IN) :: td_dom
+ TYPE(TMPP) , INTENT(INOUT) :: td_mpp
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax
! local variable
- INTEGER(i4) :: il_jmin
LOGICAL :: ll_iuse
LOGICAL :: ll_juse
+ INTEGER(i4) :: il_imin
+ INTEGER(i4) :: il_imax
+ INTEGER(i4) :: il_jmin
+ INTEGER(i4) :: il_jmax
+
! loop indices
INTEGER(i4) :: jk
@@ -2799,8 +3057,27 @@
IF( ASSOCIATED(td_mpp%t_proc) )THEN
+ il_imin=1
+ il_imax=td_mpp%t_dim(1)%i_len
+ IF( PRESENT(id_imin) ) il_imin=id_imin
+ IF( PRESENT(id_imax) ) il_imax=id_imax
+ il_jmin=1
+ il_jmax=td_mpp%t_dim(2)%i_len
+ IF( PRESENT(id_jmin) ) il_jmin=id_jmin
+ IF( PRESENT(id_jmax) ) il_jmax=id_jmax
+
! check domain
- IF( td_mpp%t_dim(1)%i_len == td_dom%t_dim0(1)%i_len .AND. &
- & td_mpp%t_dim(2)%i_len == td_dom%t_dim0(2)%i_len )THEN
-
+ IF( il_imin < 1 .OR. il_imin > td_mpp%t_dim(1)%i_len .OR. &
+ & il_imax < 1 .OR. il_imax > td_mpp%t_dim(1)%i_len .OR. &
+ & il_jmin < 1 .OR. il_jmin > td_mpp%t_dim(2)%i_len .OR. &
+ & il_jmax < 1 .OR. il_jmax > td_mpp%t_dim(2)%i_len )THEN
+ CALL logger_debug("MPP GET USE: mpp gloabl size "//&
+ & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
+ & TRIM(fct_str(td_mpp%t_dim(2)%i_len)))
+ CALL logger_debug("MPP GET USE: i-indices "//&
+ & TRIM(fct_str(il_imin))//","//TRIM(fct_str(il_imax)))
+ CALL logger_debug("MPP GET USE: j-indices "//&
+ & TRIM(fct_str(il_jmin))//","//TRIM(fct_str(il_jmax)))
+ CALL logger_error("MPP GET USE: invalid indices ")
+ ELSE
td_mpp%t_proc(:)%l_use=.FALSE.
DO jk=1,td_mpp%i_nproc
@@ -2808,28 +3085,25 @@
! check i-direction
ll_iuse=.FALSE.
- IF( td_dom%i_imin < td_dom%i_imax )THEN
+ IF( il_imin < il_imax )THEN
! not overlap east west boundary
IF( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
- & td_dom%i_imin .AND. &
- & td_mpp%t_proc(jk)%i_impp < td_dom%i_imax )THEN
+ & il_imin .AND. &
+ & td_mpp%t_proc(jk)%i_impp < il_imax )THEN
ll_iuse=.TRUE.
ENDIF
- ELSEIF( td_dom%i_imin == td_dom%i_imax )THEN
+ ELSEIF( il_imin == il_imax )THEN
! east west cyclic
ll_iuse=.TRUE.
- ELSE ! td_dom%i_imin > td_dom%i_imax
+ ELSE ! il_imin > id_imax
! overlap east west boundary
IF( ( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
- & td_dom%i_imin .AND. &
- & td_mpp%t_proc(jk)%i_impp < td_dom%t_dim0(1)%i_len ) &
+ & il_imin ) &
& .OR. &
- & ( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
- & 1 .AND. &
- & td_mpp%t_proc(jk)%i_impp < td_dom%i_imax) )THEN
+ & ( td_mpp%t_proc(jk)%i_impp < il_imax) )THEN
ll_iuse=.TRUE.
ENDIF
@@ -2839,16 +3113,15 @@
! check j-direction
ll_juse=.FALSE.
- IF( td_dom%i_jmin < td_dom%i_jmax )THEN
+ IF( il_jmin < il_jmax )THEN
! not overlap north fold
IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > &
- & td_dom%i_jmin .AND. &
- & td_mpp%t_proc(jk)%i_jmpp < td_dom%i_jmax )THEN
+ & il_jmin .AND. &
+ & td_mpp%t_proc(jk)%i_jmpp < il_jmax )THEN
ll_juse=.TRUE.
ENDIF
- ELSE ! td_dom%i_jmin >= td_dom%i_jmax
-
- il_jmin=MIN(td_dom%i_jmin,td_dom%i_jmax)
+ ELSE ! id_jmin >= id_jmax
+
IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > &
& il_jmin )THEN
@@ -2861,24 +3134,20 @@
ENDDO
- ELSE
- CALL logger_error("GET USE: domain differ")
ENDIF
ELSE
- CALL logger_error("GET USE: domain decomposition not define.")
- ENDIF
-
- END SUBROUTINE mpp_get_use
- !> @endcode
+ CALL logger_error("MPP GET USE: mpp decomposition not define.")
+ ENDIF
+
+ END SUBROUTINE mpp__get_use_unit
!-------------------------------------------------------------------
!> @brief
!> This subroutine get sub domains which form global domain border.
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !-------------------------------------------------------------------
- !> @code
+ !>
+ !> @author J.Paul
+ !> @date November, 2013
+ !>
+ !> @param[inout] td_mpp mpp strcuture
+ !-------------------------------------------------------------------
SUBROUTINE mpp_get_contour( td_mpp )
IMPLICIT NONE
@@ -2892,5 +3161,5 @@
IF( ASSOCIATED(td_mpp%t_proc) )THEN
- td_mpp%t_proc(:)%l_ctr = .FALSE.
+ td_mpp%t_proc(:)%l_use = .FALSE.
DO jk=1,td_mpp%i_nproc
IF( td_mpp%t_proc(jk)%i_ldi == 1 .OR. &
@@ -2899,33 +3168,31 @@
& td_mpp%t_proc(jk)%i_lej == td_mpp%t_proc(jk)%i_lcj )THEN
- td_mpp%t_proc(jk)%l_ctr = .TRUE.
-
+ td_mpp%t_proc(jk)%l_use = .TRUE.
+
ENDIF
ENDDO
ELSE
- CALL logger_error("GET CONTOUR: domain decomposition not define.")
+ CALL logger_error("MPP GET CONTOUR: domain decomposition not define.")
ENDIF
END SUBROUTINE mpp_get_contour
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function return processor indices, without overlap boundary,
- !> given processor id. This depends of domain decompisition type.
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[in] td_mpp : mpp strcuture
- !> @param[in] id_procid : processor id
- !> @return table of index (/ i1, i2, j1, j2 /)
- !-------------------------------------------------------------------
- !> @code
+ !> given processor id.
+ !>
+ !> @author J.Paul
+ !> @date November, 2013
+ !>
+ !> @param[in] td_mpp mpp strcuture
+ !> @param[in] id_procid processor id
+ !> @return array of index (/ i1, i2, j1, j2 /)
+ !-------------------------------------------------------------------
FUNCTION mpp_get_proc_index( td_mpp, id_procid )
IMPLICIT NONE
! Argument
- TYPE(TMPP), INTENT(IN) :: td_mpp
+ TYPE(TMPP) , INTENT(IN) :: td_mpp
INTEGER(i4), INTENT(IN) :: id_procid
@@ -2936,18 +3203,14 @@
INTEGER(i4) :: il_i1, il_i2
INTEGER(i4) :: il_j1, il_j2
- TYPE(TMPP) :: tl_mpp
!----------------------------------------------------------------
IF( ASSOCIATED(td_mpp%t_proc) )THEN
- tl_mpp=td_mpp
- !IF( TRIM(td_mpp%c_dom) == "unknown" )THEN
IF( TRIM(td_mpp%c_dom) == '' )THEN
- CALL logger_warn("GET PROC INDEX: decomposition type unknown. "//&
- & "look for it")
- CALL mpp_get_dom( tl_mpp )
+ CALL logger_fatal("MPP GET PROC INDEX: decomposition type unknown. "//&
+ & "you should ahve run mpp_get_dom before.")
ENDIF
- SELECT CASE(TRIM(tl_mpp%c_dom))
+ SELECT CASE(TRIM(td_mpp%c_dom))
CASE('full')
il_i1 = 1 ; il_i2 = td_mpp%t_dim(1)%i_len
@@ -2957,5 +3220,5 @@
il_j1 = td_mpp%t_proc(id_procid)%i_jmpp
- il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1 ! attention lei dans ioRestartDimg
+ il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1
il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1
CASE('nooverlap')
@@ -2970,5 +3233,5 @@
& td_mpp%t_proc(id_procid)%i_lej - 1
CASE DEFAULT
- CALL logger_error("GET PROC INDEX: invalid decomposition type.")
+ CALL logger_error("MPP GET PROC INDEX: invalid decomposition type.")
END SELECT
@@ -2976,9 +3239,8 @@
ELSE
- CALL logger_error("GET PROC INDEX: domain decomposition not define.")
+ CALL logger_error("MPP GET PROC INDEX: domain decomposition not define.")
ENDIF
END FUNCTION mpp_get_proc_index
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -2987,11 +3249,10 @@
!
!> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[in] td_mpp : mpp strcuture
- !> @param[in] id_procid : sub domain id
- !> @return table of index (/ isize, jsize /)
- !-------------------------------------------------------------------
- !> @code
+ !> @date November, 2013
+ !
+ !> @param[in] td_mpp mpp strcuture
+ !> @param[in] id_procid sub domain id
+ !> @return array of index (/ isize, jsize /)
+ !-------------------------------------------------------------------
FUNCTION mpp_get_proc_size( td_mpp, id_procid )
IMPLICIT NONE
@@ -3007,18 +3268,14 @@
INTEGER(i4) :: il_isize
INTEGER(i4) :: il_jsize
- TYPE(TMPP) :: tl_mpp
!----------------------------------------------------------------
IF( ASSOCIATED(td_mpp%t_proc) )THEN
- tl_mpp=td_mpp
- !IF( TRIM(td_mpp%c_dom) == "unknown" )THEN
IF( TRIM(td_mpp%c_dom) == '' )THEN
- CALL logger_warn("GET PROC SIZE: decomposition type unknown. "//&
- & "look for it")
- CALL mpp_get_dom( tl_mpp )
+ CALL logger_fatal("MPP GET PROC SIZE: decomposition type unknown. "//&
+ & "you should ahve run mpp_get_dom before.")
ENDIF
- SELECT CASE(TRIM(tl_mpp%c_dom))
+ SELECT CASE(TRIM(td_mpp%c_dom))
CASE('full')
@@ -3037,6 +3294,6 @@
& td_mpp%t_proc(id_procid)%i_ldj + 1
CASE DEFAULT
- CALL logger_error("GET PROC SIZE: invalid decomposition type : "//&
- & TRIM(tl_mpp%c_dom) )
+ CALL logger_error("MPP GET PROC SIZE: invalid decomposition type : "//&
+ & TRIM(td_mpp%c_dom) )
END SELECT
@@ -3044,22 +3301,18 @@
ELSE
- CALL logger_error("GET PROC SIZE: domain decomposition not define.")
+ CALL logger_error("MPP GET PROC SIZE: domain decomposition not define.")
ENDIF
END FUNCTION mpp_get_proc_size
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine determine domain decomposition type.
!> (full, overlap, noverlap)
- !
- !> @author J.Paul
- !> @date Nov, 2013
- !
- !> @param[inout] td_mpp : mpp strcuture
- !> @todo
- !> - change name, confusing with domain.f90
- !-------------------------------------------------------------------
- !> @code
+ !>
+ !> @author J.Paul
+ !> @date November, 2013
+ !>
+ !> @param[inout] td_mpp mpp strcuture
+ !-------------------------------------------------------------------
SUBROUTINE mpp_get_dom( td_mpp )
IMPLICIT NONE
@@ -3075,5 +3328,5 @@
IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_niproc == 0 )THEN
- CALL logger_info("GET DOM: use indoor indices to get domain "//&
+ CALL logger_info("MPP GET DOM: use indoor indices to get domain "//&
& "decomposition type.")
IF((td_mpp%t_proc(1)%t_dim(1)%i_len == &
@@ -3100,24 +3353,24 @@
ELSE
- CALL logger_error("GET DOM: should have been an impossible case")
+ CALL logger_error("MPP GET DOM: should have been an impossible case")
il_isize=td_mpp%t_proc(1)%t_dim(1)%i_len
il_jsize=td_mpp%t_proc(1)%t_dim(2)%i_len
- CALL logger_debug("GET DOM: proc size "//&
+ CALL logger_debug("MPP GET DOM: proc size "//&
& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
il_isize=td_mpp%t_proc(1)%i_lei - td_mpp%t_proc(1)%i_ldi + 1
il_jsize=td_mpp%t_proc(1)%i_lej - td_mpp%t_proc(1)%i_ldj + 1
- CALL logger_debug("GET DOM: no overlap size "//&
+ CALL logger_debug("MPP GET DOM: no overlap size "//&
& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
il_isize=td_mpp%t_proc(1)%i_lci
il_jsize=td_mpp%t_proc(1)%i_lcj
- CALL logger_debug("GET DOM: overlap size "//&
+ CALL logger_debug("MPP GET DOM: overlap size "//&
& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
il_isize=td_mpp%t_dim(1)%i_len
il_jsize=td_mpp%t_dim(2)%i_len
- CALL logger_debug("GET DOM: full size "//&
+ CALL logger_debug("MPP GET DOM: full size "//&
& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
@@ -3126,5 +3379,5 @@
ELSE
- CALL logger_info("GET DOM: use number of processors following "//&
+ CALL logger_info("MPP GET DOM: use number of processors following "//&
& "I and J to get domain decomposition type.")
IF( td_mpp%i_niproc*td_mpp%i_njproc==td_mpp%i_nproc )THEN
@@ -3140,23 +3393,21 @@
ELSE
- CALL logger_error("GET DOM: domain decomposition not define.")
+ CALL logger_error("MPP GET DOM: domain decomposition not define.")
ENDIF
END SUBROUTINE mpp_get_dom
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function check if variable and mpp structure use same
!> dimension.
- !
+ !>
!> @details
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !> @param[in] td_var : variable structure
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] td_mpp mpp structure
+ !> @param[in] td_var variable structure
!> @return dimension of variable and mpp structure agree (or not)
!-------------------------------------------------------------------
- ! @code
LOGICAL FUNCTION mpp__check_var_dim(td_mpp, td_var)
IMPLICIT NONE
@@ -3179,5 +3430,5 @@
CALL logger_error( &
- & " CHECK DIM: variable and mpp dimension differ"//&
+ & "MPP CHECK DIM: variable and mpp dimension differ"//&
& " for variable "//TRIM(td_var%c_name)//&
& " and mpp "//TRIM(td_mpp%c_name))
@@ -3189,5 +3440,5 @@
DO ji = 1, il_ndim
CALL logger_debug( &
- & " CHECK DIM: for dimension "//&
+ & "MPP CHECK DIM: for dimension "//&
& TRIM(td_mpp%t_dim(ji)%c_name)//&
& ", mpp length: "//&
@@ -3200,5 +3451,156 @@
END FUNCTION mpp__check_var_dim
- ! @endcode
+ !-------------------------------------------------------------------
+ !> @brief This function return the mpp id, in a array of mpp
+ !> structure, given mpp base name.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_file array of file structure
+ !> @param[in] cd_name file name
+ !> @return file id in array of file structure (0 if not found)
+ !-------------------------------------------------------------------
+ INTEGER(i4) FUNCTION mpp_get_index(td_mpp, cd_name)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP) , DIMENSION(:), INTENT(IN) :: td_mpp
+ CHARACTER(LEN=*), INTENT(IN) :: cd_name
+
+ ! local variable
+ CHARACTER(LEN=lc) :: cl_name
+ INTEGER(i4) :: il_size
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ mpp_get_index=0
+ il_size=SIZE(td_mpp(:))
+
+ cl_name=TRIM( file_rename(cd_name) )
+
+ ! check if mpp is in array of mpp structure
+ DO ji=1,il_size
+ ! look for file name
+ IF( TRIM(fct_lower(td_mpp(ji)%c_name)) == TRIM(fct_lower(cd_name)) )THEN
+
+ mpp_get_index=ji
+ EXIT
+
+ ENDIF
+ ENDDO
+
+ END FUNCTION mpp_get_index
+ !-------------------------------------------------------------------
+ !> @brief This function recombine variable splitted mpp structure.
+ !
+ !> @author J.Paul
+ !> - Ocotber, 2014- Initial Version
+ !
+ !> @param[in] td_mpp mpp file structure
+ !> @param[in] cd_name variable name
+ !> @return variable strucutre
+ !-------------------------------------------------------------------
+ TYPE(TVAR) FUNCTION mpp_recombine_var(td_mpp, cd_name)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TMPP) , INTENT(IN) :: td_mpp
+ CHARACTER(LEN=*), INTENT(IN) :: cd_name
+
+ ! local variable
+ INTEGER(i4) :: il_varid
+ INTEGER(i4) :: il_status
+ INTEGER(i4) :: il_i1p
+ INTEGER(i4) :: il_i2p
+ INTEGER(i4) :: il_j1p
+ INTEGER(i4) :: il_j2p
+ INTEGER(i4), DIMENSION(4) :: il_ind
+
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt
+
+ TYPE(TVAR) :: tl_tmp
+ TYPE(TVAR) :: tl_var
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jk
+ !----------------------------------------------------------------
+
+ il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name)
+ IF( il_varid /= 0 )THEN
+
+ tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid))
+ ! Allocate space to hold variable value in structure
+ IF( ASSOCIATED(tl_var%d_value) )THEN
+ DEALLOCATE(tl_var%d_value)
+ ENDIF
+ !
+ DO ji=1,ip_maxdim
+ IF( tl_var%t_dim(ji)%l_use )THEN
+ tl_var%t_dim(ji)%i_len=td_mpp%t_dim(ji)%i_len
+ ENDIF
+ ENDDO
+
+ ALLOCATE(tl_var%d_value( tl_var%t_dim(1)%i_len, &
+ & tl_var%t_dim(2)%i_len, &
+ & tl_var%t_dim(3)%i_len, &
+ & tl_var%t_dim(4)%i_len),&
+ & stat=il_status)
+ IF(il_status /= 0 )THEN
+
+ CALL logger_error( &
+ & " MPP RECOMBINE VAR: not enough space to put variable "//&
+ & TRIM(tl_var%c_name)//" in variable structure")
+
+ ENDIF
+
+ ! FillValue by default
+ tl_var%d_value(:,:,:,:)=tl_var%d_fill
+
+ ! read processor
+ DO jk=1,td_mpp%i_nproc
+ IF( td_mpp%t_proc(jk)%l_use )THEN
+ ! get processor indices
+ il_ind(:)=mpp_get_proc_index( td_mpp, jk )
+ il_i1p = il_ind(1)
+ il_i2p = il_ind(2)
+ il_j1p = il_ind(3)
+ il_j2p = il_ind(4)
+
+ il_strt(:)=(/ 1,1,1,1 /)
+
+ il_cnt(:)=(/ il_i2p-il_i1p+1, &
+ & il_j2p-il_j1p+1, &
+ & tl_var%t_dim(3)%i_len, &
+ & tl_var%t_dim(4)%i_len /)
+
+ tl_tmp=iom_read_var( td_mpp%t_proc(jk), tl_var%c_name,&
+ & il_strt(:), il_cnt(:) )
+
+ ! replace value in output variable structure
+ tl_var%d_value( il_i1p : il_i2p, &
+ & il_j1p : il_j2p, &
+ & :,:) = tl_tmp%d_value(:,:,:,:)
+
+ ! clean
+ CALL var_clean(tl_tmp)
+
+ ENDIF
+ ENDDO
+
+ mpp_recombine_var=var_copy(tl_var)
+
+ ! clean
+ CALL var_clean(tl_var)
+
+ ELSE
+
+ CALL logger_error( &
+ & " MPP RECOMBINE VAR: there is no variable with "//&
+ & "name or standard name"//TRIM(cd_name)//&
+ & " in mpp file "//TRIM(td_mpp%c_name))
+ ENDIF
+ END FUNCTION mpp_recombine_var
END MODULE mpp
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/multi.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/multi.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/multi.f90 (revision 5214)
@@ -5,16 +5,61 @@
! MODULE: multi
!
-!
! DESCRIPTION:
-!> This module manage multi file structure
+!> This module manage multi file structure.
!
!> @details
-!> define type TMULTI:
-!> TYPE(TMULTI) :: tl_multi
+!> define type TMULTI:
+!> @code
+!> TYPE(TMULTI) :: tl_multi
+!> @endcode
+!>
+!> to initialize a multi-file structure:
+!> @code
+!> tl_multi=multi_init(cd_varfile(:))
+!> @endcode
+!> - cd_varfile : array of variable with file path
+!> ('var1:file1','var2:file2')
+!> file path could be replaced by a matrix of value.
+!> separators used to defined matrix are:
+!> - ',' for line
+!> - '/' for row
+!> - '\' for level
+!> Example:
+!> - 'var1:3,2,3/1,4,5'
+!> - 3,2,3/1,4,5 =>
+!> @f$ \left( \begin{array}{ccc}
+!> 3 & 2 & 3 \\
+!> 1 & 4 & 5 \end{array} \right) @f$
+!>
+!> to get the number of mpp file in mutli file structure:
+!> - tl_multi\%i_nmpp
+!>
+!> to get the total number of variable in mutli file structure:
+!> - tl_multi\%i_nvar
+!>
+!> @note number of variable and number of file could differ cause several variable
+!> could be in the same file.
+!>
+!> to get array of mpp structure in mutli file structure:
+!> - tl_multi\%t_mpp(:)
+!>
+!> to print information about multi structure:
+!> @code
+!> CALL multi_print(td_multi)
+!> @endcode
+!>
+!> to clean multi file strucutre:
+!> @code
+!> CALL multi_clean(td_multi)
+!> @endcode
+!> - td_multi is multi file structure
!>
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date 2013 - Initial Version
+!> @date November, 2013 - Initial Version
+!> @date October, 2014
+!> - use mpp file structure instead of file
+!> @date November, 2014 - Fix memory leaks bug
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
@@ -22,37 +67,37 @@
MODULE multi
USE kind ! F90 kind parameter
- USE logger ! log file manager
+ USE logger ! log file manager
USE fct ! basic useful function
USE dim ! dimension manager
- USE att ! attribute manager
USE var ! variable manager
USE file ! file manager
+ USE iom ! I/O manager
+ USE mpp ! MPP manager
+ USE iom_mpp ! MPP I/O manager
+
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
! type and variable
- PUBLIC :: TMULTI ! multi file structure
+ PUBLIC :: TMULTI !< multi file structure
! function and subroutine
- PUBLIC :: ASSIGNMENT(=) !< copy multi structure
- PUBLIC :: multi_init !< initialise mpp structure
- PUBLIC :: multi_clean !< clean mpp strcuture
- PUBLIC :: multi_print !< print information about mpp structure
-
- PUBLIC :: multi_add_file !< add one proc strucutre in mpp structure
-! PUBLIC :: multi_del_file !< delete one proc strucutre in mpp structure
-! PUBLIC :: multi_move_file !< overwrite proc strucutre in mpp structure
-
- !> @struct TMULTI
- TYPE TMULTI
+ PUBLIC :: multi_copy !< copy multi structure
+ PUBLIC :: multi_init !< initialise multi structure
+ PUBLIC :: multi_clean !< clean multi strcuture
+ PUBLIC :: multi_print !< print information about milti structure
+
+ PUBLIC :: multi__add_mpp !< add file strucutre to multi file structure
+ PRIVATE :: multi__copy_unit !< copy multi file structure
+
+ TYPE TMULTI !< multi file structure
! general
- INTEGER(i4) :: i_nfile = 0 !< number of files
+ INTEGER(i4) :: i_nmpp = 0 !< number of mpp files
INTEGER(i4) :: i_nvar = 0 !< total number of variables
- TYPE(TFILE), DIMENSION(:), POINTER :: t_file => NULL() !< files composing multi
+ TYPE(TMPP) , DIMENSION(:), POINTER :: t_mpp => NULL() !< mpp files composing multi
END TYPE
- INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE multi__copy ! copy multi file structure
+ INTERFACE multi_copy
+ MODULE PROCEDURE multi__copy_unit ! copy multi file structure
END INTERFACE
@@ -60,26 +105,33 @@
!-------------------------------------------------------------------
!> @brief
- !> This function copy multi file structure in another multi file
- !> structure
+ !> This function copy multi mpp structure in another one
!> @details
- !> file variable value are copied in a temporary table,
+ !> file variable value are copied in a temporary array,
!> so input and output file structure value do not point on the same
!> "memory cell", and so on are independant.
!>
+ !> @warning do not use on the output of a function who create or read an
+ !> attribute (ex: tl_att=att_copy(att_init()) is forbidden).
+ !> This will create memory leaks.
!> @warning to avoid infinite loop, do not use any function inside
!> this subroutine
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[out] td_multi1 : file structure
- !> @param[in] td_multi2 : file structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE multi__copy( td_multi1, td_multi2 )
+ !> - November, 2013- Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator (to avoid memory leak)
+ !>
+ !> @param[in] td_multi mpp structure
+ !> @return copy of input multi structure
+ !-------------------------------------------------------------------
+ FUNCTION multi__copy_unit( td_multi )
IMPLICIT NONE
! Argument
- TYPE(TMULTI), INTENT(OUT) :: td_multi1
- TYPE(TMULTI), INTENT(IN) :: td_multi2
+ TYPE(TMULTI), INTENT(IN) :: td_multi
+ ! function
+ TYPE(TMULTI) :: multi__copy_unit
+
+ ! local variable
+ TYPE(TMPP) :: tl_mpp
! loop indices
@@ -87,30 +139,39 @@
!----------------------------------------------------------------
- CALL logger_trace("COPY: mulit file ")
-
- td_multi1%i_nfile = td_multi2%i_nfile
- td_multi1%i_nvar = td_multi2%i_nvar
+ multi__copy_unit%i_nmpp = td_multi%i_nmpp
+ multi__copy_unit%i_nvar = td_multi%i_nvar
! copy variable structure
- IF( ASSOCIATED(td_multi1%t_file) ) DEALLOCATE(td_multi1%t_file)
- IF( ASSOCIATED(td_multi2%t_file) .AND. td_multi1%i_nfile > 0 )THEN
- ALLOCATE( td_multi1%t_file(td_multi1%i_nfile) )
- DO ji=1,td_multi1%i_nfile
- td_multi1%t_file(ji) = td_multi2%t_file(ji)
+ IF( ASSOCIATED(multi__copy_unit%t_mpp) )THEN
+ CALL mpp_clean(multi__copy_unit%t_mpp(:))
+ DEALLOCATE(multi__copy_unit%t_mpp)
+ ENDIF
+ IF( ASSOCIATED(td_multi%t_mpp) .AND. multi__copy_unit%i_nmpp > 0 )THEN
+ ALLOCATE( multi__copy_unit%t_mpp(multi__copy_unit%i_nmpp) )
+ DO ji=1,multi__copy_unit%i_nmpp
+ tl_mpp = mpp_copy(td_multi%t_mpp(ji))
+ multi__copy_unit%t_mpp(ji) = mpp_copy(tl_mpp)
ENDDO
- ENDIF
-
- END SUBROUTINE multi__copy
- !> @endcode
+ ! clean
+ CALL mpp_clean(tl_mpp)
+ ENDIF
+
+ END FUNCTION multi__copy_unit
!-------------------------------------------------------------------
!> @brief This subroutine initialize multi file structure.
- !
+ !>
+ !> @details
+ !> if variable name is 'all', add all the variable of the file in mutli file
+ !> structure.
+ !> @note if first character of filename is numeric, assume matrix is given as
+ !> input.
+ !> create pseudo file named 'data-*', with matrix read as variable value.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_varfile : variable location information (from namelist)
- !> @return td_multi : multi structure
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] cd_varfile variable location information (from namelist)
+ !> @return multi file structure
+ !-------------------------------------------------------------------
FUNCTION multi_init(cd_varfile)
IMPLICIT NONE
@@ -124,17 +185,20 @@
! local variable
CHARACTER(LEN=lc) :: cl_name
+ CHARACTER(LEN=lc) :: cl_lower
CHARACTER(LEN=lc) :: cl_file
CHARACTER(LEN=lc) :: cl_matrix
- INTEGER(i4) :: il_fileid
+ INTEGER(i4) :: il_nvar
+
+ LOGICAL :: ll_dim
TYPE(TVAR) :: tl_var
- TYPE(TFILE) :: tl_file
-
- TYPE(TMULTI) :: tl_multi
+ TYPE(TMPP) :: tl_mpp
! loop indices
INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ INTEGER(i4) :: jk
!----------------------------------------------------------------
@@ -142,31 +206,97 @@
DO WHILE( TRIM(cd_varfile(ji)) /= '' )
- cl_name=fct_lower(fct_split(cd_varfile(ji),1,':'))
+ il_nvar=0
+ cl_name=fct_split(cd_varfile(ji),1,':')
+ cl_lower=fct_lower(cl_name)
cl_file=fct_split(cd_varfile(ji),2,':')
- IF( TRIM(cl_name) /= '' )THEN
+ IF( LEN(TRIM(cl_file)) == lc )THEN
+ CALL logger_fatal("MULTI INIT: file name too long (==256)."//&
+ & " check namelist.")
+ ENDIF
+
+ IF( TRIM(cl_lower) /= '' )THEN
IF( TRIM(cl_file) /= '' )THEN
cl_matrix=''
IF( fct_is_num(cl_file(1:1)) )THEN
cl_matrix=TRIM(cl_file)
- WRITE(cl_file,'(a,i2.2)')'data_',ji
+ WRITE(cl_file,'(a,i2.2)')'data-',ji
+
+ tl_var=var_init(TRIM(cl_name))
+ CALL var_read_matrix(tl_var, cl_matrix)
+
+ ! create mpp structure
+ tl_mpp=mpp_init(TRIM(cl_file), tl_var)
+
+ ! add variable
+ CALL mpp_add_var(tl_mpp,tl_var)
+
+ ! number of variable
+ il_nvar=il_nvar+1
+
+ ELSE
+
+ !
+ tl_mpp=mpp_init( file_init(TRIM(cl_file)) )
+
+ ! define variable
+ IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN
+
+ ! clean var
+ CALL mpp_del_var(tl_mpp)
+
+ tl_var=var_init(TRIM(cl_lower))
+
+ ! add variable
+ CALL mpp_add_var(tl_mpp,tl_var)
+
+ ! number of variable
+ il_nvar=il_nvar+1
+
+ ! clean structure
+ CALL var_clean(tl_var)
+
+ ELSE ! cl_lower == 'all'
+
+ DO jk=tl_mpp%t_proc(1)%i_nvar,1,-1
+
+ ! check if variable is dimension
+ ll_dim=.FALSE.
+ DO jj=1,ip_maxdim
+ IF( TRIM(tl_mpp%t_proc(1)%t_dim(jj)%c_name) == &
+ & TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name) )THEN
+ ll_dim=.TRUE.
+ CALL logger_trace("MULTI INIT: "//&
+ & TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name)//&
+ & ' is var dimension')
+ EXIT
+ ENDIF
+ ENDDO
+ ! do not use variable dimension
+ IF( ll_dim )THEN
+ tl_var=var_init( &
+ & TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name) )
+ ! delete variable
+ CALL mpp_del_var(tl_mpp,tl_var)
+ ! clean structure
+ CALL var_clean(tl_var)
+ ELSE
+ ! number of variable
+ il_nvar=il_nvar+1
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
ENDIF
-
- ! get file id
- tl_file=file_init(TRIM(cl_file))
- il_fileid=multi_add_file(tl_multi,tl_file)
-
- ! define variable
- tl_var=var_init(TRIM(cl_name))
- CALL var_read_matrix(tl_var, cl_matrix)
-
- ! add variable
- CALL file_add_var(tl_multi%t_file(il_fileid),tl_var)
+
+ CALL multi__add_mpp(multi_init, tl_mpp)
! update total number of variable
- tl_multi%i_nvar=tl_multi%i_nvar+1
-
- ! clean structure
- CALL var_clean(tl_var)
+ multi_init%i_nvar=multi_init%i_nvar+il_nvar
+
+ ! clean
+ CALL mpp_clean(tl_mpp)
ELSE
@@ -182,18 +312,13 @@
ENDDO
- ! save result
- multi_init=tl_multi
-
END FUNCTION multi_init
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine clean multi file strucutre.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_multi : multi file structure
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_multi multi file structure
+ !-------------------------------------------------------------------
SUBROUTINE multi_clean(td_multi)
IMPLICIT NONE
@@ -206,30 +331,25 @@
! loop indices
- INTEGER(i4) :: ji
!----------------------------------------------------------------
CALL logger_info( " CLEAN: reset multi file " )
- IF( ASSOCIATED( td_multi%t_file ) )THEN
- DO ji=td_multi%i_nfile,1,-1
- CALL file_clean(td_multi%t_file(ji))
- ENDDO
- DEALLOCATE(td_multi%t_file)
+ IF( ASSOCIATED( td_multi%t_mpp ) )THEN
+ CALL mpp_clean(td_multi%t_mpp(:))
+ DEALLOCATE(td_multi%t_mpp)
ENDIF
! replace by empty structure
- td_multi=tl_multi
+ td_multi=multi_copy(tl_multi)
END SUBROUTINE multi_clean
- ! @endcode
!-------------------------------------------------------------------
!> @brief This subroutine print some information about mpp strucutre.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_mpp : mpp structure
- !-------------------------------------------------------------------
- ! @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_multi multi file structure
+ !-------------------------------------------------------------------
SUBROUTINE multi_print(td_multi)
IMPLICIT NONE
@@ -246,15 +366,16 @@
! print file
- IF( td_multi%i_nfile /= 0 .AND. ASSOCIATED(td_multi%t_file) )THEN
- WRITE(*,'(/a,i3)') 'MULTI: total number of file: ',&
- & td_multi%i_nfile
+ IF( td_multi%i_nmpp /= 0 .AND. ASSOCIATED(td_multi%t_mpp) )THEN
+ WRITE(*,'(/a,i3)') 'MULTI: total number of mpp: ',&
+ & td_multi%i_nmpp
WRITE(*,'(6x,a,i3)') ' total number of variable: ',&
& td_multi%i_nvar
- DO ji=1,td_multi%i_nfile
- WRITE(*,'(3x,3a)') 'FILE ',TRIM(td_multi%t_file(ji)%c_name),&
+ DO ji=1,td_multi%i_nmpp
+ WRITE(*,'(3x,3a)') 'MPP FILE ',TRIM(td_multi%t_mpp(ji)%c_name),&
& ' CONTAINS'
- DO jj=1,td_multi%t_file(ji)%i_nvar
- IF( ASSOCIATED(td_multi%t_file(ji)%t_var) )THEN
- WRITE(*,'(6x,a/)') TRIM(td_multi%t_file(ji)%t_var(jj)%c_name)
+ DO jj=1,td_multi%t_mpp(ji)%t_proc(1)%i_nvar
+ IF( ASSOCIATED(td_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
+ WRITE(*,'(6x,a)') &
+ & TRIM(td_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
ENDIF
ENDDO
@@ -263,5 +384,4 @@
END SUBROUTINE multi_print
- ! @endcode
!-------------------------------------------------------------------
!> @brief
@@ -271,92 +391,102 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_multi : multi file strcuture
- !> @param[in] td_file : file strcuture
- !> @return file id in multi structure
- !-------------------------------------------------------------------
- !> @code
- FUNCTION multi_add_file( td_multi, td_file )
+ !> - November, 2013- Initial Version
+ !> @date October, 2014
+ !> - use mpp file structure instead of file
+ !
+ !> @param[inout] td_multi multi mpp file strcuture
+ !> @param[in] td_mpp mpp file strcuture
+ !> @return mpp file id in multi mpp file structure
+ !-------------------------------------------------------------------
+ SUBROUTINE multi__add_mpp( td_multi, td_mpp )
IMPLICIT NONE
! Argument
TYPE(TMULTI), INTENT(INOUT) :: td_multi
- TYPE(TFILE) , INTENT(IN) :: td_file
-
- ! function
- INTEGER(i4) :: multi_add_file
+ TYPE(TMPP) , INTENT(IN) :: td_mpp
! local variable
INTEGER(i4) :: il_status
- INTEGER(i4) :: il_fileid
- TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_file
+ INTEGER(i4) :: il_mppid
+
+ TYPE(TMPP), DIMENSION(:), ALLOCATABLE :: tl_mpp
+
+ ! loop indices
+ INTEGER(i4) :: ji
!----------------------------------------------------------------
- il_fileid=0
- IF( ASSOCIATED(td_multi%t_file) )THEN
- il_fileid=file_get_id(td_multi%t_file(:),TRIM(td_file%c_name))
- ENDIF
-
- IF( il_fileid /= 0 )THEN
-
- multi_add_file=il_fileid
+ il_mppid=0
+ IF( ASSOCIATED(td_multi%t_mpp) )THEN
+ il_mppid=mpp_get_index(td_multi%t_mpp(:),TRIM(td_mpp%c_name))
+ ENDIF
+
+ IF( il_mppid /= 0 )THEN
+
+ CALL logger_debug( " MULTI ADD FILE: mpp file "//TRIM(td_mpp%c_name)//&
+ & " already in multi mpp file structure")
+
+ ! add new variable
+ DO ji=1,td_mpp%t_proc(1)%i_nvar
+ CALL mpp_add_var(td_multi%t_mpp(il_mppid), td_mpp%t_proc(1)%t_var(ji))
+ ENDDO
ELSE
-
- CALL logger_trace("MULTI ADD FILE: add file "//&
- & TRIM(td_file%c_name)//" in multi structure")
-
- IF( td_multi%i_nfile > 0 )THEN
+
+ CALL logger_trace("MULTI ADD MPP: add mpp "//&
+ & TRIM(td_mpp%c_name)//" in multi mpp file structure")
+
+ IF( td_multi%i_nmpp > 0 )THEN
!
- ! already other file in multi structure
- ALLOCATE( tl_file(td_multi%i_nfile), stat=il_status )
+ ! already other mpp file in multi file structure
+ ALLOCATE( tl_mpp(td_multi%i_nmpp), stat=il_status )
IF(il_status /= 0 )THEN
- CALL logger_error( " MULTI ADD FILE: not enough space to put file &
- & in multi structure")
+ CALL logger_error( " MULTI ADD MPP FILE: not enough space to put &
+ & mpp file in multi mpp file structure")
ELSE
- ! save temporary multi structure
- tl_file(:)=td_multi%t_file(:)
-
- DEALLOCATE( td_multi%t_file )
- ALLOCATE( td_multi%t_file(td_multi%i_nfile+1), stat=il_status)
+ ! save temporary multi file structure
+ tl_mpp(:)=mpp_copy(td_multi%t_mpp(:))
+
+ CALL mpp_clean(td_multi%t_mpp(:))
+ DEALLOCATE( td_multi%t_mpp )
+ ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status)
IF(il_status /= 0 )THEN
- CALL logger_error( " MULTI ADD FILE: not enough space to put "//&
- & "file in multi structure ")
+ CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
+ & "to put mpp file in multi mpp file structure ")
ENDIF
- ! copy file in multi before
- td_multi%t_file(1:td_multi%i_nfile) = tl_file(:)
-
- DEALLOCATE(tl_file)
+ ! copy mpp file in multi mpp file before
+ td_multi%t_mpp(1:td_multi%i_nmpp) = mpp_copy(tl_mpp(:))
+
+ ! clean
+ CALL mpp_clean(tl_mpp(:))
+ DEALLOCATE(tl_mpp)
ENDIF
ELSE
- ! no processor in mpp structure
- IF( ASSOCIATED(td_multi%t_file) )THEN
- DEALLOCATE(td_multi%t_file)
+ ! no file in multi file structure
+ IF( ASSOCIATED(td_multi%t_mpp) )THEN
+ CALL mpp_clean(td_multi%t_mpp(:))
+ DEALLOCATE(td_multi%t_mpp)
ENDIF
- ALLOCATE( td_multi%t_file(td_multi%i_nfile+1), stat=il_status )
+ ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status )
IF(il_status /= 0 )THEN
- CALL logger_error( " MULTI ADD FILE: not enough space to put "//&
- & "file in multi structure " )
+ CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
+ & "to put mpp file in multi mpp file structure " )
ENDIF
ENDIF
- td_multi%i_nfile=td_multi%i_nfile+1
-
- ! add new file
- td_multi%t_file(td_multi%i_nfile)=td_file
-
- multi_add_file=td_multi%i_nfile
-
- ENDIF
- END FUNCTION multi_add_file
- !> @endcode
+ ! update number of mpp
+ td_multi%i_nmpp=td_multi%i_nmpp+1
+
+ ! add new mpp
+ td_multi%t_mpp(td_multi%i_nmpp)=mpp_copy(td_mpp)
+
+ ENDIF
+ END SUBROUTINE multi__add_mpp
END MODULE multi
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/phycst.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/phycst.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/phycst.f90 (revision 5214)
@@ -11,5 +11,5 @@
!> J.paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
+!> @date November, 2013 - Initial Version
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
@@ -19,17 +19,18 @@
IMPLICIT NONE
-
- PUBLIC :: dg_pi !< pi
- PUBLIC :: dg_eps !< epsilon value
- PUBLIC :: dg_rearth !< earth radius (km)
- PUBLIC :: dg_deg2rad !<
- PRIVATE
! NOTE_avoid_public_variables_if_possible
- REAL(dp), PARAMETER :: dg_pi = 3.14159274101257_dp
- REAL(dp), PARAMETER :: dg_eps = EPSILON(1._dp)
- REAL(dp), PARAMETER :: dg_rearth = 6871._dp
- REAL(dp), PARAMETER :: dg_deg2rad = dg_pi/180.0
+ PUBLIC :: dp_pi !< pi
+ PUBLIC :: dp_eps !< epsilon value
+ PUBLIC :: dp_rearth !< earth radius (km)
+ PUBLIC :: dp_deg2rad !< degree to radian ratio
+ PUBLIC :: dp_delta !<
+ REAL(dp), PARAMETER :: dp_pi = 3.14159274101257_dp
+ REAL(dp), PARAMETER :: dp_eps = EPSILON(1._dp)
+ REAL(dp), PARAMETER :: dp_rearth = 6871._dp
+ REAL(dp), PARAMETER :: dp_deg2rad = dp_pi/180.0
+
+ REAL(dp), PARAMETER :: dp_delta=1.e-2
END MODULE phycst
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/variable.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/variable.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/variable.f90 (revision 5214)
@@ -11,28 +11,60 @@
!> @details
!> define type TVAR:
-!> TYPE(TVAR) :: tl_var
+!> @code
+!> TYPE(TVAR) :: tl_var
+!> @endcode
!>
-!> the variable value will always be 4D table of real(8).
+!> @note the variable value inside structure will always be 4D array of real(8).
!> However the variable value could be initialised with
-!> table of real(4), real(8), integer(4) or integer(8)
+!> array of real(4), real(8), integer(4) or integer(8).
!>
!> to initialise a variable structure:
-!> tl_var=var_init( cd_name, [value,] [id_start, [id_count,]] [td_dim,] [td_att] )
+!> @code
+!> tl_var=var_init( cd_name, [value,] [id_start, [id_count,]] [id_type,] [td_dim,] [td_att]... )
+!> @endcode
!> - cd_name is the variable name
-!> - value is a 4D table ordered as ('x','y','z','t') (optional)
-!> (real(4), real(8), integer(4) or integer(8)
-!> - id_start is a integer(4) 1D table of index from which the data
-!> values will be read (optional)
-!> - id_count is a integer(4) 1D table of the number of indices selected
-!> along each dimension (optional)
-!> - td_dim is the table of dimension structure (optional)
-!> - td_att is the table of attribute structure (optional)
+!> - value is a 1D,2D,3D or 4D array, see var_init for more information [optional]
+!> - id_start is a integer(4) 1D array of index from which the data
+!> values will be read [optional]
+!> - id_count is a integer(4) 1D array of the number of indices selected
+!> along each dimension [optional]
+!> - id_type is the type of the variable to be used [optional]
+!> - td_dim is the array of dimension structure [optional]
+!> - td_att is the array of attribute structure [optional]
+!> Note:
+!> - others optionals arguments could be added, see var_init.
+!> - to put variable 0D, use td_dim with all dimension unused
+!> (td_dim(:)%l_use=.FALSE.)
+!>
+!> to print information about variable structure:
+!> @code
+!> CALL var_print(td_var [,ld_more])
+!> @endcode
+!> - td_var is the variable structure
+!> - ld_more to print more infomration about variable
!>
-!> to print information about variable structure:
-!> CALL var_print(tl_var)
+!> to clean variable structure:
+!> @code
+!> CALL var_clean(tl_var)
+!> @endcode
+!>
+!> to copy variable structure in another one (using different memory cell):
+!> @code
+!> tl_var2=var_copy(tl_var1)
+!> @endcode
+!> @note as we use pointer for the value array of the variable structure,
+!> the use of the assignment operator (=) to copy variable structure
+!> create a pointer on the same array.
+!> This is not the case with this copy function.
!>
!> to get variable name:
!> - tl_var\%c_name
-!>
+!>
+!> to get grid point of the variable:
+!> - tl_var\%c_point
+!>
+!> to get EW overlap:
+!> - tl_var\%i_ew
+!>
!> to get variable value:
!> - tl_var\%d_value(:,:,:,:)
@@ -42,5 +74,5 @@
!> - tl_var\%i_type
!>
-!> to get variable id (affected when variable will be added to a file):
+!> to get variable id (read from a file):
!> - tl_var\%i_id
!>
@@ -49,14 +81,15 @@
!> - tl_var\%i_ndim
!>
-!> to get the table of dimension structure (4 elts) associated to the
+!> to get the array of dimension structure (4 elts) associated to the
!> variable:
!> - tl_var\%t_dim(:)
!>
!> Variable attributes
-!> attribue value are always character or real(8) 1D table.
+!> @note attribue value are always character or real(8) 1D array.
+!>
!> to get the number of attributes of the variable:
!> - tl_var\%i_natt
!>
-!> to get the table of attribute structure associated to the
+!> to get the array of attribute structure associated to the
!> variable:
!> - tl_var\%t_att(:)
@@ -66,6 +99,12 @@
!> - tl_var\%c_stdname
!>
+!> to get variable longname:
+!> - tl_var\%c_longname
+!>
!> to get variable units:
!> - tl_var\%c_units
+!>
+!> to get variable axis:
+!> - tl_var\%c_axis
!>
!> to get variable scale factor:
@@ -79,50 +118,169 @@
!>
!> to add value to a variable structure:
-!> CALL var_add_value(tl_var, value, [id_start, [id_count]])
-!> - value : 4D table of value (real(4), real(8), integer(4), integer(8))
-!> - id_start : 1D table of the index in the variable from which the data
+!> @code
+!> CALL var_add_value(tl_var, value, [id_type,] [id_start, [id_count]])
+!> @endcode
+!> - value : 4D array of value (real(4), real(8), integer(1), integer(2), integer(4), integer(8))
+!> - id_type is the type of the variable to be used (default is the type
+!> of array value)
+!> - id_start : 1D array of the index in the variable from which the data
!> values will be read (integer(4), optional)
-!> - id_count : 1D table of the number of indices selected along each
+!> - id_count : 1D array of the number of indices selected along each
!> dimension (integer(4), optional)
!>
-!> to add one attribute to a variable structure:
+!> to add attribute to a variable structure:
+!> @code
!> CALL var_add_att(tl_var, td_att)
-!> - td_att is an attribute structure
+!> @endcode
+!> - td_att is an attribute structure, or array of attribute structure
!>
-!> to add one dimension to a variable structure:
+!> to add dimension to a variable structure:
+!> @code
!> CALL var_add_dim(tl_var, td_dim)
-!> - td_dim is a dimension structure
+!> @endcode
+!> - td_dim is a dimension structure, or array of dimension structure
!>
!> to delete value of a variable structure:
+!> @code
!> CALL var_del_value(tl_var)
+!> @endcode
!>
!> to delete one attribute of a variable structure:
+!> @code
!> CALL var_del_att(tl_var, td_att)
+!> @endcode
!> - td_att is an attribute structure
+!> or
+!> @code
+!> CALL var_del_att(tl_var, cd_name)
+!> @endcode
+!> - cd_name is attribute name
!>
!> to delete one dimension of a variable structure:
+!> @code
!> CALL var_del_dim(tl_var, td_dim)
+!> @endcode
!> - td_dim is a dimension structure
!>
!> to overwrite one attribute structure in variable structure:
+!> @code
!> CALL var_move_att(tl_var, td_att)
+!> @endcode
!> - td_att is an attribute structure
!>
!> to overwrite one dimension structure in variable structure:
+!> @code
!> CALL var_move_dim(tl_var, td_dim)
+!> @endcode
!> - td_dim is a dimension structure
!>
+!> to get the mask of a variable strucutre, (based on its FillValue):
+!> @code
+!> mask(:,:)=var_get_mask(tl_var)
+!> @endcode
+!>
+!> to change FillValue to standard NETCDF Fill Value:
+!> @code
+!> CALL var_chg_FillValue(tl_var, [dd_fill])
+!> @endcode
+!> - dd_fill is the FillValue to be used [optional]
+!>
+!> to concatenate two variables:
+!> @code
+!> tl_var=var_concat(tl_var1, tl_var2, [DIM])
+!> @endcode
+!> - tl_var1 : variable structure
+!> - tl_var2 : variable structure
+!> - DIM : number of the dimension following which concatenate (1=>I, 2=>J, 3=>Z, 4=>T) [optional, default=4]
+!>
+!> to forced min and max value of a variable:
+!> define min and max value of the variable:
+!> tl_var\%d_min=min
+!> tl_var\%d_max=max
+!> then
+!> @code
+!> CALL var_limit_value( tl_var )
+!> @endcode
+!> - min and max : real(8) value
+!>
+!> to get the biggest dimensions use in a array of variable:
+!> @code
+!> tl_dim(:)=var_max_dim(tl_var(:))
+!> @endcode
+!> - tl_var(:) : array of variable structure
+!> - tl_dim(:) : array (4 elts) of dimension structure
+!>
+!> to reorder dimension of a variable (default 'x','y','z','t'):
+!> @code
+!> CALL var_reorder( td_var, cd_dimorder )
+!> @endcode
+!> - td_var is variable structure
+!> - cd_dimorder string character(LEN=4) of dimension order to be used (example:
+!> 'yxzt') [optional]
+!>
+!> to get variable index, in an array of variable structure:
+!> @code
+!> il_index=var_get_index( td_var, cd_name )
+!> @endcode
+!> - td_var array of variable structure
+!> - cd_name variable name
+!>
+!> to get variable id, read from a file:
+!>@code
+!> il_id=var_get_id( td_var, cd_name )
+!>@endcode
+!> - td_var array of variable structure
+!> - cd_name variable name
+!>
+!> to get free variable unit in an array of variable structure:
+!>@code
+!> il_unit=var_get_unit(td_var)
+!>@endcode
+!> - td_var array of variable structure
+!>
+!> to convert time variable structure in date structure:
+!>@code
+!> tl_date=var_to_date(td_var)
+!>@endcode
+!> - td_var is time variable structure
+!> - tl_date is date structure
+!>
+!> to read matrix value from character string in namelist
+!>@code
+!> CALL var_read_matrix(td_var, cd_matrix)
+!>@endcode
+!> - td_var is variable structure
+!> - cd_matrix is matrix value
+!>
+!> to read variable configuration file ('variable.cfg') and fill global array
+!> of variable structure:
+!>@code
+!> CALL var_def_extra( cd_file )
+!>@endcode
+!> - cd_file is filename
+!>
+!> to add variable information get from namelist, in global array of variable
+!> structure:
+!>@code
+!> CALL var_chg_extra( cd_varinfo )
+!>@endcode
+!> - cd_varinfo is variable information from namelist
+!>
+!> to check variable dimension expected, as defined in file 'variable.cfg':
+!>@code
+!> CALL var_check_dim( td_var )
+!>@endcode
+!> - td_var is variable structure
+!>
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
+!> @date November, 2013 - Initial Version
+!> @date September, 2014
+!> - add var_reorder
+!> @date November, 2014
+!> - Fix memory leaks bug
!
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!> @todo
-!> - manage ew_wrap in structure
-!> - manage c_point in structure
-!> - think about create init for 0D 1D 2D 3D input table
-!> - creer module cfg qui lit et def tg_varcfg (pb var_get_extra appele ds
-!> var_init)
!----------------------------------------------------------------------
MODULE var
@@ -130,10 +288,10 @@
USE global ! global variable
USE kind ! F90 kind parameter
- USE logger ! log file manager
+ USE logger ! log file manager
+ USE date ! date manager
USE fct ! basic useful function
USE att ! attribute manager
USE dim ! dimension manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
@@ -141,90 +299,97 @@
PUBLIC :: TVAR !< variable structure
- PUBLIC :: tg_varextra !< table of variable structure with extra information.
+ PUBLIC :: tg_varextra !< array of variable structure with extra information.
! function and subroutine
- PUBLIC :: ASSIGNMENT(=) !< copy variable structure
- PUBLIC :: var_init !< initialize variable structure
- PUBLIC :: var_print !< print variable information
- PUBLIC :: var_clean !< clean variable structure
- PUBLIC :: var_get_id !< return the variable id, from a table of variable structure
- PUBLIC :: var_add_value !< add table of value in variable structure
- PUBLIC :: var_add_att !< add attribute structure in variable structure
- PUBLIC :: var_add_dim !< add dimension structure in variable structure
- PUBLIC :: var_del_value !< delete table of value of variable structure
- PUBLIC :: var_del_att !< delete one attribute structure of variable structure
- PUBLIC :: var_del_dim !< delete one dimension structure of variable structure
- PUBLIC :: var_move_att !< overwrite one attribute structure in variable structure
- PUBLIC :: var_move_dim !< overwrite one dimension structure in variable structure
- PUBLIC :: var_get_mask !< return the mask of variable
- PUBLIC :: var_chg_FillValue !< change FillValue to standard NETCDF Fill Value
- PUBLIC :: var_def_extra !< read variable configuration file, and save extra information.
- PUBLIC :: var_chg_extra !< read variable namelist information, and modify extra information.
- PUBLIC :: var_read_matrix !<
-! PUBLIC :: var_match_file !< read variable namelist information, and modify extra information.
- PUBLIC :: var_max_dim !< get table of maximum dimension use
- PUBLIC :: var_concat !< concatenate two variables
- PUBLIC :: var_limit_value !< forced min and max value
- PUBLIC :: var_check_dim !< check variable dimension expected
-
-! PUBLIC :: var_ended !< deallocate global variable
-
- PRIVATE :: var__add_value_dp !< add table of value real(8) in variable structure
- PRIVATE :: var__add_value_rp !< add table of value real(4) in variable structure
- PRIVATE :: var__add_value_i1 !< add table of value integer(1) in variable structure
- PRIVATE :: var__add_value_i2 !< add table of value integer(2) in variable structure
- PRIVATE :: var__add_value_i4 !< add table of value integer(4) in variable structure
- PRIVATE :: var__add_value_i8 !< add table of value integer(8) in variable structure
- PRIVATE :: var__init !< initialse variable structure without table of value
- PRIVATE :: var__init_dp !< initialse variable structure with real(8) 4D table of value
- PRIVATE :: var__init_1D_dp !< initialse variable structure with real(8) 1D table of value
- PRIVATE :: var__init_2D_dp !< initialse variable structure with real(8) 2D table of value
- PRIVATE :: var__init_3D_dp !< initialse variable structure with real(8) 3D table of value
- PRIVATE :: var__init_sp !< initialse variable structure with real(4) 4D table of value
- PRIVATE :: var__init_1D_sp !< initialse variable structure with real(4) 1D table of value
- PRIVATE :: var__init_2D_sp !< initialse variable structure with real(4) 2D table of value
- PRIVATE :: var__init_3D_sp !< initialse variable structure with real(4) 3D table of value
- PRIVATE :: var__init_i1 !< initialse variable structure with integer(1) 4D table of value
- PRIVATE :: var__init_1D_i1 !< initialse variable structure with integer(1) 1D table of value
- PRIVATE :: var__init_2D_i1 !< initialse variable structure with integer(1) 2D table of value
- PRIVATE :: var__init_3D_i1 !< initialse variable structure with integer(1) 3D table of value
- PRIVATE :: var__init_i2 !< initialse variable structure with integer(2) 4D table of value
- PRIVATE :: var__init_1D_i2 !< initialse variable structure with integer(2) 1D table of value
- PRIVATE :: var__init_2D_i2 !< initialse variable structure with integer(2) 2D table of value
- PRIVATE :: var__init_3D_i2 !< initialse variable structure with integer(2) 3D table of value
- PRIVATE :: var__init_i4 !< initialse variable structure with integer(4) 4D table of value
- PRIVATE :: var__init_1D_i4 !< initialse variable structure with integer(4) 1D table of value
- PRIVATE :: var__init_2D_i4 !< initialse variable structure with integer(4) 2D table of value
- PRIVATE :: var__init_3D_i4 !< initialse variable structure with integer(4) 3D table of value
- PRIVATE :: var__init_i8 !< initialse variable structure with integer(8) 4D table of value
- PRIVATE :: var__init_1D_i8 !< initialse variable structure with integer(8) 1D table of value
- PRIVATE :: var__init_2D_i8 !< initialse variable structure with integer(8) 2D table of value
- PRIVATE :: var__init_3D_i8 !< initialse variable structure with integer(8) 3D table of value
- PRIVATE :: var__add_dim_unit !< add one dimension structure in variable structure
- PRIVATE :: var__add_dim_tab !< add a table of dimension structure in variable structure
- PRIVATE :: var__add_att_unit !< add one attribute structure in variable structure
- PRIVATE :: var__add_att_tab !< add a table of attribute structure in variable structure
- PRIVATE :: var__add_dim !< add a dimension structure in a variable structure.
- PRIVATE :: var__add_value !< add a 4D table of double value in a variable structure.
- PRIVATE :: var__copy_unit !< copy variable structure
- PRIVATE :: var__copy_tab !< copy variable structure
- PRIVATE :: var__get_extra !< add extra information in variable structure
- PRIVATE :: var__concat_i !< concatenate varibales in i-direction
- PRIVATE :: var__concat_j !< concatenate varibales in j-direction
- PRIVATE :: var__concat_k !< concatenate varibales in k-direction
- PRIVATE :: var__concat_l !< concatenate varibales in l-direction
- PRIVATE :: var__get_max !< get maximum value from namelist
- PRIVATE :: var__get_min !< get minimum value from namelist
- PRIVATE :: var__get_interp !< get interpolation method from namelist
- PRIVATE :: var__get_extrap !< get extrapolation method from namelist
- PRIVATE :: var__get_filter !< get filter method from namelist
-
- !> @struct TVAR
- TYPE TVAR
+ PUBLIC :: var_init !< initialize variable structure
+ PUBLIC :: var_print !< print variable information
+ PUBLIC :: var_clean !< clean variable structure
+ PUBLIC :: var_copy !< copy variable structure
+ PUBLIC :: var_add_value !< add array of value in variable structure
+ PUBLIC :: var_add_att !< add attribute structure in variable structure
+ PUBLIC :: var_add_dim !< add dimension structure in variable structure
+ PUBLIC :: var_del_value !< delete array of value of variable structure
+ PUBLIC :: var_del_att !< delete one attribute structure of variable structure
+ PUBLIC :: var_del_dim !< delete one dimension structure of variable structure
+ PUBLIC :: var_move_att !< overwrite one attribute structure in variable structure
+ PUBLIC :: var_move_dim !< overwrite one dimension structure in variable structure
+ PUBLIC :: var_get_mask !< return the mask of variable
+ PUBLIC :: var_chg_FillValue !< change FillValue to standard NETCDF Fill Value
+ PUBLIC :: var_concat !< concatenate two variables
+ PUBLIC :: var_limit_value !< forced min and max value
+ PUBLIC :: var_max_dim !< get array of maximum dimension use
+ PUBLIC :: var_reorder !< reorder table of value in variable structure
+ PUBLIC :: var_get_index !< return the variable index, in an array of variable structure
+ PUBLIC :: var_get_id !< return the variable id, read from a file
+ PUBLIC :: var_get_unit !< get free variable unit in an array of variable structure
+ PUBLIC :: var_to_date !< convert time variable structure in date structure
+ PUBLIC :: var_read_matrix !< read matrix value from character string in namelist
+ PUBLIC :: var_def_extra !< read variable configuration file, and save extra information.
+ PUBLIC :: var_chg_extra !< read variable namelist information, and modify extra information.
+ PUBLIC :: var_check_dim !< check variable dimension expected
+
+ PRIVATE :: var__init ! initialize variable structure without array of value
+ PRIVATE :: var__init_dp ! initialize variable structure with real(8) 4D array of value
+ PRIVATE :: var__init_1D_dp ! initialize variable structure with real(8) 1D array of value
+ PRIVATE :: var__init_2D_dp ! initialize variable structure with real(8) 2D array of value
+ PRIVATE :: var__init_3D_dp ! initialize variable structure with real(8) 3D array of value
+ PRIVATE :: var__init_sp ! initialize variable structure with real(4) 4D array of value
+ PRIVATE :: var__init_1D_sp ! initialize variable structure with real(4) 1D array of value
+ PRIVATE :: var__init_2D_sp ! initialize variable structure with real(4) 2D array of value
+ PRIVATE :: var__init_3D_sp ! initialize variable structure with real(4) 3D array of value
+ PRIVATE :: var__init_i1 ! initialize variable structure with integer(1) 4D array of value
+ PRIVATE :: var__init_1D_i1 ! initialize variable structure with integer(1) 1D array of value
+ PRIVATE :: var__init_2D_i1 ! initialize variable structure with integer(1) 2D array of value
+ PRIVATE :: var__init_3D_i1 ! initialize variable structure with integer(1) 3D array of value
+ PRIVATE :: var__init_i2 ! initialize variable structure with integer(2) 4D array of value
+ PRIVATE :: var__init_1D_i2 ! initialize variable structure with integer(2) 1D array of value
+ PRIVATE :: var__init_2D_i2 ! initialize variable structure with integer(2) 2D array of value
+ PRIVATE :: var__init_3D_i2 ! initialize variable structure with integer(2) 3D array of value
+ PRIVATE :: var__init_i4 ! initialize variable structure with integer(4) 4D array of value
+ PRIVATE :: var__init_1D_i4 ! initialize variable structure with integer(4) 1D array of value
+ PRIVATE :: var__init_2D_i4 ! initialize variable structure with integer(4) 2D array of value
+ PRIVATE :: var__init_3D_i4 ! initialize variable structure with integer(4) 3D array of value
+ PRIVATE :: var__init_i8 ! initialize variable structure with integer(8) 4D array of value
+ PRIVATE :: var__init_1D_i8 ! initialize variable structure with integer(8) 1D array of value
+ PRIVATE :: var__init_2D_i8 ! initialize variable structure with integer(8) 2D array of value
+ PRIVATE :: var__init_3D_i8 ! initialize variable structure with integer(8) 3D array of value
+ PRIVATE :: var__print_unit ! print information on one variable
+ PRIVATE :: var__print_arr ! print information on a array of variables
+ PRIVATE :: var__clean_unit ! clean variable structure
+ PRIVATE :: var__clean_arr_1D ! clean 1D array of variable structure
+ PRIVATE :: var__clean_arr_2D ! clean 2D array of variable structure
+ PRIVATE :: var__clean_arr_3D ! clean 3D array of variable structure
+ PRIVATE :: var__add_value_dp ! add array of value real(8) in variable structure
+ PRIVATE :: var__add_value_rp ! add array of value real(4) in variable structure
+ PRIVATE :: var__add_value_i1 ! add array of value integer(1) in variable structure
+ PRIVATE :: var__add_value_i2 ! add array of value integer(2) in variable structure
+ PRIVATE :: var__add_value_i4 ! add array of value integer(4) in variable structure
+ PRIVATE :: var__add_value_i8 ! add array of value integer(8) in variable structure
+ PRIVATE :: var__add_att_unit ! add one attribute structure in variable structure
+ PRIVATE :: var__add_att_arr ! add a array of attribute structure in variable structure
+ PRIVATE :: var__del_att_name ! delete one attribute given attribute name
+ PRIVATE :: var__del_att_str ! delete one attribute given attribute structure
+ PRIVATE :: var__add_dim_unit ! add one dimension structure in variable structure
+ PRIVATE :: var__add_dim_arr ! add a array of dimension structure in variable structure
+ PRIVATE :: var__add_value ! add a 4D array of real(8) value in a variable structure.
+ PRIVATE :: var__copy_unit ! copy variable structure
+ PRIVATE :: var__copy_arr ! copy a array of variable structure
+ PRIVATE :: var__get_extra ! add extra information in variable structure
+ PRIVATE :: var__concat_i ! concatenate varibales in i-direction
+ PRIVATE :: var__concat_j ! concatenate varibales in j-direction
+ PRIVATE :: var__concat_k ! concatenate varibales in k-direction
+ PRIVATE :: var__concat_l ! concatenate varibales in l-direction
+ PRIVATE :: var__get_max ! get maximum value from namelist
+ PRIVATE :: var__get_min ! get minimum value from namelist
+ PRIVATE :: var__get_interp ! get interpolation method from namelist
+ PRIVATE :: var__get_extrap ! get extrapolation method from namelist
+ PRIVATE :: var__get_filter ! get filter method from namelist
+
+ TYPE TVAR !< variable structure
CHARACTER(LEN=lc) :: c_name = '' !< variable name
- CHARACTER(LEN=lc) :: c_point = '' !< type of grid point
+ CHARACTER(LEN=lc) :: c_point = 'T' !< ARAKAWA C-grid point name (T,U,V,F)
INTEGER(i4) :: i_id = 0 !< variable id
- INTEGER(i4) :: i_ew = 0 !< east-west overlap
+ INTEGER(i4) :: i_ew = -1 !< east-west overlap
REAL(dp) , DIMENSION(:,:,:,:), POINTER :: d_value => NULL() !< variable value
@@ -237,5 +402,7 @@
TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< variable dimension
- ! highlight some attribute
+ LOGICAL :: l_file = .FALSE. !< variable read in a file
+
+ ! highlight some attributes
CHARACTER(LEN=lc) :: c_stdname = ''!< variable standard name
CHARACTER(LEN=lc) :: c_longname = ''!< variable long name
@@ -245,6 +412,6 @@
REAL(dp) :: d_ofs = 0. !< offset
REAL(dp) :: d_fill= 0. !< fill value ! NF90_FILL_DOUBLE
- REAL(dp) :: d_min = dg_fill !< minimum value
- REAL(dp) :: d_max = dg_fill !< maximum value
+ REAL(dp) :: d_min = dp_fill !< minimum value
+ REAL(dp) :: d_max = dp_fill !< maximum value
!!! netcdf4
@@ -256,5 +423,5 @@
!!! dimg
- INTEGER(i4) :: i_rec = 0 !< record number
+ INTEGER(i4) :: i_rec = 0 !< record number
CHARACTER(LEN=lc), DIMENSION(2) :: c_interp = '' !< interpolation method
@@ -264,83 +431,104 @@
END TYPE TVAR
- TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tg_varextra !< table of variable structure with extra information.
+ TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tg_varextra !< array of variable structure with extra information.
!< fill when running var_def_extra()
+ INTERFACE var_init
+ MODULE PROCEDURE var__init ! initialize variable structure without array of value
+ MODULE PROCEDURE var__init_dp ! initialize variable structure with real(8) 4D array of value
+ MODULE PROCEDURE var__init_1D_dp ! initialize variable structure with real(8) 1D array of value
+ MODULE PROCEDURE var__init_2D_dp ! initialize variable structure with real(8) 2D array of value
+ MODULE PROCEDURE var__init_3D_dp ! initialize variable structure with real(8) 3D array of value
+ MODULE PROCEDURE var__init_sp ! initialize variable structure with real(4) 4D array of value
+ MODULE PROCEDURE var__init_1D_sp ! initialize variable structure with real(4) 1D array of value
+ MODULE PROCEDURE var__init_2D_sp ! initialize variable structure with real(4) 2D array of value
+ MODULE PROCEDURE var__init_3D_sp ! initialize variable structure with real(4) 3D array of value
+ MODULE PROCEDURE var__init_i1 ! initialize variable structure with integer(1) 4D array of value
+ MODULE PROCEDURE var__init_1D_i1 ! initialize variable structure with integer(1) 1D array of value
+ MODULE PROCEDURE var__init_2D_i1 ! initialize variable structure with integer(1) 2D array of value
+ MODULE PROCEDURE var__init_3D_i1 ! initialize variable structure with integer(1) 3D array of value
+ MODULE PROCEDURE var__init_i2 ! initialize variable structure with integer(2) 4D array of value
+ MODULE PROCEDURE var__init_1D_i2 ! initialize variable structure with integer(2) 1D array of value
+ MODULE PROCEDURE var__init_2D_i2 ! initialize variable structure with integer(2) 2D array of value
+ MODULE PROCEDURE var__init_3D_i2 ! initialize variable structure with integer(2) 3D array of value
+ MODULE PROCEDURE var__init_i4 ! initialize variable structure with integer(4) 4D array of value
+ MODULE PROCEDURE var__init_1D_i4 ! initialize variable structure with integer(4) 1D array of value
+ MODULE PROCEDURE var__init_2D_i4 ! initialize variable structure with integer(4) 2D array of value
+ MODULE PROCEDURE var__init_3D_i4 ! initialize variable structure with integer(4) 3D array of value
+ MODULE PROCEDURE var__init_i8 ! initialize variable structure with integer(8) 4D array of value
+ MODULE PROCEDURE var__init_1D_i8 ! initialize variable structure with integer(8) 1D array of value
+ MODULE PROCEDURE var__init_2D_i8 ! initialize variable structure with integer(8) 2D array of value
+ MODULE PROCEDURE var__init_3D_i8 ! initialize variable structure with integer(8) 3D array of value
+ END INTERFACE var_init
+
+ INTERFACE var_print
+ MODULE PROCEDURE var__print_unit ! print information on one variable
+ MODULE PROCEDURE var__print_arr ! print information on a array of variables
+ END INTERFACE var_print
+
+ INTERFACE var_clean
+ MODULE PROCEDURE var__clean_unit
+ MODULE PROCEDURE var__clean_arr_1D
+ MODULE PROCEDURE var__clean_arr_2D
+ MODULE PROCEDURE var__clean_arr_3D
+ END INTERFACE
+
INTERFACE var_add_value
- MODULE PROCEDURE var__add_value_dp ! add table of value real(8) in variable structure
- MODULE PROCEDURE var__add_value_rp ! add table of value real(4) in variable structure
- MODULE PROCEDURE var__add_value_i1 ! add table of value integer(1) in variable structure
- MODULE PROCEDURE var__add_value_i2 ! add table of value integer(2) in variable structure
- MODULE PROCEDURE var__add_value_i4 ! add table of value integer(4) in variable structure
- MODULE PROCEDURE var__add_value_i8 ! add table of value integer(8) in variable structure
+ MODULE PROCEDURE var__add_value_dp ! add array of value real(8) in variable structure
+ MODULE PROCEDURE var__add_value_rp ! add array of value real(4) in variable structure
+ MODULE PROCEDURE var__add_value_i1 ! add array of value integer(1) in variable structure
+ MODULE PROCEDURE var__add_value_i2 ! add array of value integer(2) in variable structure
+ MODULE PROCEDURE var__add_value_i4 ! add array of value integer(4) in variable structure
+ MODULE PROCEDURE var__add_value_i8 ! add array of value integer(8) in variable structure
END INTERFACE var_add_value
- INTERFACE var_init
- MODULE PROCEDURE var__init ! initialse variable structure without table of value
- MODULE PROCEDURE var__init_dp ! initialse variable structure with real(8) 4D table of value
- MODULE PROCEDURE var__init_1D_dp ! initialse variable structure with real(8) 1D table of value
- MODULE PROCEDURE var__init_2D_dp ! initialse variable structure with real(8) 2D table of value
- MODULE PROCEDURE var__init_3D_dp ! initialse variable structure with real(8) 3D table of value
- MODULE PROCEDURE var__init_sp ! initialse variable structure with real(4) 4D table of value
- MODULE PROCEDURE var__init_1D_sp ! initialse variable structure with real(4) 1D table of value
- MODULE PROCEDURE var__init_2D_sp ! initialse variable structure with real(4) 2D table of value
- MODULE PROCEDURE var__init_3D_sp ! initialse variable structure with real(4) 3D table of value
- MODULE PROCEDURE var__init_i1 ! initialse variable structure with integer(1) 4D table of value
- MODULE PROCEDURE var__init_1D_i1 ! initialse variable structure with integer(1) 1D table of value
- MODULE PROCEDURE var__init_2D_i1 ! initialse variable structure with integer(1) 2D table of value
- MODULE PROCEDURE var__init_3D_i1 ! initialse variable structure with integer(1) 3D table of value
- MODULE PROCEDURE var__init_i2 ! initialse variable structure with integer(2) 4D table of value
- MODULE PROCEDURE var__init_1D_i2 ! initialse variable structure with integer(2) 1D table of value
- MODULE PROCEDURE var__init_2D_i2 ! initialse variable structure with integer(2) 2D table of value
- MODULE PROCEDURE var__init_3D_i2 ! initialse variable structure with integer(2) 3D table of value
- MODULE PROCEDURE var__init_i4 ! initialse variable structure with integer(4) 4D table of value
- MODULE PROCEDURE var__init_1D_i4 ! initialse variable structure with integer(4) 1D table of value
- MODULE PROCEDURE var__init_2D_i4 ! initialse variable structure with integer(4) 2D table of value
- MODULE PROCEDURE var__init_3D_i4 ! initialse variable structure with integer(4) 3D table of value
- MODULE PROCEDURE var__init_i8 ! initialse variable structure with integer(8) 4D table of value
- MODULE PROCEDURE var__init_1D_i8 ! initialse variable structure with integer(8) 1D table of value
- MODULE PROCEDURE var__init_2D_i8 ! initialse variable structure with integer(8) 2D table of value
- MODULE PROCEDURE var__init_3D_i8 ! initialse variable structure with integer(8) 3D table of value
- END INTERFACE var_init
+ INTERFACE var_add_att
+ MODULE PROCEDURE var__add_att_unit ! add one attribute structure in variable structure
+ MODULE PROCEDURE var__add_att_arr ! add a array of attribute structure in variable structure
+ END INTERFACE var_add_att
+
+ INTERFACE var_del_att ! delete one attribute in variable structure
+ MODULE PROCEDURE var__del_att_name ! - given attribute name
+ MODULE PROCEDURE var__del_att_str ! - given attribute structure
+ END INTERFACE var_del_att
INTERFACE var_add_dim
MODULE PROCEDURE var__add_dim_unit ! add one dimension structure in variable structure
- MODULE PROCEDURE var__add_dim_tab ! add a table of dimension structure in variable structure
+ MODULE PROCEDURE var__add_dim_arr ! add a array of dimension structure in variable structure
END INTERFACE var_add_dim
- INTERFACE var_add_att
- MODULE PROCEDURE var__add_att_unit ! add one attribute structure in variable structure
- MODULE PROCEDURE var__add_att_tab ! add a table of attribute structure in variable structure
- END INTERFACE var_add_att
-
- INTERFACE ASSIGNMENT(=)
+ INTERFACE var_copy
MODULE PROCEDURE var__copy_unit ! copy variable structure
- MODULE PROCEDURE var__copy_tab ! copy variable structure
+ MODULE PROCEDURE var__copy_arr ! copy variable structure
END INTERFACE
CONTAINS
!-------------------------------------------------------------------
!> @brief
- !> This subroutine copy variable structure in another variable
- !> structure
+ !> This subroutine copy variable structure in another one
!> @details
- !> variable value are copied in a temporary table, so input and output
+ !> variable value are copied in a temporary array, so input and output
!> variable structure value do not point on the same "memory cell", and so
!> are independant.
!>
+ !> @warning do not use on the output of a function who create or read an
+ !> structure (ex: tl_var=var_copy(var_init()) is forbidden).
+ !> This will create memory leaks.
!> @warning to avoid infinite loop, do not use any function inside
!> this subroutine
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[out] td_var1 : variable structure
- !> @param[in] td_var2 : variable structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__copy_unit( td_var1, td_var2 )
+ !> - November, 2013- Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator (to avoid memory leak)
+ !
+ !> @param[in] td_var variable structure
+ !> @return copy of input variable structure
+ !-------------------------------------------------------------------
+ FUNCTION var__copy_unit( td_var )
IMPLICIT NONE
! Argument
- TYPE(TVAR), INTENT(OUT) :: td_var1
- TYPE(TVAR), INTENT(IN) :: td_var2
+ TYPE(TVAR), INTENT(IN) :: td_var
+ ! function
+ TYPE(TVAR) :: var__copy_unit
! local variable
@@ -353,97 +541,104 @@
! copy variable name, id, ..
- td_var1%c_name = TRIM(td_var2%c_name)
- td_var1%c_point = TRIM(td_var2%c_point)
- td_var1%i_id = td_var2%i_id
- td_var1%i_ew = td_var2%i_ew
-
- td_var1%d_min = td_var2%d_min
- td_var1%d_max = td_var2%d_max
-
- td_var1%i_type = td_var2%i_type
- td_var1%i_natt = td_var2%i_natt
- td_var1%i_ndim = td_var2%i_ndim
- td_var1%i_ndim = td_var2%i_ndim
+ var__copy_unit%c_name = TRIM(td_var%c_name)
+ var__copy_unit%c_point = TRIM(td_var%c_point)
+ var__copy_unit%i_id = td_var%i_id
+ var__copy_unit%i_ew = td_var%i_ew
+
+ var__copy_unit%d_min = td_var%d_min
+ var__copy_unit%d_max = td_var%d_max
+
+ var__copy_unit%i_type = td_var%i_type
+ var__copy_unit%i_natt = td_var%i_natt
+ var__copy_unit%i_ndim = td_var%i_ndim
+ var__copy_unit%i_ndim = td_var%i_ndim
! copy dimension
- td_var1%t_dim(:) = td_var2%t_dim(:)
+ var__copy_unit%t_dim(:) = dim_copy(td_var%t_dim(:))
! copy attribute
- IF( ASSOCIATED(td_var1%t_att) ) DEALLOCATE(td_var1%t_att)
- IF( ASSOCIATED(td_var2%t_att) .AND. td_var1%i_natt > 0 )THEN
- ALLOCATE( td_var1%t_att(td_var1%i_natt) )
- DO ji=1,td_var1%i_natt
- tl_att=td_var2%t_att(ji)
- td_var1%t_att(ji)=tl_att
+ IF( ASSOCIATED(var__copy_unit%t_att) )THEN
+ CALL att_clean( var__copy_unit%t_att(:) )
+ DEALLOCATE(var__copy_unit%t_att)
+ ENDIF
+ IF( ASSOCIATED(td_var%t_att) .AND. var__copy_unit%i_natt > 0 )THEN
+ ALLOCATE( var__copy_unit%t_att(var__copy_unit%i_natt) )
+ DO ji=1,var__copy_unit%i_natt
+ tl_att=att_copy(td_var%t_att(ji))
+ var__copy_unit%t_att(ji)=att_copy(tl_att)
ENDDO
+ ! clean
+ CALL att_clean(tl_att)
ENDIF
! copy highlight attribute
- td_var1%c_stdname = TRIM(td_var2%c_stdname)
- td_var1%c_longname = TRIM(td_var2%c_longname)
- td_var1%c_units = TRIM(td_var2%c_units)
- td_var1%c_axis = TRIM(td_var2%c_axis)
- td_var1%d_scf = td_var2%d_scf
- td_var1%d_ofs = td_var2%d_ofs
- td_var1%d_fill = td_var2%d_fill
+ var__copy_unit%c_stdname = TRIM(td_var%c_stdname)
+ var__copy_unit%c_longname = TRIM(td_var%c_longname)
+ var__copy_unit%c_units = TRIM(td_var%c_units)
+ var__copy_unit%c_axis = TRIM(td_var%c_axis)
+ var__copy_unit%d_scf = td_var%d_scf
+ var__copy_unit%d_ofs = td_var%d_ofs
+ var__copy_unit%d_fill = td_var%d_fill
! copy netcdf4 variable
- td_var1%l_contiguous = td_var2%l_contiguous
- td_var1%l_shuffle = td_var2%l_shuffle
- td_var1%l_fletcher32 = td_var2%l_fletcher32
- td_var1%i_deflvl = td_var2%i_deflvl
- td_var1%i_chunksz(:) = td_var2%i_chunksz(:)
+ var__copy_unit%l_contiguous = td_var%l_contiguous
+ var__copy_unit%l_shuffle = td_var%l_shuffle
+ var__copy_unit%l_fletcher32 = td_var%l_fletcher32
+ var__copy_unit%i_deflvl = td_var%i_deflvl
+ var__copy_unit%i_chunksz(:) = td_var%i_chunksz(:)
! copy dimg variable
- td_var1%i_rec = td_var2%i_rec
+ var__copy_unit%i_rec = td_var%i_rec
! copy pointer in an independant variable
- IF( ASSOCIATED(td_var1%d_value) ) DEALLOCATE(td_var1%d_value)
- IF( ASSOCIATED(td_var2%d_value) )THEN
- ALLOCATE( dl_value( td_var2%t_dim(1)%i_len, &
- & td_var2%t_dim(2)%i_len, &
- & td_var2%t_dim(3)%i_len, &
- & td_var2%t_dim(4)%i_len ) )
- dl_value(:,:,:,:)=td_var2%d_value(:,:,:,:)
-
- ALLOCATE( td_var1%d_value( td_var1%t_dim(1)%i_len, &
- & td_var1%t_dim(2)%i_len, &
- & td_var1%t_dim(3)%i_len, &
- & td_var1%t_dim(4)%i_len ) )
- td_var1%d_value(:,:,:,:)=dl_value(:,:,:,:)
+ IF( ASSOCIATED(var__copy_unit%d_value) ) DEALLOCATE(var__copy_unit%d_value)
+ IF( ASSOCIATED(td_var%d_value) )THEN
+ ALLOCATE( dl_value( td_var%t_dim(1)%i_len, &
+ & td_var%t_dim(2)%i_len, &
+ & td_var%t_dim(3)%i_len, &
+ & td_var%t_dim(4)%i_len ) )
+ dl_value(:,:,:,:)=td_var%d_value(:,:,:,:)
+
+ ALLOCATE( var__copy_unit%d_value( var__copy_unit%t_dim(1)%i_len, &
+ & var__copy_unit%t_dim(2)%i_len, &
+ & var__copy_unit%t_dim(3)%i_len, &
+ & var__copy_unit%t_dim(4)%i_len ) )
+ var__copy_unit%d_value(:,:,:,:)=dl_value(:,:,:,:)
DEALLOCATE( dl_value )
ENDIF
- td_var1%c_interp(:)=td_var2%c_interp(:)
- td_var1%c_extrap(:)=td_var2%c_extrap(:)
- td_var1%c_filter(:)=td_var2%c_filter(:)
-
- END SUBROUTINE var__copy_unit
- !> @endcode
+ var__copy_unit%c_interp(:)=td_var%c_interp(:)
+ var__copy_unit%c_extrap(:)=td_var%c_extrap(:)
+ var__copy_unit%c_filter(:)=td_var%c_filter(:)
+
+ END FUNCTION var__copy_unit
!-------------------------------------------------------------------
!> @brief
- !> This subroutine copy variable structure in another variable
- !> structure
+ !> This subroutine copy a array of variable structure in another one
!> @details
- !> variable value are copied in a temporary table, so input and output
- !> variable structure value do not point on the same "memory cell", and so
- !> are independant.
- !>
+ !> see var__copy_unit
+ !>
+ !> @warning do not use on the output of a function who create or read an
+ !> structure (ex: tl_var=var_copy(var_init()) is forbidden).
+ !> This will create memory leaks.
!> @warning to avoid infinite loop, do not use any function inside
!> this subroutine
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[out] td_var1 : variable structure
- !> @param[in] td_var2 : variable structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__copy_tab( td_var1, td_var2 )
+ !> - November, 2013- Initial Version
+ !> @date November, 2014
+ !> - use function instead of overload assignment operator
+ !> (to avoid memory leak)
+ !
+ !> @param[in] td_var array of variable structure
+ !> @return copy of input array of variable structure
+ !-------------------------------------------------------------------
+ FUNCTION var__copy_arr( td_var )
IMPLICIT NONE
! Argument
- TYPE(TVAR), DIMENSION(:), INTENT(IN ) :: td_var2
- TYPE(TVAR), DIMENSION(:), INTENT( OUT) :: td_var1
+ TYPE(TVAR), DIMENSION(:), INTENT(IN ) :: td_var
+ ! function
+ TYPE(TVAR), DIMENSION(SIZE(td_var(:))) :: var__copy_arr
! local variable
@@ -452,24 +647,18 @@
!----------------------------------------------------------------
- IF( SIZE(td_var2(:))/=SIZE(td_var1(:)) )THEN
- CALL logger_error("VAR COPY: variable structure dimension differ")
- ELSE
- DO ji=1,SIZE(td_var2(:))
- td_var1(ji)=td_var2(ji)
- ENDDO
- ENDIF
-
- END SUBROUTINE var__copy_tab
- !> @endcode
+ DO ji=1,SIZE(td_var(:))
+ var__copy_arr(ji)=var_copy(td_var(ji))
+ ENDDO
+
+ END FUNCTION var__copy_arr
!-------------------------------------------------------------------
!> @brief This subroutine clean variable structure
- !
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : variable strucutre
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var_clean( td_var )
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_var variable strucutre
+ !-------------------------------------------------------------------
+ SUBROUTINE var__clean_unit( td_var )
IMPLICIT NONE
! Argument
@@ -480,25 +669,15 @@
! loop indices
- INTEGER(i4) :: ji
!----------------------------------------------------------------
-
- CALL logger_info( &
- & " CLEAN: reset variable "//TRIM(td_var%c_name) )
! del attribute
IF( ASSOCIATED(td_var%t_att) )THEN
- ! clean each attribute
- DO ji=td_var%i_natt,1,-1
- CALL att_clean(td_var%t_att(ji) )
- ENDDO
- DEALLOCATE( td_var%t_att )
+ CALL att_clean( td_var%t_att(:) )
+ DEALLOCATE(td_var%t_att)
ENDIF
! del dimension
IF( td_var%i_ndim /= 0 )THEN
- ! clean each dimension
- DO ji=td_var%i_ndim,1,-1
- CALL dim_clean(td_var%t_dim(ji))
- ENDDO
+ CALL dim_clean(td_var%t_dim(:))
ENDIF
@@ -509,42 +688,151 @@
! replace by empty structure
- td_var=tl_var
-
- END SUBROUTINE var_clean
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !
- !> @details
+ td_var=var_copy(tl_var)
+
+ END SUBROUTINE var__clean_unit
+ !-------------------------------------------------------------------
+ !> @brief This subroutine clean 1D array of variable structure
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] dd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !> @param[in] cd_interp : interpolation method
- !> @param[in] cd_extrap : extrapolation method
- !> @param[in] cd_filter : filter method
- !-------------------------------------------------------------------
- !> @code
+ !> - September, 2014- Initial Version
+ !
+ !> @param[inout] td_var array of variable strucutre
+ !-------------------------------------------------------------------
+ SUBROUTINE var__clean_arr_1D( td_var )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR), DIMENSION(:), INTENT(INOUT) :: td_var
+
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+
+ DO ji=SIZE(td_var(:)),1,-1
+ CALL var_clean(td_var(ji))
+ ENDDO
+
+ END SUBROUTINE var__clean_arr_1D
+ !-------------------------------------------------------------------
+ !> @brief This subroutine clean 2D array of variable structure
+ !
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !
+ !> @param[inout] td_var array of variable strucutre
+ !-------------------------------------------------------------------
+ SUBROUTINE var__clean_arr_2D( td_var )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR), DIMENSION(:,:), INTENT(INOUT) :: td_var
+
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ !----------------------------------------------------------------
+
+ DO jj=SIZE(td_var(:,:),DIM=2),1,-1
+ DO ji=SIZE(td_var(:,:),DIM=1),1,-1
+ CALL var_clean(td_var(ji,jj))
+ ENDDO
+ ENDDO
+
+ END SUBROUTINE var__clean_arr_2D
+ !-------------------------------------------------------------------
+ !> @brief This subroutine clean 3D array of variable structure
+ !
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !
+ !> @param[inout] td_var array of variable strucutre
+ !-------------------------------------------------------------------
+ SUBROUTINE var__clean_arr_3D( td_var )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR), DIMENSION(:,:,:), INTENT(INOUT) :: td_var
+
+ ! local variable
+ ! loop indices
+ INTEGER(i4) :: ji
+ INTEGER(i4) :: jj
+ INTEGER(i4) :: jk
+ !----------------------------------------------------------------
+
+ DO jk=SIZE(td_var(:,:,:),DIM=3),1,-1
+ DO jj=SIZE(td_var(:,:,:),DIM=2),1,-1
+ DO ji=SIZE(td_var(:,:,:),DIM=1),1,-1
+ CALL var_clean(td_var(ji,jj,jk))
+ ENDDO
+ ENDDO
+ ENDDO
+
+ END SUBROUTINE var__clean_arr_3D
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure, given variable name.
+ !
+ !> @details
+ !> Optionally you could add 1D,2D,3D or 4D array of value,
+ !> see var__init_1D_dp, var__init_2D_dp... for more information.
+ !>
+ !> you could also add more information with the following optional arguments:
+ !> - id_type : integer(4) variable type, (as defined by NETCDF type constants).
+ !> - td_dim : array of dimension structure.
+ !> - td_att : array of attribute structure.
+ !> - dd_fill : real(8) variable FillValue. if none NETCDF FillValue will be used.
+ !> - cd_units : string character of units.
+ !> - cd_axis : string character of axis expected to be used
+ !> - cd_stdname : string character of variable standard name.
+ !> - cd_longname : string character of variable long name.
+ !> - cd_point : one character for ARAKAWA C-grid point name (T,U,V,F).
+ !> - id_id : variable id (read from a file).
+ !> - id_ew : number of point composing east west wrap band.
+ !> - dd_scf : real(8) value for scale factor attribute.
+ !> - dd_ofs : real(8) value for add offset attribute.
+ !> - id_rec : record id (for rstdimg file).
+ !> - dd_min : real(8) value for minimum value.
+ !> - dd_max : real(8) value for maximum value.
+ !> - ld_contiguous : use contiguous storage or not (for netcdf4).
+ !> - ld_shuffle : shuffle filter is turned on or not (for netcdf4).
+ !> - ld_fletcher32 : fletcher32 filter is turned on or not (for netcdf4).
+ !> - id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use (for netcdf4).
+ !> - id_chunksz : chunk size (for netcdf4).
+ !> - cd_interp : a array of character defining interpolation method.
+ !> - cd_extrap : a array of character defining extrapolation method.
+ !> - cd_filter : a array of character defining filtering method.
+ !>
+ !> @note most of these optionals arguments will be inform automatically,
+ !> when reading variable from a file, or using confiuguration file variable.cfg.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[in] cd_name variable name
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] dd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @param[in] cd_interp interpolation method
+ !> @param[in] cd_extrap extrapolation method
+ !> @param[in] cd_filter filter method
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init( cd_name, id_type, td_dim, &
& td_att, dd_fill, cd_units, cd_axis, &
@@ -586,5 +874,5 @@
! local variable
- INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_ind
TYPE(TATT) :: tl_att
@@ -637,14 +925,24 @@
! add _FillValue
IF( PRESENT(dd_fill) )THEN
- tl_att=att_init('_FillValue',dd_fill)
+ SELECT CASE( var__init%i_type )
+ CASE(NF90_BYTE)
+ tl_att=att_init('_FillValue', INT(dd_fill,i1) )
+ CASE(NF90_SHORT)
+ tl_att=att_init('_FillValue', INT(dd_fill,i2) )
+ CASE(NF90_INT)
+ tl_att=att_init('_FillValue', INT(dd_fill,i4) )
+ CASE(NF90_FLOAT)
+ tl_att=att_init('_FillValue', INT(dd_fill,sp) )
+ CASE DEFAULT ! NF90_DOUBLE
+ tl_att=att_init('_FillValue', dd_fill )
+ END SELECT
CALL var_move_att(var__init, tl_att)
ELSE
- il_attid=0
+ il_ind=0
IF( ASSOCIATED(var__init%t_att) )THEN
- il_attid=att_get_id(var__init%t_att(:),'_FillValue')
+ il_ind=att_get_index(var__init%t_att(:),'_FillValue')
ENDIF
- IF( il_attid == 0 )THEN
+ IF( il_ind == 0 )THEN
SELECT CASE( var__init%i_type )
-
CASE(NF90_BYTE)
tl_att=att_init('_FillValue',NF90_FILL_BYTE)
@@ -657,5 +955,4 @@
CASE DEFAULT ! NF90_DOUBLE
tl_att=att_init('_FillValue',NF90_FILL_DOUBLE)
-
END SELECT
CALL var_add_att(var__init, tl_att)
@@ -687,4 +984,6 @@
IF( PRESENT(td_dim) )THEN
CALL var_add_dim(var__init, td_dim(:))
+ ELSE
+ CALL var_add_dim(var__init, dim_fill_unused())
ENDIF
@@ -703,4 +1002,5 @@
ENDIF
+ ! netcdf4
IF( PRESENT(ld_contiguous) )THEN
var__init%l_contiguous=ld_contiguous
@@ -723,12 +1023,15 @@
ENDIF
+ ! interp
IF( PRESENT(cd_interp) )THEN
var__init%c_interp(:)=cd_interp(:)
ENDIF
+ !extrap
IF( PRESENT(cd_extrap) )THEN
var__init%c_extrap(:)=cd_extrap(:)
ENDIF
+ !filter
IF( PRESENT(cd_filter) )THEN
var__init%c_filter(:)=cd_filter(:)
@@ -738,92 +1041,68 @@
CALL var__get_extra(var__init)
- ! delete some attribute
- il_attid=att_get_id(var__init%t_att(:),'interpolation')
- IF( il_attid /= 0 )THEN
- tl_att=var__init%t_att(il_attid)
- CALL var_del_att(var__init, tl_att)
- ENDIF
- il_attid=att_get_id(var__init%t_att(:),'extrapolation')
- IF( il_attid /= 0 )THEN
- tl_att=var__init%t_att(il_attid)
- CALL var_del_att(var__init, tl_att)
- ENDIF
- il_attid=att_get_id(var__init%t_att(:),'filter')
- IF( il_attid /= 0 )THEN
- tl_att=var__init%t_att(il_attid)
- CALL var_del_att(var__init, tl_att)
- ENDIF
- il_attid=att_get_id(var__init%t_att(:),'src_file')
- IF( il_attid /= 0 )THEN
- tl_att=var__init%t_att(il_attid)
- CALL var_del_att(var__init, tl_att)
- ENDIF
- ! those attribute are deleted cause seems not to be informed correctly
- il_attid=att_get_id(var__init%t_att(:),'valid_min')
- IF( il_attid /= 0 )THEN
- tl_att=var__init%t_att(il_attid)
- CALL var_del_att(var__init, tl_att)
- ENDIF
- il_attid=att_get_id(var__init%t_att(:),'valid_max')
- IF( il_attid /= 0 )THEN
- tl_att=var__init%t_att(il_attid)
- CALL var_del_att(var__init, tl_att)
- ENDIF
- il_attid=att_get_id(var__init%t_att(:),'missing_value')
- IF( il_attid /= 0 )THEN
- tl_att=var__init%t_att(il_attid)
- CALL var_del_att(var__init, tl_att)
- ENDIF
+ ! delete some attribute cause linked to file where variable come from
+ CALL var_del_att(var__init, 'refinment_factor')
+ CALL var_del_att(var__init, 'interpolation')
+ CALL var_del_att(var__init, 'extrapolation')
+ CALL var_del_att(var__init, 'filter')
+ CALL var_del_att(var__init, 'src_file')
+ CALL var_del_att(var__init, 'valid_min')
+ CALL var_del_att(var__init, 'valid_max')
+ CALL var_del_att(var__init, 'missing_value')
+
+ ! clean
+ CALL att_clean(tl_att)
END FUNCTION var__init
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - real(8) 1D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a real(8) 1D array of value.
!> @details
+ !> Optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !
!> Dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('z') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] dd_value : 1D table of real(8) value
- !> @param[in] id_start : index in the variable from which the data values
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] dd_value 1D array of real(8) value
+ !> @param[in] id_start index in the variable from which the data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] dd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] id_count number of indices selected along each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] dd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_1D_dp( cd_name, dd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, dd_fill, cd_units,&
+ & td_att, dd_fill, cd_units, cd_axis, &
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -843,4 +1122,5 @@
REAL(dp) , INTENT(IN), OPTIONAL :: dd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -874,5 +1154,5 @@
CALL var_clean(var__init_1D_dp)
- ! ugly call to avoid warning
+ ! dummy call to avoid warning
il_type=NF90_DOUBLE
IF( PRESENT(id_type) ) il_type=id_type
@@ -880,5 +1160,5 @@
tl_dim(1)=dim_init( 'Z', id_len=SIZE(dd_value(:)) )
IF( PRESENT(td_dim) )THEN
- tl_dim(1)=td_dim
+ tl_dim(1)=dim_copy(td_dim)
ENDIF
@@ -895,5 +1175,5 @@
! reorder dimension
CALL dim_reorder(tl_dim(:))
- ! reorder table
+ ! reorder array
il_start(:)=dim_reorder_2xyzt(tl_dim(:),il_start(:))
il_count(:)=dim_reorder_2xyzt(tl_dim(:),il_count(:))
@@ -902,4 +1182,5 @@
& td_dim=tl_dim(:), td_att=td_att, &
& dd_fill=dd_fill, cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -934,58 +1215,63 @@
CALL var_add_value( var__init_1D_dp, dl_value(:,:,:,:), &
- & il_start(:), il_count(:) )
-
+ & il_type, il_start(:), il_count(:) )
+
+ ! clean
DEALLOCATE( dl_value )
+ CALL dim_clean(tl_dim)
END FUNCTION var__init_1D_dp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - real(8) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a real(8) 2D array of value.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
!
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> array of 2 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] dd_value : 1D table of real(8) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] dd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] dd_value 1D array of real(8) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] dd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates
+ !> no deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_2D_dp( cd_name, dd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, dd_fill, cd_units,&
+ & td_att, dd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -1005,4 +1291,5 @@
REAL(dp) , INTENT(IN), OPTIONAL :: dd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -1036,5 +1323,5 @@
CALL var_clean(var__init_2D_dp)
- ! ugly call to avoid warning
+ ! dummy call to avoid warning
il_type=NF90_DOUBLE
IF( PRESENT(id_type) ) il_type=id_type
@@ -1047,6 +1334,6 @@
& " not conform")
ELSE
- tl_dim(1)=td_dim(1)
- tl_dim(2)=td_dim(2)
+ tl_dim(1)=dim_copy(td_dim(1))
+ tl_dim(2)=dim_copy(td_dim(2))
ENDIF
ENDIF
@@ -1055,5 +1342,5 @@
IF( PRESENT(id_start) )THEN
IF( SIZE(id_start(:)) /= 2 )THEN
- CALL logger_error("VAR INIT: dimension of start table "//&
+ CALL logger_error("VAR INIT: dimension of start array "//&
& " not conform")
ELSE
@@ -1066,5 +1353,5 @@
IF( PRESENT(id_count) )THEN
IF( SIZE(id_count(:)) /= 2 )THEN
- CALL logger_error("VAR INIT: dimension of count table "//&
+ CALL logger_error("VAR INIT: dimension of count array "//&
& " not conform")
ELSE
@@ -1076,5 +1363,5 @@
! reorder dimension
CALL dim_reorder(tl_dim(:))
- ! reorder table
+ ! reorder array
il_start(:)=dim_reorder_2xyzt(tl_dim(:),il_start(:))
il_count(:)=dim_reorder_2xyzt(tl_dim(:),il_count(:))
@@ -1083,4 +1370,5 @@
& td_dim=tl_dim(:), td_att=td_att, &
& dd_fill=dd_fill, cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -1119,58 +1407,63 @@
CALL var_add_value( var__init_2D_dp, dl_value(:,:,:,:), &
- & il_start(:), il_count(:) )
-
+ & il_type, il_start(:), il_count(:) )
+
+ ! clean
DEALLOCATE( dl_value )
+ CALL dim_clean(tl_dim)
END FUNCTION var__init_2D_dp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - real(8) 3D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a real(8) 3D array of value.
!> @details
- !> table of 3 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y','z') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 3 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y','z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] dd_value : 1D table of real(8) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] dd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] dd_value 1D array of real(8) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] dd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_3D_dp( cd_name, dd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, dd_fill, cd_units,&
+ & td_att, dd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -1190,4 +1483,5 @@
REAL(dp) , INTENT(IN), OPTIONAL :: dd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -1221,5 +1515,5 @@
CALL var_clean(var__init_3D_dp)
- ! ugly call to avoid warning
+ ! dummy call to avoid warning
il_type=NF90_DOUBLE
IF( PRESENT(id_type) ) il_type=id_type
@@ -1233,7 +1527,7 @@
& " not conform")
ELSE
- tl_dim(1)=td_dim(1)
- tl_dim(2)=td_dim(2)
- tl_dim(3)=td_dim(3)
+ tl_dim(1)=dim_copy(td_dim(1))
+ tl_dim(2)=dim_copy(td_dim(2))
+ tl_dim(3)=dim_copy(td_dim(3))
ENDIF
ENDIF
@@ -1242,5 +1536,5 @@
IF( PRESENT(id_start) )THEN
IF( SIZE(id_start(:)) /= 3 )THEN
- CALL logger_error("VAR INIT: dimension of start table "//&
+ CALL logger_error("VAR INIT: dimension of start array "//&
& " not conform")
ELSE
@@ -1254,5 +1548,5 @@
IF( PRESENT(id_count) )THEN
IF( SIZE(id_count(:)) /= 3 )THEN
- CALL logger_error("VAR INIT: dimension of count table "//&
+ CALL logger_error("VAR INIT: dimension of count array "//&
& " not conform")
ELSE
@@ -1265,5 +1559,5 @@
! reorder dimension
CALL dim_reorder(tl_dim(:))
- ! reorder table
+ ! reorder array
il_start(:)=dim_reorder_2xyzt(tl_dim(:),il_start(:))
il_count(:)=dim_reorder_2xyzt(tl_dim(:),il_count(:))
@@ -1272,4 +1566,5 @@
& td_dim=tl_dim(:), td_att=td_att, &
& dd_fill=dd_fill, cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -1304,58 +1599,63 @@
CALL var_add_value( var__init_3D_dp, dl_value(:,:,:,:), &
- & il_start(:), il_count(:) )
-
+ & il_type, il_start(:), il_count(:) )
+
+ ! clean
DEALLOCATE( dl_value )
+ CALL dim_clean(tl_dim)
END FUNCTION var__init_3D_dp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - real(8) 4D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a real(8) 4D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> Dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y','z','t') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('x','y','z','t') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] dd_value : 4D table of real(8) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] dd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] dd_value 4D array of real(8) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] dd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_dp( cd_name, dd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, dd_fill, cd_units,&
+ & td_att, dd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -1375,4 +1675,5 @@
REAL(dp) , INTENT(IN), OPTIONAL :: dd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -1404,5 +1705,5 @@
CALL var_clean(var__init_dp)
- ! ugly call to avoid warning
+ ! dummy call to avoid warning
il_type=NF90_DOUBLE
IF( PRESENT(id_type) ) il_type=id_type
@@ -1411,4 +1712,5 @@
& td_dim=td_dim, td_att=td_att, &
& dd_fill=dd_fill, cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -1422,5 +1724,5 @@
& id_deflvl=id_deflvl, &
& id_chunksz=id_chunksz(:))
-
+
! add value
IF( .NOT. PRESENT(td_dim) )THEN
@@ -1433,56 +1735,62 @@
CALL var_add_value( var__init_dp, dd_value(:,:,:,:), &
- & id_start(:), id_count(:) )
+ & il_type, id_start(:), id_count(:) )
+
+ ! clean
+ CALL dim_clean(tl_dim)
END FUNCTION var__init_dp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - real(4) 1D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a real(4) 1D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('z') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] rd_value : 1D table of real(4) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] rd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] rd_value 1D array of real(4) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] rd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_1D_sp( cd_name, rd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, rd_fill, cd_units,&
+ & td_att, rd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -1503,4 +1811,5 @@
REAL(sp) , INTENT(IN), OPTIONAL :: rd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -1550,4 +1859,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -1565,53 +1875,56 @@
END FUNCTION var__init_1D_sp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - real(4) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a real(4) 2D array of value.
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 2 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] rd_value : 2D table of real(4) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] rd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name : variable name
+ !> @param[in] rd_value : 2D array of real(4) value
+ !> @param[in] id_start : index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count : number of indices selected along
+ !> each dimension
+ !> @param[in] id_type : variable type
+ !> @param[in] td_dim : array of dimension structure
+ !> @param[in] td_att : array of attribute structure
+ !> @param[in] rd_fill : fill value
+ !> @param[in] cd_units : units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname : variable standard name
+ !> @param[in] cd_longname : variable long name
+ !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id : variable id
+ !> @param[in] id_ew : east west wrap
+ !> @param[in] dd_scf : scale factor
+ !> @param[in] dd_ofs : add offset
+ !> @param[in] id_rec : record id (for rstdimg file)
+ !> @param[in] dd_min : minimum value
+ !> @param[in] dd_max : maximum value
+ !> @param[in] ld_contiguous : use contiguous storage or not
+ !> @param[in] ld_shuffle : shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz : chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_2D_sp( cd_name, rd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, rd_fill, cd_units,&
+ & td_att, rd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -1625,6 +1938,6 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
REAL(sp) , DIMENSION(:,:) , INTENT(IN) :: rd_value
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim
@@ -1632,4 +1945,5 @@
REAL(sp) , INTENT(IN), OPTIONAL :: rd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -1681,4 +1995,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -1696,53 +2011,56 @@
END FUNCTION var__init_2D_sp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - real(4) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a real(4) 3D array of value.
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 3 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y','z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] rd_value : 2D table of real(4) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] rd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name : variable name
+ !> @param[in] rd_value : 2D array of real(4) value
+ !> @param[in] id_start : index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count : number of indices selected along
+ !> each dimension
+ !> @param[in] id_type : variable type
+ !> @param[in] td_dim : array of dimension structure
+ !> @param[in] td_att : array of attribute structure
+ !> @param[in] rd_fill : fill value
+ !> @param[in] cd_units : units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname : variable standard name
+ !> @param[in] cd_longname : variable long name
+ !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id : variable id
+ !> @param[in] id_ew : east west wrap
+ !> @param[in] dd_scf : scale factor
+ !> @param[in] dd_ofs : add offset
+ !> @param[in] id_rec : record id (for rstdimg file)
+ !> @param[in] dd_min : minimum value
+ !> @param[in] dd_max : maximum value
+ !> @param[in] ld_contiguous : use contiguous storage or not
+ !> @param[in] ld_shuffle : shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz : chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_3D_sp( cd_name, rd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, rd_fill, cd_units,&
+ & td_att, rd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -1756,6 +2074,6 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
REAL(sp) , DIMENSION(:,:,:) , INTENT(IN) :: rd_value
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim
@@ -1763,4 +2081,5 @@
REAL(sp) , INTENT(IN), OPTIONAL :: rd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -1813,4 +2132,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -1828,53 +2148,56 @@
END FUNCTION var__init_3D_sp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - real(4) 4D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a real(4) 4D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> Dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y','z','t') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('x','y','z','t') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] rd_value : 4D table of real(4) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] rd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] rd_value 4D array of real(4) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] rd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_sp( cd_name, rd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, rd_fill, cd_units,&
+ & td_att, rd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -1895,4 +2218,5 @@
REAL(sp) , INTENT(IN), OPTIONAL :: rd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -1946,4 +2270,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -1961,53 +2286,56 @@
END FUNCTION var__init_sp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(8) 1D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(8) 1D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('z') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] kd_value : 1D table of integer(8) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] kd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name : variable name
+ !> @param[in] kd_value : 1D array of integer(8) value
+ !> @param[in] id_start : index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count : number of indices selected along
+ !> each dimension
+ !> @param[in] id_type : variable type
+ !> @param[in] td_dim : array of dimension structure
+ !> @param[in] td_att : array of attribute structure
+ !> @param[in] kd_fill : fill value
+ !> @param[in] cd_units : units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname : variable standard name
+ !> @param[in] cd_longname : variable long name
+ !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id : variable id
+ !> @param[in] id_ew : east west wrap
+ !> @param[in] dd_scf : scale factor
+ !> @param[in] dd_ofs : add offset
+ !> @param[in] id_rec : record id (for rstdimg file)
+ !> @param[in] dd_min : minimum value
+ !> @param[in] dd_max : maximum value
+ !> @param[in] ld_contiguous : use contiguous storage or not
+ !> @param[in] ld_shuffle : shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz : chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_1D_i8( cd_name, kd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, kd_fill, cd_units,&
+ & td_att, kd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -2028,4 +2356,5 @@
INTEGER(i8) , INTENT(IN), OPTIONAL :: kd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -2075,4 +2404,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -2090,53 +2420,54 @@
END FUNCTION var__init_1D_i8
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(8) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(8) 2D array of value.
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 2 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] kd_value : 2D table of integer(8) value
- !> @param[in] id_start : index in the variable from which the data values
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] kd_value 2D array of integer(8) value
+ !> @param[in] id_start index in the variable from which the data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] kd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] id_count number of indices selected along each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] kd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_2D_i8( cd_name, kd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, kd_fill, cd_units,&
+ & td_att, kd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -2150,6 +2481,6 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i8) , DIMENSION(:,:) , INTENT(IN) :: kd_value
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim
@@ -2157,4 +2488,5 @@
INTEGER(i8) , INTENT(IN), OPTIONAL :: kd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -2206,4 +2538,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -2221,53 +2554,56 @@
END FUNCTION var__init_2D_i8
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(8) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(8) 3D array of value.
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 3 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y','z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] kd_value : 2D table of integer(8) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] kd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] kd_value 2D array of integer(8) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] kd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_3D_i8( cd_name, kd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, kd_fill, cd_units,&
+ & td_att, kd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -2281,6 +2617,6 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i8) , DIMENSION(:,:,:) , INTENT(IN) :: kd_value
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim
@@ -2288,4 +2624,5 @@
INTEGER(i8) , INTENT(IN), OPTIONAL :: kd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -2338,4 +2675,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -2353,53 +2691,56 @@
END FUNCTION var__init_3D_i8
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(8) 4D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(8) 4D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> Dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y','z','t') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('x','y','z','t') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] kd_value : 4D table of integer(8) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] kd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] kd_value 4D array of integer(8) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] kd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_i8( cd_name, kd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, kd_fill, cd_units,&
+ & td_att, kd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -2420,4 +2761,5 @@
INTEGER(i8) , INTENT(IN), OPTIONAL :: kd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -2471,4 +2813,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -2486,53 +2829,56 @@
END FUNCTION var__init_i8
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(4) 1D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(4) 1D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('z') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] id_value : 1D table of integer(4) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] id_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] id_value 1D array of integer(4) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] id_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_1D_i4( cd_name, id_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, id_fill, cd_units,&
+ & td_att, id_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -2553,4 +2899,5 @@
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -2600,4 +2947,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -2615,53 +2963,56 @@
END FUNCTION var__init_1D_i4
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(4) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(4) 2D array of value.
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 2 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] id_value : 2D table of integer(4) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] id_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] id_value 2D array of integer(4) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] id_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_2D_i4( cd_name, id_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, id_fill, cd_units,&
+ & td_att, id_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -2675,6 +3026,6 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i4) , DIMENSION(:,:) , INTENT(IN) :: id_value
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim
@@ -2682,4 +3033,5 @@
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -2731,4 +3083,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -2746,53 +3099,56 @@
END FUNCTION var__init_2D_i4
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(4) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(4) 3D array of value.
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 3 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y','z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] id_value : 2D table of integer(4) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] id_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] id_value 3D array of integer(4) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] id_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_3D_i4( cd_name, id_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, id_fill, cd_units,&
+ & td_att, id_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -2806,6 +3162,6 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i4) , DIMENSION(:,:,:) , INTENT(IN) :: id_value
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim
@@ -2813,4 +3169,5 @@
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -2863,4 +3220,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -2878,53 +3236,56 @@
END FUNCTION var__init_3D_i4
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(4) 4D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(4) 4D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> Dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y','z','t') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('x','y','z','t') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] id_value : 4D table of integer(4) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] id_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] id_value 4D array of integer(4) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] id_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_i4( cd_name, id_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, id_fill, cd_units,&
+ & td_att, id_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -2945,4 +3306,5 @@
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -2996,4 +3358,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -3010,65 +3373,57 @@
DEALLOCATE( dl_value )
-! ! add value
-! IF( .NOT. PRESENT(td_dim) )THEN
-! il_shape(:)=SHAPE(id_value(:,:,:,:))
-! DO ji=1,ip_maxdim
-! tl_dim=dim_init( cp_dimorder(ji:ji), id_len=il_shape(ji))
-! CALL var_add_dim(var__init_i4, tl_dim)
-! ENDDO
-! ENDIF
-! CALL var_add_value(var__init_i4, id_value(:,:,:,:), &
-! & id_start(:), id_count(:))
-
END FUNCTION var__init_i4
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(2) 1D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(2) 1D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('z') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] sd_value : 1D table of integer(2) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] sd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] sd_value 1D array of integer(2) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] sd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_1D_i2( cd_name, sd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, sd_fill, cd_units,&
+ & td_att, sd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -3089,4 +3444,5 @@
INTEGER(i2) , INTENT(IN), OPTIONAL :: sd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -3136,4 +3492,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -3151,53 +3508,56 @@
END FUNCTION var__init_1D_i2
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(2) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(2) 2D array of value.
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 2 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] sd_value : 2D table of integer(2) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] sd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] sd_value 2D array of integer(2) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] sd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_2D_i2( cd_name, sd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, sd_fill, cd_units,&
+ & td_att, sd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -3211,6 +3571,6 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i2) , DIMENSION(:,:) , INTENT(IN) :: sd_value
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim
@@ -3218,4 +3578,5 @@
INTEGER(i2) , INTENT(IN), OPTIONAL :: sd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -3267,4 +3628,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -3282,53 +3644,56 @@
END FUNCTION var__init_2D_i2
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(2) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(2) 3D array of value.
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 3 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y','z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] sd_value : 2D table of integer(2) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] sd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] sd_value 3D array of integer(2) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] sd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_3D_i2( cd_name, sd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, sd_fill, cd_units,&
+ & td_att, sd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -3342,6 +3707,6 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i2) , DIMENSION(:,:,:) , INTENT(IN) :: sd_value
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim
@@ -3349,4 +3714,5 @@
INTEGER(i2) , INTENT(IN), OPTIONAL :: sd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -3399,4 +3765,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -3414,53 +3781,56 @@
END FUNCTION var__init_3D_i2
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(2) 4D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(2) 4D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> Dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y','z','t') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('x','y','z','t') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] sd_value : 4D table of integer(2) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] sd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] sd_value 4D array of integer(2) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] sd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_i2( cd_name, sd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, sd_fill, cd_units,&
+ & td_att, sd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -3481,4 +3851,5 @@
INTEGER(i2) , INTENT(IN), OPTIONAL :: sd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -3532,4 +3903,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -3546,65 +3918,57 @@
DEALLOCATE( dl_value )
-! ! add value
-! IF( .NOT. PRESENT(td_dim) )THEN
-! il_shape(:)=SHAPE(sd_value(:,:,:,:))
-! DO ji=1,ip_maxdim
-! tl_dim=dim_init( cp_dimorder(ji:ji), id_len=il_shape(ji))
-! CALL var_add_dim(var__init_i2, tl_dim)
-! ENDDO
-! ENDIF
-! CALL var_add_value(var__init_i2, sd_value(:,:,:,:), &
-! & id_start(:), id_count(:))
-
END FUNCTION var__init_i2
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(1) 1D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(1) 1D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('z') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] bd_value : 1D table of integer(1) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] bd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] bd_value 1D array of integer(1) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] bd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_1D_i1( cd_name, bd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, bd_fill, cd_units,&
+ & td_att, bd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -3625,4 +3989,5 @@
INTEGER(i1) , INTENT(IN), OPTIONAL :: bd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -3672,4 +4037,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -3687,53 +4053,56 @@
END FUNCTION var__init_1D_i1
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(1) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(1) 2D array of value.
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 2 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] bd_value : 2D table of integer(1) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] bd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] bd_value 2D array of integer(1) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] bd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_2D_i1( cd_name, bd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, bd_fill, cd_units,&
+ & td_att, bd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -3747,6 +4116,6 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i1) , DIMENSION(:,:) , INTENT(IN) :: bd_value
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim
@@ -3754,4 +4123,5 @@
INTEGER(i1) , INTENT(IN), OPTIONAL :: bd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -3803,4 +4173,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -3818,53 +4189,56 @@
END FUNCTION var__init_2D_i1
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(1) 2D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(1) 3D array of value.
!> @details
- !> table of 2 dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y') and we
- !> use table size as lentgh dimension.
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
+ !> array of 3 dimension structure is needed to put value in variable structure.
+ !> If none is given, we assume array is ordered as ('x','y','z') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
+ !> start and count array are given. Dimension structure is needed in that
!> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] bd_value : 2D table of integer(1) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] bd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] bd_value 3D array of integer(1) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] bd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_3D_i1( cd_name, bd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, bd_fill, cd_units,&
+ & td_att, bd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -3878,6 +4252,6 @@
CHARACTER(LEN=*), INTENT(IN) :: cd_name
INTEGER(i1) , DIMENSION(:,:,:) , INTENT(IN) :: bd_value
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
- INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_start
+ INTEGER(i4) , DIMENSION(:) , INTENT(IN), OPTIONAL :: id_count
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_type
TYPE(TDIM) , DIMENSION(:) , INTENT(IN), OPTIONAL :: td_dim
@@ -3885,4 +4259,5 @@
INTEGER(i1) , INTENT(IN), OPTIONAL :: bd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -3935,4 +4310,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -3950,53 +4326,56 @@
END FUNCTION var__init_3D_i1
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function initalise a variable structure.
- !> - integer(1) 4D table of value could be added.
- !> - dimension structure could be added.
- !> - attribute structure could be added
- !
+ !-------------------------------------------------------------------
+ !> @brief This function initialize a variable structure,
+ !> with a integer(1) 4D array of value.
!> @details
+ !> optionally could be added:
+ !> - dimension structure.
+ !> - attribute structure.
+ !>
!> Dimension structure is needed to put value in variable structure.
- !> If none is given, we assume table is ordered as ('x','y','z','t') and we
- !> use table size as lentgh dimension.
+ !> If none is given, we assume array is ordered as ('x','y','z','t') and we
+ !> use array size as lentgh dimension.
!>
!> indices in the variable where value will be written could be specify if
- !> start and count table are given. Dimension structure is needed in that
- !> case.
+ !> start and count array are given. Dimension structure is needed in that
+ !> case.
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_name : variable name
- !> @param[in] bd_value : 4D table of integer(1) value
- !> @param[in] id_start : index in the variable from which the data values
- !> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !> @param[in] id_type : variable type
- !> @param[in] td_dim : table of dimension structure
- !> @param[in] td_att : table of attribute structure
- !> @param[in] bd_fill : fill value
- !> @param[in] cd_units : units
- !> @param[in] cd_stdname : variable standard name
- !> @param[in] cd_longname : variable long name
- !> @param[in] cd_point : point on Arakawa-C grid (T,U,V,F)
- !> @param[in] id_id : variable id
- !> @param[in] id_ew : east west wrap
- !> @param[in] dd_scf : scale factor
- !> @param[in] dd_ofs : add offset
- !> @param[in] id_rec : record id (for rstdimg file)
- !> @param[in] dd_min : minimum value
- !> @param[in] dd_max : maximum value
- !> @param[in] ld_contiguous : use contiguous storage or not
- !> @param[in] ld_shuffle : shuffle filter is turned on or not
- !> @param[in] ld_fletcher32 : fletcher32 filter is turned on or not
- !> @param[in] id_deflvl : deflate level from 0 to 9, 0 indicates no deflation is in use
- !> @param[in] id_chunksz : chunk size
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] bd_value 4D array of integer(1) value
+ !> @param[in] id_start index in the variable from which the
+ !> data values will be read
+ !> @param[in] id_count number of indices selected along
+ !> each dimension
+ !> @param[in] id_type variable type
+ !> @param[in] td_dim array of dimension structure
+ !> @param[in] td_att array of attribute structure
+ !> @param[in] bd_fill fill value
+ !> @param[in] cd_units units
+ !> @param[in] cd_axis axis expected to be used
+ !> @param[in] cd_stdname variable standard name
+ !> @param[in] cd_longname variable long name
+ !> @param[in] cd_point point on Arakawa-C grid (T,U,V,F)
+ !> @param[in] id_id variable id
+ !> @param[in] id_ew east west wrap
+ !> @param[in] dd_scf scale factor
+ !> @param[in] dd_ofs add offset
+ !> @param[in] id_rec record id (for rstdimg file)
+ !> @param[in] dd_min minimum value
+ !> @param[in] dd_max maximum value
+ !> @param[in] ld_contiguous use contiguous storage or not
+ !> @param[in] ld_shuffle shuffle filter is turned on or not
+ !> @param[in] ld_fletcher32 fletcher32 filter is turned on or not
+ !> @param[in] id_deflvl deflate level from 0 to 9, 0 indicates no
+ !> deflation is in use
+ !> @param[in] id_chunksz chunk size
+ !> @return variable structure
+ !-------------------------------------------------------------------
TYPE(TVAR) FUNCTION var__init_i1( cd_name, bd_value, &
& id_start, id_count, id_type, td_dim, &
- & td_att, bd_fill, cd_units,&
+ & td_att, bd_fill, cd_units, cd_axis,&
& cd_stdname, cd_longname, &
& cd_point, id_id, id_ew, &
@@ -4017,4 +4396,5 @@
INTEGER(i1) , INTENT(IN), OPTIONAL :: bd_fill
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_units
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_axis
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_longname
@@ -4068,4 +4448,5 @@
& dd_fill=dl_fill, &
& cd_units=cd_units, &
+ & cd_axis=cd_axis, &
& cd_stdname=cd_stdname, &
& cd_longname=cd_longname, &
@@ -4082,17 +4463,5 @@
DEALLOCATE( dl_value )
-! ! add value
-! IF( .NOT. PRESENT(td_dim) )THEN
-! il_shape(:)=SHAPE(bd_value(:,:,:,:))
-! DO ji=1,ip_maxdim
-! tl_dim=dim_init( cp_dimorder(ji:ji), id_len=il_shape(ji))
-! CALL var_add_dim(var__init_i1, tl_dim)
-! ENDDO
-! ENDIF
-! CALL var_add_value(var__init_i1, bd_value(:,:,:,:), &
-! & id_start(:), id_count(:))
-
END FUNCTION var__init_i1
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function concatenate variable value following DIM direction.
@@ -4101,14 +4470,14 @@
!> By default variable are concatenate following time dimension. To
!> concatenate following another dimension, specify DIM=x where x is the
- !> dimension number (1,2,3,4)
+ !> dimension number (jp_I, jp_J,jp_K, jp_L).
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var1 : variable structure
- !> @param[in] td_var2 : variable structure
- !> @param[in] DIM : dimension following which concatenate
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_var1 variable structure
+ !> @param[in] td_var2 variable structure
+ !> @param[in] DIM dimension following which concatenate
+ !> @return variable structure
+ !-------------------------------------------------------------------
FUNCTION var_concat(td_var1, td_var2, DIM)
IMPLICIT NONE
@@ -4125,5 +4494,5 @@
!----------------------------------------------------------------
il_dim=4
- IF( PRESENT(DIM) )il_dim=DIM
+ IF( PRESENT(DIM) ) il_dim=DIM
IF( .NOT. ASSOCIATED(td_var1%d_value) )THEN
@@ -4138,28 +4507,26 @@
! check other dimension
SELECT CASE(il_dim)
- CASE(1)
+ CASE(jp_I)
var_concat=var__concat_i(td_var1, td_var2)
- CASE(2)
+ CASE(jp_J)
var_concat=var__concat_j(td_var1, td_var2)
- CASE(3)
+ CASE(jp_K)
var_concat=var__concat_k(td_var1, td_var2)
- CASE(4)
+ CASE(jp_L)
var_concat=var__concat_l(td_var1, td_var2)
END SELECT
-
ENDIF
END FUNCTION var_concat
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function concatenate variable value following i-direction.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var1 : variable structure
- !> @param[in] td_var2 : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_var1 variable structure
+ !> @param[in] td_var2 variable structure
+ !> @return variable structure
+ !-------------------------------------------------------------------
FUNCTION var__concat_i(td_var1, td_var2)
IMPLICIT NONE
@@ -4176,6 +4543,9 @@
!----------------------------------------------------------------
- IF( ANY(td_var1%t_dim(2:4)%i_len /= td_var2%t_dim(2:4)%i_len) )THEN
- CALL logger_error("VAR CONCAT: dimension not conform")
+ IF( .NOT. td_var1%t_dim(1)%l_use .OR. &
+ & .NOT. td_var1%t_dim(1)%l_use )THEN
+ CALL logger_error("VAR CONCAT: can not concatenate variable "//&
+ & TRIM(td_var1%c_name)//" on an unused dimension I")
+ ELSEIF( ANY(td_var1%t_dim(2:4)%i_len /= td_var2%t_dim(2:4)%i_len) )THEN
cl_tmp='('//":"//","//&
@@ -4191,6 +4561,8 @@
CALL logger_debug("VAR CONCAT: second variable dimensions "//&
& TRIM(cl_tmp) )
+
+ CALL logger_error("VAR CONCAT: dimension not conform")
ELSE
- tl_var=td_var1
+ tl_var=var_copy(td_var1)
DEALLOCATE(tl_var%d_value)
@@ -4212,21 +4584,21 @@
! save result
- var__concat_i=tl_var
-
+ var__concat_i=var_copy(tl_var)
+
+ ! clean
CALL var_clean(tl_var)
ENDIF
END FUNCTION var__concat_i
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function concatenate variable value following j-direction.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var1 : variable structure
- !> @param[in] td_var2 : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_var1 variable structure
+ !> @param[in] td_var2 variable structure
+ !> @return variable structure
+ !-------------------------------------------------------------------
FUNCTION var__concat_j(td_var1, td_var2)
IMPLICIT NONE
@@ -4243,7 +4615,10 @@
!----------------------------------------------------------------
- IF( td_var1%t_dim(1)%i_len /= td_var2%t_dim(1)%i_len .OR. &
+ IF( .NOT. td_var1%t_dim(2)%l_use .OR. &
+ & .NOT. td_var1%t_dim(2)%l_use )THEN
+ CALL logger_error("VAR CONCAT: can not concatenate variable "//&
+ & TRIM(td_var1%c_name)//" on an unused dimension J")
+ ELSEIF( td_var1%t_dim(1)%i_len /= td_var2%t_dim(1)%i_len .OR. &
& ANY(td_var1%t_dim(3:4)%i_len /= td_var2%t_dim(3:4)%i_len) )THEN
- CALL logger_error("VAR CONCAT: dimension not conform")
cl_tmp='('//&
@@ -4261,6 +4636,8 @@
CALL logger_debug("VAR CONCAT: second variable dimensions "//&
& TRIM(cl_tmp) )
+
+ CALL logger_error("VAR CONCAT: dimension not conform")
ELSE
- tl_var=td_var1
+ tl_var=var_copy(td_var1)
DEALLOCATE(tl_var%d_value)
@@ -4282,21 +4659,21 @@
! save result
- var__concat_j=tl_var
-
+ var__concat_j=var_copy(tl_var)
+
+ ! clean
CALL var_clean(tl_var)
ENDIF
END FUNCTION var__concat_j
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function concatenate variable value following k-direction.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var1 : variable structure
- !> @param[in] td_var2 : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_var1 variable structure
+ !> @param[in] td_var2 variable structure
+ !> @return variable structure
+ !-------------------------------------------------------------------
FUNCTION var__concat_k(td_var1, td_var2)
IMPLICIT NONE
@@ -4313,7 +4690,10 @@
!----------------------------------------------------------------
- IF( td_var1%t_dim(4)%i_len /= td_var2%t_dim(4)%i_len .OR. &
+ IF( .NOT. td_var1%t_dim(3)%l_use .OR. &
+ & .NOT. td_var1%t_dim(3)%l_use )THEN
+ CALL logger_error("VAR CONCAT: can not concatenate variable "//&
+ & TRIM(td_var1%c_name)//" on an unused dimension K")
+ ELSEIF( td_var1%t_dim(4)%i_len /= td_var2%t_dim(4)%i_len .OR. &
& ANY(td_var1%t_dim(1:2)%i_len /= td_var2%t_dim(1:2)%i_len) )THEN
- CALL logger_error("VAR CONCAT: dimension not conform")
cl_tmp='('//&
@@ -4331,6 +4711,8 @@
CALL logger_debug("VAR CONCAT: second variable dimensions "//&
& TRIM(cl_tmp) )
+
+ CALL logger_error("VAR CONCAT: dimension not conform")
ELSE
- tl_var=td_var1
+ tl_var=var_copy(td_var1)
DEALLOCATE(tl_var%d_value)
@@ -4352,21 +4734,21 @@
! save result
- var__concat_k=tl_var
-
+ var__concat_k=var_copy(tl_var)
+
+ ! clean
CALL var_clean(tl_var)
ENDIF
END FUNCTION var__concat_k
- !> @endcode
!-------------------------------------------------------------------
!> @brief This function concatenate variable value following l-direction.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var1 : variable structure
- !> @param[in] td_var2 : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_var1 variable structure
+ !> @param[in] td_var2 variable structure
+ !> @return variable structure
+ !-------------------------------------------------------------------
FUNCTION var__concat_l(td_var1, td_var2)
IMPLICIT NONE
@@ -4383,6 +4765,9 @@
!----------------------------------------------------------------
- IF( ANY(td_var1%t_dim(1:3)%i_len /= td_var2%t_dim(1:3)%i_len) )THEN
- CALL logger_error("VAR CONCAT: dimension not conform")
+ IF( .NOT. td_var1%t_dim(4)%l_use .OR. &
+ & .NOT. td_var1%t_dim(4)%l_use )THEN
+ CALL logger_error("VAR CONCAT: can not concatenate variable "//&
+ & TRIM(td_var1%c_name)//" on an unused dimension L")
+ ELSEIF( ANY(td_var1%t_dim(1:3)%i_len /= td_var2%t_dim(1:3)%i_len) )THEN
cl_tmp='('//&
@@ -4400,6 +4785,8 @@
CALL logger_debug("VAR CONCAT: second variable dimensions "//&
& TRIM(cl_tmp) )
+
+ CALL logger_error("VAR CONCAT: dimension not conform")
ELSE
- tl_var=td_var1
+ tl_var=var_copy(td_var1)
DEALLOCATE(tl_var%d_value)
@@ -4421,23 +4808,22 @@
! save result
- var__concat_l=tl_var
-
+ var__concat_l=var_copy(tl_var)
+
+ ! clean
CALL var_clean(tl_var)
ENDIF
END FUNCTION var__concat_l
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a table of attribute structure
+ !-------------------------------------------------------------------
+ !> @brief This subroutine add an array of attribute structure
!> in a variable structure.
- !
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] td_att : table of attribute structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__add_att_tab(td_var, td_att)
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_att array of attribute structure
+ !-------------------------------------------------------------------
+ SUBROUTINE var__add_att_arr(td_var, td_att)
IMPLICIT NONE
! Argument
@@ -4458,19 +4844,15 @@
ENDDO
- END SUBROUTINE var__add_att_tab
- !> @endcode
+ END SUBROUTINE var__add_att_arr
!-------------------------------------------------------------------
!> @brief This subroutine add an attribute structure
!> in a variable structure.
!
- !> @details
- !
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] td_att : attribute structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_att attribute structure
+ !-------------------------------------------------------------------
SUBROUTINE var__add_att_unit(td_var, td_att)
IMPLICIT NONE
@@ -4481,5 +4863,5 @@
! local variable
INTEGER(i4) :: il_status
- INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_ind
TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
@@ -4489,24 +4871,24 @@
! check if attribute already in variable structure
- il_attid=0
+ il_ind=0
IF( ASSOCIATED(td_var%t_att) )THEN
- il_attid=att_get_id( td_var%t_att(:), td_att%c_name )
- ENDIF
-
- IF( il_attid /= 0 )THEN
+ il_ind=att_get_index( td_var%t_att(:), td_att%c_name )
+ ENDIF
+
+ IF( il_ind /= 0 )THEN
CALL logger_error( &
- & " ADD ATT: attribute "//TRIM(td_att%c_name)//&
+ & " VAR ADD ATT: attribute "//TRIM(td_att%c_name)//&
& ", already in variable "//TRIM(td_var%c_name) )
DO ji=1,td_var%i_natt
CALL logger_debug( &
- & " ADD ATT: in variable "//TRIM(td_var%t_att(ji)%c_name) )
+ & " VAR ADD ATT: in variable "//TRIM(td_var%t_att(ji)%c_name) )
ENDDO
ELSE
- CALL logger_debug( &
- & " ADD ATT: add attribute "//TRIM(td_att%c_name)//&
+ CALL logger_trace( &
+ & " VAR ADD ATT: add attribute "//TRIM(td_att%c_name)//&
& ", in variable "//TRIM(td_var%c_name) )
@@ -4517,5 +4899,5 @@
CALL logger_error( &
- & " ADD ATT: not enough space to put attributes from "//&
+ & " VAR ADD ATT: not enough space to put attributes from "//&
& TRIM(td_var%c_name)//" in temporary attribute structure")
@@ -4523,6 +4905,7 @@
! save temporary global attribute's variable structure
- tl_att(:)=td_var%t_att(:)
-
+ tl_att(:)=att_copy(td_var%t_att(:))
+
+ CALL att_clean(td_var%t_att(:))
DEALLOCATE( td_var%t_att )
ALLOCATE( td_var%t_att(td_var%i_natt+1), stat=il_status )
@@ -4530,5 +4913,5 @@
CALL logger_error( &
- & " ADD ATT: not enough space to put attributes "//&
+ & " VAR ADD ATT: not enough space to put attributes "//&
& "in variable structure "//TRIM(td_var%c_name) )
@@ -4536,6 +4919,8 @@
! copy attribute in variable before
- td_var%t_att(1:td_var%i_natt)=tl_att(:)
-
+ td_var%t_att(1:td_var%i_natt)=att_copy(tl_att(:))
+
+ ! clean
+ CALL att_clean(tl_att(:))
DEALLOCATE(tl_att)
@@ -4544,4 +4929,5 @@
! no attribute in variable structure
IF( ASSOCIATED(td_var%t_att) )THEN
+ CALL att_clean(td_var%t_att(:))
DEALLOCATE(td_var%t_att)
ENDIF
@@ -4550,5 +4936,5 @@
CALL logger_error( &
- & " ADD ATT: not enough space to put attributes "//&
+ & " VAR ADD ATT: not enough space to put attributes "//&
& "in variable structure "//TRIM(td_var%c_name) )
@@ -4558,11 +4944,9 @@
td_var%i_natt=td_var%i_natt+1
- ! add new attributes
- td_var%t_att(td_var%i_natt)=td_att
-
- ! change attribute id
- DO ji=1,td_var%i_natt
- td_var%t_att(ji)%i_id=ji
- ENDDO
+ ! add new attribute
+ td_var%t_att(td_var%i_natt)=att_copy(td_att)
+
+ !! add new attribute id
+ !td_var%t_att(td_var%i_natt)%i_id=att_get_unit(td_var%t_att(:))
! highlight some attribute
@@ -4577,8 +4961,14 @@
CASE("_FillValue")
td_var%d_fill = td_var%t_att(td_var%i_natt)%d_value(1)
+ CASE("ew_overlap")
+ td_var%i_ew = INT(td_var%t_att(td_var%i_natt)%d_value(1),i4)
CASE("standard_name")
td_var%c_stdname = TRIM(td_var%t_att(td_var%i_natt)%c_value)
+ CASE("long_name")
+ td_var%c_longname = TRIM(td_var%t_att(td_var%i_natt)%c_value)
CASE("units")
td_var%c_units = TRIM(td_var%t_att(td_var%i_natt)%c_value)
+ CASE("grid_point")
+ td_var%c_point = TRIM(td_var%t_att(td_var%i_natt)%c_value)
END SELECT
@@ -4587,19 +4977,56 @@
END SUBROUTINE var__add_att_unit
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine delete an attribute
!> from variable structure.
!
- !> @details
- !
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] td_att : attribute structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var_del_att(td_var, td_att)
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] cd_name attribute name
+ !-------------------------------------------------------------------
+ SUBROUTINE var__del_att_name(td_var, cd_name)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
+ CHARACTER(LEN=*), INTENT(IN ) :: cd_name
+
+ ! local variable
+ INTEGER(i4) :: il_ind
+
+ ! loop indices
+ !----------------------------------------------------------------
+
+ ! check if attribute already in variable structure
+ il_ind=0
+ IF( ASSOCIATED(td_var%t_att) )THEN
+ il_ind=att_get_index( td_var%t_att(:), TRIM(cd_name) )
+ ENDIF
+
+ IF( il_ind == 0 )THEN
+
+ CALL logger_warn( &
+ & " VAR DEL ATT: no attribute "//TRIM(cd_name)//&
+ & ", in variable "//TRIM(td_var%c_name) )
+
+ ELSE
+
+ CALL var_del_att(td_var, td_var%t_att(il_ind))
+
+ ENDIF
+
+ END SUBROUTINE var__del_att_name
+ !-------------------------------------------------------------------
+ !> @brief This subroutine delete an attribute
+ !> from variable structure.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_att attribute structure
+ !-------------------------------------------------------------------
+ SUBROUTINE var__del_att_str(td_var, td_att)
IMPLICIT NONE
! Argument
@@ -4609,31 +5036,32 @@
! local variable
INTEGER(i4) :: il_status
- INTEGER(i4) :: il_attid
+ INTEGER(i4) :: il_ind
TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
! loop indices
- INTEGER(i4) :: ji
+ !INTEGER(i4) :: ji
!----------------------------------------------------------------
! check if attribute already in variable structure
- il_attid=0
+ il_ind=0
IF( ASSOCIATED(td_var%t_att) )THEN
- il_attid=att_get_id( td_var%t_att(:), td_att%c_name )
- ENDIF
-
- IF( il_attid == 0 )THEN
+ il_ind=att_get_index( td_var%t_att(:), td_att%c_name )
+ ENDIF
+
+ IF( il_ind == 0 )THEN
CALL logger_warn( &
- & " DEL ATT: no attribute "//TRIM(td_att%c_name)//&
+ & " VAR DEL ATT: no attribute "//TRIM(td_att%c_name)//&
& ", in variable "//TRIM(td_var%c_name) )
ELSE
- CALL logger_debug( &
- & " DEL ATT: del attribute "//TRIM(td_att%c_name)//&
+ CALL logger_trace( &
+ & " VAR DEL ATT: del attribute "//TRIM(td_att%c_name)//&
& ", in var "//TRIM(td_var%c_name) )
IF( td_var%i_natt == 1 )THEN
+ CALL att_clean(td_var%t_att(:))
DEALLOCATE(td_var%t_att)
@@ -4646,5 +5074,5 @@
CALL logger_error( &
- & " ADD ATT: not enough space to put attributes from "//&
+ & " VAR ADD ATT: not enough space to put attributes from "//&
& TRIM(td_var%c_name)//" in temporary attribute structure")
@@ -4652,9 +5080,10 @@
! save temporary global attribute's variable structure
- tl_att(1:il_attid-1)=td_var%t_att(1:il_attid-1)
- IF( il_attid < td_var%i_natt )THEN
- tl_att(il_attid:)=td_var%t_att(il_attid+1:)
+ tl_att(1:il_ind-1)=att_copy(td_var%t_att(1:il_ind-1))
+ IF( il_ind < td_var%i_natt )THEN
+ tl_att(il_ind:)=att_copy(td_var%t_att(il_ind+1:))
ENDIF
+ CALL att_clean(td_var%t_att(:))
DEALLOCATE( td_var%t_att )
@@ -4666,5 +5095,5 @@
CALL logger_error( &
- & " ADD ATT: not enough space to put attributes "//&
+ & " VAR ADD ATT: not enough space to put attributes "//&
& "in variable structure "//TRIM(td_var%c_name) )
@@ -4672,11 +5101,13 @@
! copy attribute in variable before
- td_var%t_att(1:td_var%i_natt)=tl_att(:)
-
- ! change attribute id
- DO ji=1,td_var%i_natt
- td_var%t_att(ji)%i_id=ji
- ENDDO
-
+ td_var%t_att(1:td_var%i_natt)=att_copy(tl_att(:))
+
+ !! change attribute id
+ !DO ji=1,td_var%i_natt
+ ! td_var%t_att(ji)%i_id=ji
+ !ENDDO
+
+ ! clean
+ CALL att_clean(tl_att(:))
DEALLOCATE(tl_att)
ENDIF
@@ -4684,20 +5115,15 @@
ENDIF
- END SUBROUTINE var_del_att
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine move a global attribute structure
+ END SUBROUTINE var__del_att_str
+ !-------------------------------------------------------------------
+ !> @brief This subroutine move an attribute structure
!> from variable structure.
!
- !> @details
- !
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] td_att : attribute structure
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_att attribute structure
+ !-------------------------------------------------------------------
SUBROUTINE var_move_att(td_var, td_att)
IMPLICIT NONE
@@ -4711,5 +5137,5 @@
!----------------------------------------------------------------
! copy attribute
- tl_att=td_att
+ tl_att=att_copy(td_att)
! remove attribute with same name
@@ -4719,8 +5145,10 @@
CALL var_add_att(td_var, tl_att)
+ ! clean
+ CALL att_clean(tl_att)
+
END SUBROUTINE var_move_att
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a table of dimension structure in a variable
+ !-------------------------------------------------------------------
+ !> @brief This subroutine add an array of dimension structure in a variable
!> structure.
!> - number of dimension in variable can't be greater than 4
@@ -4728,13 +5156,10 @@
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dim : dimension structure
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__add_dim_tab(td_var, td_dim)
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
+ SUBROUTINE var__add_dim_arr(td_var, td_dim)
IMPLICIT NONE
! Argument
@@ -4749,5 +5174,5 @@
!----------------------------------------------------------------
il_ndim=SIZE(td_dim(:))
- IF( il_ndim <= 4 )THEN
+ IF( il_ndim <= ip_maxdim )THEN
DO ji=1,il_ndim
@@ -4757,85 +5182,191 @@
ELSE
CALL logger_error( &
- & " ADD DIM: too much dimension to put in structure "//&
+ & " VAR ADD DIM: too much dimension to put in structure "//&
& "("//TRIM(fct_str(il_ndim))//")" )
ENDIF
- END SUBROUTINE var__add_dim_tab
- !> @endcode
+ END SUBROUTINE var__add_dim_arr
!-------------------------------------------------------------------
!> @brief This subroutine add one dimension in a variable
- !> structure, after some check.
+ !> structure.
+ !> @details
!> - number of dimension in variable can't be greater than 4
!> - dimension can't be already uses in variable structure
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dim : dimension structure
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__add_dim_unit(td_var, td_dim)
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
+ SUBROUTINE var__add_dim_unit(td_var, td_dim)
IMPLICIT NONE
! Argument
- TYPE(TVAR), INTENT(INOUT) :: td_var
- TYPE(TDIM), INTENT(IN) :: td_dim
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
+ TYPE(TDIM) , INTENT(IN ) :: td_dim
! local variable
+ INTEGER(i4) :: il_ind
+
+ !----------------------------------------------------------------
+
+ IF( td_var%i_ndim <= 4 )THEN
+
+ ! check if dimension already used in variable structure
+ il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname))
+ IF( il_ind == 0 )THEN
+ CALL logger_warn( &
+ & " VAR ADD DIM: dimension "//TRIM(td_dim%c_name)//&
+ & ", short name "//TRIM(td_dim%c_sname)//&
+ & ", will not be added in variable "//TRIM(td_var%c_name) )
+ ELSEIF( td_var%t_dim(il_ind)%l_use )THEN
+ CALL logger_error( &
+ & " VAR ADD DIM: dimension "//TRIM(td_dim%c_name)//&
+ & ", short name "//TRIM(td_dim%c_sname)//&
+ & ", already used in variable "//TRIM(td_var%c_name) )
+ ELSE
+
+ ! back to unorder dimension array
+ CALL dim_unorder(td_var%t_dim(:))
+ ! add new dimension
+ td_var%t_dim(td_var%i_ndim+1)=dim_copy(td_dim)
+
+ ! update number of attribute
+ td_var%i_ndim=COUNT(td_var%t_dim(:)%l_use)
+
+ ENDIF
+ ! reorder dimension to ('x','y','z','t')
+ CALL dim_reorder(td_var%t_dim(:))
+
+ ELSE
+ CALL logger_error( &
+ & " VAR ADD DIM: too much dimension in variable "//&
+ & TRIM(td_var%c_name)//" ("//TRIM(fct_str(td_var%i_ndim))//")")
+ ENDIF
+
+ END SUBROUTINE var__add_dim_unit
+ !-------------------------------------------------------------------
+ !> @brief This subroutine delete a dimension structure in a variable
+ !> structure.
+ !
+ !> @warning delete variable value too.
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
+ SUBROUTINE var_del_dim(td_var, td_dim)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
+ TYPE(TDIM) , INTENT(IN ) :: td_dim
+
+ ! local variable
+ INTEGER(i4) :: il_ind
+ INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape
+
+ TYPE(TDIM) :: tl_dim ! empty dimension structure
+
+ !----------------------------------------------------------------
+
+ IF( td_var%i_ndim <= 4 )THEN
+
+ CALL logger_trace( &
+ & " VAR DEL DIM: delete dimension "//TRIM(td_dim%c_name)//&
+ & ", short name "//TRIM(td_dim%c_sname)//&
+ & ", in variable "//TRIM(td_var%c_name) )
+
+ ! check if dimension already in variable structure
+ il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname))
+
+ ! replace dimension by empty one
+ td_var%t_dim(il_ind)=dim_copy(tl_dim)
+
+ ! update number of dimension
+ td_var%i_ndim=COUNT(td_var%t_dim(:)%l_use)
+
+ ! remove variable value using this dimension
+ IF( ASSOCIATED(td_var%d_value) )THEN
+ il_shape(:)=SHAPE(td_var%d_value(:,:,:,:))
+ IF(il_shape(il_ind)/=td_dim%i_len)THEN
+ CALL logger_warn("VAR DEL DIM: remove value of variable "//&
+ & TRIM(td_var%c_name) )
+ CALL var_del_value(td_var)
+ ENDIF
+ ENDIF
+
+ ! reorder dimension to ('x','y','z','t')
+ CALL dim_reorder(td_var%t_dim)
+
+ ELSE
+ CALL logger_error( &
+ & " VAR DEL DIM: too much dimension in variable "//&
+ & TRIM(td_var%c_name)//" ("//TRIM(fct_str(td_var%i_ndim))//")")
+ ENDIF
+
+ END SUBROUTINE var_del_dim
+ !-------------------------------------------------------------------
+ !> @brief This subroutine move a dimension structure
+ !> in variable structure.
+ !>
+ !> @warning
+ !> - dimension order could be changed
+ !> - delete variable value
+ !
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] td_dim dimension structure
+ !-------------------------------------------------------------------
+ SUBROUTINE var_move_dim(td_var, td_dim)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
+ TYPE(TDIM) , INTENT(IN ) :: td_dim
+
+ ! local variable
+ INTEGER(i4) :: il_ind
INTEGER(i4) :: il_dimid
!----------------------------------------------------------------
- IF( td_var%i_ndim <= 4 )THEN
-
- ! check if dimension already used in variable structure
- il_dimid=dim_get_id( td_var%t_dim(:), td_dim%c_name, td_dim%c_sname )
-
- IF( il_dimid == 0 )THEN
-
- ! add dimension
- CALL var__add_dim(td_var, td_dim)
+
+ IF( td_var%i_ndim <= ip_maxdim )THEN
+
+ ! check if dimension already in mpp structure
+ il_ind=dim_get_index(td_var%t_dim(:), td_dim%c_name, td_dim%c_sname)
+ IF( il_ind /= 0 )THEN
+
+ il_dimid=td_var%t_dim(il_ind)%i_id
+ ! replace dimension
+ td_var%t_dim(il_ind)=dim_copy(td_dim)
+ td_var%t_dim(il_ind)%i_id=il_dimid
+ td_var%t_dim(il_ind)%l_use=.TRUE.
ELSE
-
- IF( td_var%t_dim(il_dimid)%l_use )THEN
-
- CALL logger_error( &
- & " ADD DIM: dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", already used in variable "//TRIM(td_var%c_name) )
- ELSE
- ! add dimension
- CALL var__add_dim(td_var, td_dim)
- ENDIF
-
+ CALL var_add_dim(td_var, td_dim)
ENDIF
ELSE
CALL logger_error( &
- & " ADD DIM: too much dimension in variable "//&
+ & "VAR MOVE DIM: too much dimension in variale "//&
& TRIM(td_var%c_name)//" ("//TRIM(fct_str(td_var%i_ndim))//")")
ENDIF
- END SUBROUTINE var__add_dim_unit
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a dimension structure in a variable
- !> structure.
- !
+ END SUBROUTINE var_move_dim
+ !-------------------------------------------------------------------
+ !> @brief This subroutine print informations of an array of variables.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dim : dimension structure
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__add_dim(td_var, td_dim)
+ !> - June, 2014- Initial Version
+ !
+ !> @param[in] td_var array of variables structure
+ !-------------------------------------------------------------------
+ SUBROUTINE var__print_arr(td_var)
IMPLICIT NONE
+
! Argument
- TYPE(TVAR), INTENT(INOUT) :: td_var
- TYPE(TDIM), INTENT(IN) :: td_dim
+ TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_var
! loop indices
@@ -4843,160 +5374,22 @@
!----------------------------------------------------------------
- CALL logger_info( &
- & " ADD DIM: add dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", length "//TRIM(fct_str(td_dim%i_len))//&
- & ", in variable "//TRIM(td_var%c_name) )
-
- ! if dimension order already changed
- IF( ANY(td_var%t_dim(:)%i_xyzt2 /= 0 ) )THEN
- ! unordered dimension structure
- CALL dim_unorder(td_var%t_dim(:))
- ENDIF
-
- ! search unused dimension
- DO ji=1,ip_maxdim
- IF( .NOT. td_var%t_dim(ji)%l_use )THEN
- ! add new dimension
- td_var%t_dim(ji)=td_dim
- td_var%t_dim(ji)%i_id=ji
- !!td_var%t_dim(ji)%l_use=.TRUE.
- IF( td_var%t_dim(ji)%l_use )THEN
- ! update number of attribute
- td_var%i_ndim=td_var%i_ndim+1
- ENDIF
- EXIT
- ENDIF
+ DO ji=1,SIZE(td_var(:))
+ CALL var_print(td_var(ji))
ENDDO
- ! reorder dimension to ('x','y','z','t')
- CALL dim_reorder(td_var%t_dim(:))
-
- END SUBROUTINE var__add_dim
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine delete a dimension structure in a variable
- !> structure.
- !
- !> @warning delete variable value too
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dim : dimension structure
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var_del_dim(td_var, td_dim)
- IMPLICIT NONE
- ! Argument
- TYPE(TVAR), INTENT(INOUT) :: td_var
- TYPE(TDIM), INTENT(IN) :: td_dim
-
- ! local variable
- INTEGER(i4) :: il_dimid
- TYPE(TDIM) :: tl_dim ! empty dimension structure
-
- INTEGER(i4), DIMENSION(ip_maxdim) :: il_shape
-
- !----------------------------------------------------------------
- IF( td_var%i_ndim <= 4 )THEN
-
- ! check if dimension already in variable structure
- il_dimid=dim_get_id( td_var%t_dim(:), td_dim%c_name, td_dim%c_sname )
- IF( il_dimid == 0 )THEN
-
- CALL logger_warn( &
- & " DEL DIM: no dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", in variable "//TRIM(td_var%c_name) )
-
- ELSE
-
- CALL logger_debug( &
- & " DEL DIM: delete dimension "//TRIM(td_dim%c_name)//&
- & ", short name "//TRIM(td_dim%c_sname)//&
- & ", in variable "//TRIM(td_var%c_name)//&
- & " id "//TRIM(fct_str(il_dimid)) )
-
- ! replace dimension by empty one
- td_var%t_dim(il_dimid)=tl_dim
-
- ! update number of dimension
- td_var%i_ndim=td_var%i_ndim-1
-
- IF( ASSOCIATED(td_var%d_value) )THEN
- il_shape(:)=SHAPE(td_var%d_value(:,:,:,:))
- IF(il_shape(il_dimid)/=td_dim%i_len)THEN
- CALL logger_warn("VAR DEL DIM: remove value of variable "//&
- & TRIM(td_var%c_name) )
- CALL var_del_value(td_var)
- ENDIF
- ENDIF
-
- ! reorder dimension to ('x','y','z','t')
- CALL dim_reorder(td_var%t_dim)
-
- ENDIF
- ELSE
- CALL logger_error( &
- & " DEL DIM: too much dimension in variable "//&
- & TRIM(td_var%c_name)//" ("//TRIM(fct_str(td_var%i_ndim))//")")
- ENDIF
-
- END SUBROUTINE var_del_dim
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine move a dimension structure
- !> in variable structure.
- !>
- !> @warning
- !> - dimension order could be changed
- !> - delete variable value
- !
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] td_dim : dimension structure
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var_move_dim(td_var, td_dim)
- IMPLICIT NONE
- ! Argument
- TYPE(TVAR), INTENT(INOUT) :: td_var
- TYPE(TDIM), INTENT(IN) :: td_dim
-
- ! local variable
- TYPE(TDIM) :: tl_dim
- !----------------------------------------------------------------
-
- ! copy dimension
- tl_dim=td_dim
-
- ! remove dimension with same name
- CALL var_del_dim(td_var, tl_dim)
-
- ! add new dimension
- CALL var_add_dim(td_var, tl_dim)
-
- END SUBROUTINE var_move_dim
- !> @endcode
+ END SUBROUTINE var__print_arr
!-------------------------------------------------------------------
!> @brief This subroutine print variable information.
+ !> @details
!> If ld_more is TRUE (default), print information about variable dimensions
!> and variable attributes.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : variable structure
- !> @param[in] ld_more : print more infomration about variable
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var_print(td_var, ld_more)
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_var variable structure
+ !> @param[in] ld_more print more infomration about variable
+ !-------------------------------------------------------------------
+ SUBROUTINE var__print_unit(td_var, ld_more)
IMPLICIT NONE
@@ -5039,6 +5432,21 @@
END SELECT
+ WRITE(*,'((/a,a),4(/3x,a,a),4(/3x,a,i3),&
+ & (/3x,a,a),3(/3x,a,ES12.4))')&
+ & " Variable : ",TRIM(td_var%c_name), &
+ & " standard name : ",TRIM(td_var%c_stdname), &
+ & " long name : ",TRIM(td_var%c_longname), &
+ & " units : ",TRIM(td_var%c_units), &
+ & " point : ",TRIM(td_var%c_point), &
+ & " id : ",td_var%i_id, &
+ & " rec : ",td_var%i_rec, &
+ & " ndim : ",td_var%i_ndim, &
+ & " natt : ",td_var%i_natt, &
+ & " type : ",TRIM(cl_type), &
+ & " scale factor : ",td_var%d_scf, &
+ & " add offset : ",td_var%d_ofs, &
+ & " _FillValue : ",td_var%d_fill
+
IF( ASSOCIATED(td_var%d_value) )THEN
- WRITE(*,*) "ASSOCIATED"
dl_min=MINVAL(td_var%d_value(:,:,:,:), &
& mask=(td_var%d_value(:,:,:,:)/=td_var%d_fill) )&
@@ -5047,30 +5455,15 @@
& mask=(td_var%d_value(:,:,:,:)/=td_var%d_fill) )&
& *td_var%d_scf+td_var%d_ofs
- ELSE
- WRITE(*,*) "NOT ASSOCIATED"
- dl_min=0.
- dl_max=0.
- ENDIF
-
- WRITE(*,'((a,a),3(/3x,a,a),3(/3x,a,i3),&
- & (/3x,a,a),5(/3x,a,ES12.4))')&
- & " Variable : ",TRIM(td_var%c_name), &
- & " standard name : ",TRIM(td_var%c_stdname), &
- & " units : ",TRIM(td_var%c_units), &
- & " point : ",TRIM(td_var%c_point), &
- & " id : ",td_var%i_id, &
- & " ndim : ",td_var%i_ndim, &
- & " natt : ",td_var%i_natt, &
- & " type : ",TRIM(cl_type), &
- & " scale factor : ",td_var%d_scf, &
- & " add offset : ",td_var%d_ofs, &
- & " _FillValue : ",td_var%d_fill, &
- & " min value : ",dl_min, &
- & " max value : ",dl_max
+
+ WRITE(*,'((3x,a),2(/3x,a,ES12.4))')&
+ & "VALUE ASSOCIATED" , &
+ & " min value : ",dl_min,&
+ & " max value : ",dl_max
+ ENDIF
IF( ll_more )THEN
! print dimension
IF( td_var%i_ndim /= 0 )THEN
- WRITE(*,'(/a)') " Variable dimension"
+ WRITE(*,'(a)') " Variable dimension"
DO ji=1,ip_maxdim
IF( td_var%t_dim(ji)%l_use )THEN
@@ -5082,5 +5475,5 @@
! print attribute
IF( td_var%i_natt /= 0 )THEN
- WRITE(*,'(/a)') " Variable attribute"
+ WRITE(*,'(a)') " Variable attribute"
DO ji=1,td_var%i_natt
CALL att_print(td_var%t_att(ji))
@@ -5089,28 +5482,23 @@
ENDIF
- END SUBROUTINE var_print
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a 4D table of double value in a variable
+ END SUBROUTINE var__print_unit
+ !-------------------------------------------------------------------
+ !> @brief This subroutine add a 4D array of real(8) value in a variable
!> structure.
- !>
- !> @warning Dimension of the table must be ordered as ('x','y','z','t')
!
!> @details
!> indices in the variable where value will be written could be specify if
- !> start and count table are given.
- !
+ !> start and count array are given.
+ !> @warning Dimension of the array must be ordered as ('x','y','z','t')
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] dd_value : table of variable value
- !> @param[in] id_start : index in the variable from which the data values
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_var variable structure
+ !> @param[in] dd_value array of variable value
+ !> @param[in] id_start index in the variable from which the data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
SUBROUTINE var__add_value(td_var, dd_value, id_start, id_count)
IMPLICIT NONE
@@ -5135,10 +5523,10 @@
((.NOT. PRESENT(id_start)) .AND. PRESENT(id_count) ) )THEN
CALL logger_warn( &
- & " ADD VALUE: id_start and id_count should be both specified")
+ & " VAR ADD VALUE: id_start and id_count should be both specified")
ENDIF
IF( PRESENT(id_start).AND.PRESENT(id_count) )THEN
- ! keep ordered table ('x','y','z','t')
+ ! keep ordered array ('x','y','z','t')
il_start(:)=id_start(:)
il_count(:)=id_count(:)
@@ -5146,5 +5534,5 @@
ELSE
- ! keep ordered table ('x','y','z','t')
+ ! keep ordered array ('x','y','z','t')
il_start(:)=(/1,1,1,1/)
il_count(:)=td_var%t_dim(:)%i_len
@@ -5152,16 +5540,16 @@
ENDIF
- ! check dimension of input table
+ ! check dimension of input array
il_shape(:)=SHAPE(dd_value(:,:,:,:))
IF(.NOT.ALL( il_count(:) == il_shape(:)) )THEN
- CALL logger_error( &
- & " ADD VALUE: dimension of input table, and count table differ " )
CALL logger_debug(" ADD VALUE: check dimension order !!")
DO ji = 1, ip_maxdim
CALL logger_debug( &
- & " ADD VALUE: count : "//TRIM(fct_str(il_count(ji)))//&
- & " table dimension : "//TRIM(fct_str(il_shape(ji))))
+ & " VAR ADD VALUE: count : "//TRIM(fct_str(il_count(ji)))//&
+ & " array dimension : "//TRIM(fct_str(il_shape(ji))))
ENDDO
+ CALL logger_error( &
+ & " VAR ADD VALUE: dimension of input array, and count array differ " )
ELSE
@@ -5169,15 +5557,15 @@
! check dimension of variable
IF(.NOT.ALL(il_start(:)+il_count(:)-1 <= td_var%t_dim(:)%i_len) )THEN
- CALL logger_error( &
- & " ADD VALUE: start + count exceed variable dimension. " )
-
- CALL logger_debug(" ADD VALUE: check dimension order !!")
+
+ CALL logger_debug(" VAR ADD VALUE: check dimension order !!")
DO ji = 1, ip_maxdim
CALL logger_debug( &
- & " ADD VALUE: start ("//TRIM(fct_str(il_start(ji)))//") "//&
+ & " VAR ADD VALUE: start ("//TRIM(fct_str(il_start(ji)))//") "//&
& "+ count ("//TRIM(fct_str(il_count(ji)))//") "//&
& "variable dimension "//TRIM(fct_str(td_var%t_dim(ji)%i_len)))
ENDDO
+ CALL logger_error( &
+ & " VAR ADD VALUE: start + count exceed variable dimension bound. " )
ELSE
@@ -5191,5 +5579,5 @@
CALL logger_warn( &
- & " ADD VALUE: value already in variable "//&
+ & "VAR ADD VALUE: value already in variable "//&
& TRIM(td_var%c_name)//&
& " (standard name "//TRIM(td_var%c_stdname)//")" )
@@ -5206,5 +5594,5 @@
CALL logger_error( &
- & " ADD VALUE: not enough space to put variable "//&
+ & " VAR ADD VALUE: not enough space to put variable "//&
& TRIM(td_var%c_name)//&
& " in variable structure")
@@ -5212,7 +5600,7 @@
ENDIF
- ! initialise table
- CALL logger_info( &
- & " ADD VALUE: value in variable "//TRIM(td_var%c_name)//&
+ ! initialise array
+ CALL logger_trace( &
+ & " VAR ADD VALUE: value in variable "//TRIM(td_var%c_name)//&
& ", initialise to FillValue "//TRIM(fct_str(td_var%d_fill)) )
td_var%d_value(:,:,:,:)=td_var%d_fill
@@ -5220,6 +5608,6 @@
ENDIF
- CALL logger_info( &
- & " ADD VALUE: put value in variable "//TRIM(td_var%c_name)//&
+ CALL logger_debug( &
+ & " VAR ADD VALUE: put value in variable "//TRIM(td_var%c_name)//&
& " (standard name "//TRIM(td_var%c_stdname)//")" )
@@ -5234,32 +5622,28 @@
END SUBROUTINE var__add_value
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a 4D table of real(8) value in a variable
- !> structure. Dimension of the table must be ordered as ('x','y','z','t')
- !
+ !-------------------------------------------------------------------
+ !> @brief This subroutine add a 4D array of real(8) value in a variable
+ !> structure. Dimension of the array must be ordered as ('x','y','z','t')
+ !>
!> @details
- !> indices of the variable where value will be written could be specify
- !> with start and count table.
- !>
- !> @note variable type is forced to DOUBLE
- !
+ !> Optionally, you could specify the type of the variable to be used (default real(8)),
+ !> and indices of the variable where value will be written with start and count array.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] dd_value : table of variable value
- !> @param[in] id_start : start indices of the variable where data values
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_var variable structure
+ !> @param[in] dd_value array of variable value
+ !> @param[in] id_type type of the variable to be used (default real(8))
+ !> @param[in] id_start start indices of the variable where data values
!> will be written
- !> @param[in] id_count : number of indices selected along each dimension
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__add_value_dp(td_var, dd_value, id_start, id_count)
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
+ SUBROUTINE var__add_value_dp(td_var, dd_value, id_type, id_start, id_count)
IMPLICIT NONE
! Argument
TYPE(TVAR), INTENT(INOUT) :: td_var
REAL(dp), DIMENSION(:,:,:,:), INTENT(IN) :: dd_value
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_type
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
@@ -5269,7 +5653,7 @@
!----------------------------------------------------------------
- IF( td_var%i_type == 0 )THEN
- td_var%i_type=NF90_DOUBLE
- ELSE
+ IF( PRESENT(id_type) )THEN
+ td_var%i_type=id_type
+
cl_type=''
SELECT CASE(td_var%i_type)
@@ -5285,5 +5669,5 @@
cl_type='BYTE'
END SELECT
- CALL logger_info("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
+ CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
& " value will be saved as "//TRIM(cl_type))
ENDIF
@@ -5292,32 +5676,28 @@
END SUBROUTINE var__add_value_dp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a 4D table of real value in a variable
- !> structure. Dimension of the table must be ordered as ('x','y','z','t')
+ !-------------------------------------------------------------------
+ !> @brief This subroutine add a 4D array of real(4) value in a variable
+ !> structure. Dimension of the array must be ordered as ('x','y','z','t')
!
!> @details
- !> indices of the variable where value will be written could be specify
- !> wiht start and count table.
- !>
- !> @note variable type is forced to FLOAT
- !
+ !> Optionally, you could specify the type of the variable to be used (default real(4)),
+ !> and indices of the variable where value will be written with start and count array.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] rd_value : table of variable value
- !> @param[in] id_start : start indices of the variable where data values
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] rd_value array of variable value
+ !> @param[in] id_type type of the variable to be used (default real(4))
+ !> @param[in] id_start start indices of the variable where data values
!> will be written
- !> @param[in] id_count : number of indices selected along each dimension
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__add_value_rp(td_var, rd_value, id_start, id_count)
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
+ SUBROUTINE var__add_value_rp(td_var, rd_value, id_type, id_start, id_count)
IMPLICIT NONE
! Argument
TYPE(TVAR), INTENT(INOUT) :: td_var
REAL(sp), DIMENSION(:,:,:,:), INTENT(IN) :: rd_value
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_type
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
@@ -5332,7 +5712,7 @@
!----------------------------------------------------------------
- IF( td_var%i_type == 0 )THEN
- td_var%i_type=NF90_FLOAT
- ELSE
+ IF( PRESENT(id_type) )THEN
+ td_var%i_type=id_type
+
cl_type=''
SELECT CASE(td_var%i_type)
@@ -5348,5 +5728,5 @@
cl_type='BYTE'
END SELECT
- CALL logger_info("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
+ CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
& " value will be saved as "//TRIM(cl_type))
ENDIF
@@ -5358,5 +5738,5 @@
CALL logger_error( &
- & " ADD VALUE: not enough space to put variable "//&
+ & " VAR ADD VALUE: not enough space to put variable "//&
& TRIM(td_var%c_name)//&
& " in variable structure")
@@ -5370,32 +5750,30 @@
END SUBROUTINE var__add_value_rp
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a 4D table of integer(1) value in a variable
- !> structure. Dimension of the table must be ordered as ('x','y','z','t')
+ !-------------------------------------------------------------------
+ !> @brief This subroutine add a 4D array of integer(1) value in a variable
+ !> structure. Dimension of the array must be ordered as ('x','y','z','t')
!
!> @details
- !> indices in the variable where value will be written could be specify if
- !> start and count table are given.
+ !> Optionally, you could specify the type of the variable to be used (default integer(1)),
+ !> and indices of the variable where value will be written with start and count array.
!>
!> @note variable type is forced to BYTE
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variabele structure
- !> @param[in] bd_value : table of variable value
- !> @param[in] id_start : start indices of the variable where data values
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variabele structure
+ !> @param[in] bd_value array of variable value
+ !> @param[in] id_type type of the variable to be used (default integer(1))
+ !> @param[in] id_start start indices of the variable where data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__add_value_i1(td_var, bd_value, id_start, id_count)
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
+ SUBROUTINE var__add_value_i1(td_var, bd_value, id_type, id_start, id_count)
IMPLICIT NONE
! Argument
TYPE(TVAR), INTENT(INOUT) :: td_var
INTEGER(i1), DIMENSION(:,:,:,:), INTENT(IN) :: bd_value
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_type
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
@@ -5410,7 +5788,7 @@
!----------------------------------------------------------------
- IF( td_var%i_type == 0 )THEN
- td_var%i_type=NF90_BYTE
- ELSE
+ IF( PRESENT(id_type) )THEN
+ td_var%i_type=id_type
+
cl_type=''
SELECT CASE(td_var%i_type)
@@ -5426,5 +5804,5 @@
cl_type='BYTE'
END SELECT
- CALL logger_info("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
+ CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
& " value will be saved as "//TRIM(cl_type))
ENDIF
@@ -5436,5 +5814,5 @@
CALL logger_error( &
- & " ADD VALUE: not enough space to put variable "//&
+ & " VAR ADD VALUE: not enough space to put variable "//&
& TRIM(td_var%c_name)//&
& " in variable structure")
@@ -5448,32 +5826,30 @@
END SUBROUTINE var__add_value_i1
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a 4D table of integer(1) value in a variable
- !> structure. Dimension of the table must be ordered as ('x','y','z','t')
+ !-------------------------------------------------------------------
+ !> @brief This subroutine add a 4D array of integer(2) value in a variable
+ !> structure. Dimension of the array must be ordered as ('x','y','z','t')
!
!> @details
- !> indices in the variable where value will be written could be specify if
- !> start and count table are given.
+ !> Optionally, you could specify the type of the variable to be used (default integer(2)),
+ !> and indices of the variable where value will be written with start and count array.
!>
!> @note variable type is forced to SHORT
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variabele structure
- !> @param[in] sd_value : table of variable value
- !> @param[in] id_start : start indices of the variable where data values
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variabele structure
+ !> @param[in] sd_value array of variable value
+ !> @param[in] id_type type of the variable to be used (default integer(2))
+ !> @param[in] id_start start indices of the variable where data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__add_value_i2(td_var, sd_value, id_start, id_count)
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
+ SUBROUTINE var__add_value_i2(td_var, sd_value, id_type, id_start, id_count)
IMPLICIT NONE
! Argument
TYPE(TVAR), INTENT(INOUT) :: td_var
INTEGER(i2), DIMENSION(:,:,:,:), INTENT(IN) :: sd_value
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_type
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
@@ -5488,7 +5864,7 @@
!----------------------------------------------------------------
- IF( td_var%i_type == 0 )THEN
- td_var%i_type=NF90_SHORT
- ELSE
+ IF( PRESENT(id_type) )THEN
+ td_var%i_type=id_type
+
cl_type=''
SELECT CASE(td_var%i_type)
@@ -5504,5 +5880,5 @@
cl_type='BYTE'
END SELECT
- CALL logger_info("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
+ CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
& " value will be saved as "//TRIM(cl_type))
ENDIF
@@ -5514,5 +5890,5 @@
CALL logger_error( &
- & " ADD VALUE: not enough space to put variable "//&
+ & " VAR ADD VALUE: not enough space to put variable "//&
& TRIM(td_var%c_name)//&
& " in variable structure")
@@ -5526,32 +5902,30 @@
END SUBROUTINE var__add_value_i2
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a 4D table of integer(4) value in a variable
- !> structure. Dimension of the table must be ordered as ('x','y','z','t')
+ !-------------------------------------------------------------------
+ !> @brief This subroutine add a 4D array of integer(4) value in a variable
+ !> structure. Dimension of the array must be ordered as ('x','y','z','t')
!
!> @details
- !> indices in the variable where value will be written could be specify if
- !> start and count table are given.
+ !> Optionally, you could specify the type of the variable to be used (default integer(4)),
+ !> and indices of the variable where value will be written with start and count array.
!>
!> @note variable type is forced to INT
!
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variabele structure
- !> @param[in] id_value : table of variable value
- !> @param[in] id_start : start indices of the variable where data values
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variabele structure
+ !> @param[in] id_value array of variable value
+ !> @param[in] id_type type of the variable to be used (default integer(4))
+ !> @param[in] id_start start indices of the variable where data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__add_value_i4(td_var, id_value, id_start, id_count)
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
+ SUBROUTINE var__add_value_i4(td_var, id_value, id_type, id_start, id_count)
IMPLICIT NONE
! Argument
TYPE(TVAR), INTENT(INOUT) :: td_var
INTEGER(i4), DIMENSION(:,:,:,:), INTENT(IN) :: id_value
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_type
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
@@ -5566,7 +5940,7 @@
!----------------------------------------------------------------
- IF( td_var%i_type == 0 )THEN
- td_var%i_type=NF90_INT
- ELSE
+ IF( PRESENT(id_type) )THEN
+ td_var%i_type=id_type
+
cl_type=''
SELECT CASE(td_var%i_type)
@@ -5582,5 +5956,5 @@
cl_type='BYTE'
END SELECT
- CALL logger_info("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
+ CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
& " value will be saved as "//TRIM(cl_type))
ENDIF
@@ -5592,5 +5966,5 @@
CALL logger_error( &
- & " ADD VALUE: not enough space to put variable "//&
+ & " VAR ADD VALUE: not enough space to put variable "//&
& TRIM(td_var%c_name)//&
& " in variable structure")
@@ -5604,32 +5978,28 @@
END SUBROUTINE var__add_value_i4
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This subroutine add a 4D table of integer(4) value in a variable
- !> structure. Dimension of the table must be ordered as ('x','y','z','t')
+ !-------------------------------------------------------------------
+ !> @brief This subroutine add a 4D array of integer(8) value in a variable
+ !> structure. Dimension of the array must be ordered as ('x','y','z','t')
!
!> @details
- !> indices in the variable where value will be written could be specify if
- !> start and count table are given.
- !>
- !> @note variable type is forced to INT
- !
+ !> Optionally, you could specify the type of the variable to be used (default integer(4)),
+ !> and indices of the variable where value will be written with start and count array.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] kd_value : table of variable value
- !> @param[in] id_start : start indices of the variable where data values
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] kd_value array of variable value
+ !> @param[in] id_type type of the variable to be used (default integer(8))
+ !> @param[in] id_start start indices of the variable where data values
!> will be read
- !> @param[in] id_count : number of indices selected along each dimension
- !
- !> @todo
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var__add_value_i8(td_var, kd_value, id_start, id_count)
+ !> @param[in] id_count number of indices selected along each dimension
+ !-------------------------------------------------------------------
+ SUBROUTINE var__add_value_i8(td_var, kd_value, id_type, id_start, id_count)
IMPLICIT NONE
! Argument
TYPE(TVAR), INTENT(INOUT) :: td_var
INTEGER(i8), DIMENSION(:,:,:,:), INTENT(IN) :: kd_value
+ INTEGER(i4), INTENT(IN), OPTIONAL :: id_type
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_start
INTEGER(i4), DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: id_count
@@ -5644,7 +6014,7 @@
!----------------------------------------------------------------
- IF( td_var%i_type == 0 )THEN
- td_var%i_type=NF90_INT
- ELSE
+ IF( PRESENT(id_type) )THEN
+ td_var%i_type=id_type
+
cl_type=''
SELECT CASE(td_var%i_type)
@@ -5660,5 +6030,5 @@
cl_type='BYTE'
END SELECT
- CALL logger_info("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
+ CALL logger_trace("VAR ADD VALUE: "//TRIM(td_var%c_name)//&
& " value will be saved as "//TRIM(cl_type))
ENDIF
@@ -5670,5 +6040,5 @@
CALL logger_error( &
- & " ADD VALUE: not enough space to put variable "//&
+ & " VAR ADD VALUE: not enough space to put variable "//&
& TRIM(td_var%c_name)//&
& " in variable structure")
@@ -5682,16 +6052,13 @@
END SUBROUTINE var__add_value_i8
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine remove variable value in a variable
!> structure.
- !
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE var_del_value(td_var)
IMPLICIT NONE
@@ -5700,6 +6067,6 @@
!----------------------------------------------------------------
- CALL logger_warn( &
- & " DEL VALUE: value in variable "//TRIM(td_var%c_name)//&
+ CALL logger_debug( &
+ & " VAR DEL VALUE: value in variable "//TRIM(td_var%c_name)//&
& ", standard name "//TRIM(td_var%c_stdname)//&
& " will be remove ")
@@ -5708,18 +6075,81 @@
END SUBROUTINE var_del_value
- !> @endcode
- !-------------------------------------------------------------------
- !> @brief This function return the variable id, in a table of variable
- !> structure, given variable name or standard name
- !
+ !-------------------------------------------------------------------
+ !> @brief This function return the variable index, in a array of variable
+ !> structure, given variable name or standard name.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : table of variable structure
- !> @param[in] cd_name : variable name
- !> @param[in] cd_stdname : variable standard name
- !> @return variable id in table of variable structure (0 if not found)
- !-------------------------------------------------------------------
- !> @code
+ !> - September, 2014- Initial Version
+ !>
+ !> @param[in] td_var array of variable structure
+ !> @param[in] cd_name variable name
+ !> @param[in] cd_stdname variable standard name
+ !> @return variable index in array of variable structure (0 if not found)
+ !-------------------------------------------------------------------
+ INTEGER(i4) FUNCTION var_get_index(td_var, cd_name, cd_stdname)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR) , DIMENSION(:), INTENT(IN) :: td_var
+ CHARACTER(LEN=*), INTENT(IN) :: cd_name
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_stdname
+
+ ! local variable
+ INTEGER(i4) :: il_size
+
+ ! loop indices
+ INTEGER(i4) :: ji
+ !----------------------------------------------------------------
+ var_get_index=0
+ il_size=SIZE(td_var(:))
+
+ ! check if variable is in array of variable structure
+ DO ji=1,il_size
+ ! look for variable name
+ IF( fct_lower(td_var(ji)%c_name) == fct_lower(cd_name) )THEN
+
+ var_get_index=ji
+ EXIT
+
+ ! look for variable standard name
+ ELSE IF( fct_lower(td_var(ji)%c_stdname) == fct_lower(cd_name) .AND.&
+ & TRIM(fct_lower(td_var(ji)%c_stdname)) /= '' )THEN
+
+ var_get_index=ji
+ EXIT
+
+ ELSE IF( PRESENT(cd_stdname) )THEN
+ IF( fct_lower(td_var(ji)%c_stdname) == fct_lower(cd_stdname) .AND.&
+ & TRIM(fct_lower(td_var(ji)%c_stdname)) /= '' )THEN
+
+ var_get_index=ji
+ EXIT
+ ENDIF
+
+ ! look for variable longname
+ ELSE IF( fct_lower(td_var(ji)%c_longname) == fct_lower(cd_name) .AND.&
+ & TRIM(fct_lower(td_var(ji)%c_longname)) /= '' )THEN
+
+ var_get_index=ji
+ EXIT
+
+ ENDIF
+
+ ENDDO
+
+ END FUNCTION var_get_index
+ !-------------------------------------------------------------------
+ !> @brief This function return the variable id,
+ !> given variable name or standard name.
+ !>
+ !> @warning only variable read from file, have an id.
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_var array of variable structure
+ !> @param[in] cd_name variable name
+ !> @param[in] cd_stdname variable standard name
+ !> @return variable id in array of variable structure (0 if not found)
+ !-------------------------------------------------------------------
INTEGER(i4) FUNCTION var_get_id(td_var, cd_name, cd_stdname)
IMPLICIT NONE
@@ -5738,10 +6168,10 @@
il_size=SIZE(td_var(:))
- ! check if variable is in table of variable structure
+ ! check if variable is in array of variable structure
DO ji=1,il_size
! look for variable name
IF( fct_lower(td_var(ji)%c_name) == fct_lower(cd_name) )THEN
- var_get_id=ji
+ var_get_id=td_var(ji)%i_id
EXIT
@@ -5749,7 +6179,6 @@
ELSE IF( fct_lower(td_var(ji)%c_stdname) == fct_lower(cd_name) .AND.&
& TRIM(fct_lower(td_var(ji)%c_stdname)) /= '' )THEN
- !& TRIM(ADJUSTL(cd_stdname)) /= 'unknown' )THEN
- var_get_id=ji
+ var_get_id=td_var(ji)%i_id
EXIT
@@ -5757,7 +6186,6 @@
IF( fct_lower(td_var(ji)%c_stdname) == fct_lower(cd_stdname) .AND.&
& TRIM(fct_lower(td_var(ji)%c_stdname)) /= '' )THEN
- !& TRIM(ADJUSTL(cd_stdname)) /= 'unknown' )THEN
- var_get_id=ji
+ var_get_id=td_var(ji)%i_id
EXIT
ENDIF
@@ -5767,18 +6195,14 @@
END FUNCTION var_get_id
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This function return the mask of variable, given variable structure
- !> @detail
- !>
- !
+ !> This function return the mask 3D of variable, given variable structure.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : table of variable structure
- !> @return variable id in table of variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_var array of variable structure
+ !> @return variable mask(3D)
+ !-------------------------------------------------------------------
FUNCTION var_get_mask(td_var)
IMPLICIT NONE
@@ -5787,7 +6211,7 @@
! function
- !INTEGER(i4), DIMENSION(:,:), POINTER :: var_get_mask
INTEGER(i4), DIMENSION(td_var%t_dim(1)%i_len, &
- & td_var%t_dim(2)%i_len) :: var_get_mask
+ & td_var%t_dim(2)%i_len, &
+ & td_var%t_dim(3)%i_len ) :: var_get_mask
! local variable
@@ -5795,39 +6219,45 @@
IF( ASSOCIATED(td_var%d_value) )THEN
- CALL logger_trace( "GET MASK: create mask from variable "//&
+ CALL logger_trace( "VAR GET MASK: create mask from variable "//&
& TRIM(td_var%c_name) )
- var_get_mask(:,:)=1
- WHERE( td_var%d_value(:,:,1,1) == td_var%d_fill )
- var_get_mask(:,:)=0
+ var_get_mask(:,:,:)=1
+ WHERE( td_var%d_value(:,:,:,1) == td_var%d_fill )
+ var_get_mask(:,:,:)=0
ENDWHERE
ELSE
- CALL logger_error("GET MASK: variable value not define.")
+ CALL logger_error("VAR GET MASK: variable value not define.")
ENDIF
END FUNCTION var_get_mask
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine change Fill Value of the variable to
- !> standard NETCDF Fill Value
- !> @detail
+ !> This subroutine change FillValue of the variable to
+ !> standard NETCDF FillValue.
+ !>
+ !> @details
+ !> optionally, you could specify a dummy _FillValue to be used
!>
- !
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : table of variable structure
- !-------------------------------------------------------------------
- !> @code
- SUBROUTINE var_chg_FillValue(td_var)
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var array of variable structure
+ !> @param[in] dd_fill _FillValue to be used
+ !-------------------------------------------------------------------
+ SUBROUTINE var_chg_FillValue(td_var, dd_fill)
IMPLICIT NONE
! Argument
TYPE(TVAR), INTENT(INOUT) :: td_var
+ REAL(dp) , INTENT(IN) , OPTIONAL :: dd_fill
! local variable
TYPE(TATT) :: tl_att
+
+ INTEGER(i1) :: bl_fill
+ INTEGER(i2) :: sl_fill
+ INTEGER(i4) :: il_fill
+ REAL(sp) :: rl_fill
!----------------------------------------------------------------
- CALL logger_debug( "CHG FILL VALUE: change _FillValue in variable "//&
+ CALL logger_trace( "VAR CHG FILL VALUE: change _FillValue in variable "//&
& TRIM(td_var%c_name) )
@@ -5836,15 +6266,37 @@
CASE(NF90_BYTE)
- tl_att=att_init('_FillValue',NF90_FILL_BYTE)
+ IF( PRESENT(dd_fill) )THEN
+ bl_fill=INT(dd_fill,i1)
+ tl_att=att_init('_FillValue',bl_fill)
+ ELSE
+ tl_att=att_init('_FillValue',NF90_FILL_BYTE)
+ ENDIF
CASE(NF90_SHORT)
- tl_att=att_init('_FillValue',NF90_FILL_SHORT)
+ IF( PRESENT(dd_fill) )THEN
+ sl_fill=INT(dd_fill,i2)
+ tl_att=att_init('_FillValue',sl_fill)
+ ELSE
+ tl_att=att_init('_FillValue',NF90_FILL_SHORT)
+ ENDIF
CASE(NF90_INT)
- tl_att=att_init('_FillValue',NF90_FILL_INT)
+ IF( PRESENT(dd_fill) )THEN
+ il_fill=INT(dd_fill,i4)
+ tl_att=att_init('_FillValue',il_fill)
+ ELSE
+ tl_att=att_init('_FillValue',NF90_FILL_INT)
+ ENDIF
CASE(NF90_FLOAT)
- tl_att=att_init('_FillValue',NF90_FILL_FLOAT)
- CASE(NF90_DOUBLE)
- tl_att=att_init('_FillValue',NF90_FILL_DOUBLE)
- CASE DEFAULT
- tl_att=att_init('_FillValue',NF90_FILL_DOUBLE)
+ IF( PRESENT(dd_fill) )THEN
+ rl_fill=REAL(dd_fill,sp)
+ tl_att=att_init('_FillValue',rl_fill)
+ ELSE
+ tl_att=att_init('_FillValue',NF90_FILL_FLOAT)
+ ENDIF
+ CASE DEFAULT ! NF90_DOUBLE
+ IF( PRESENT(dd_fill) )THEN
+ tl_att=att_init('_FillValue',dd_fill)
+ ELSE
+ tl_att=att_init('_FillValue',NF90_FILL_DOUBLE)
+ ENDIF
END SELECT
@@ -5860,19 +6312,18 @@
CALL var_move_att(td_var, tl_att)
+ ! clean
+ CALL att_clean(tl_att)
+
END SUBROUTINE var_chg_FillValue
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine read variable configuration file, fill and save
- !> a global table of variable structure with extra information :tg_varextra.
+ !> This subroutine read variable configuration file. And save
+ !> global array of variable structure with extra information: tg_varextra.
!>
- !> @details
- !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_file : configuration file of variable
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_file configuration file of variable
+ !-------------------------------------------------------------------
SUBROUTINE var_def_extra( cd_file )
IMPLICIT NONE
@@ -5894,5 +6345,8 @@
!----------------------------------------------------------------
- IF( ALLOCATED(tg_varextra) ) DEALLOCATE(tg_varextra)
+ IF( ALLOCATED(tg_varextra) )THEN
+ CALL var_clean(tg_varextra(:))
+ DEALLOCATE(tg_varextra)
+ ENDIF
! read config variable file
@@ -5901,7 +6355,7 @@
! get number of variable to be read
+
il_fileid=fct_getunit()
-
- CALL logger_debug("VAR DEF EXTRA: open "//TRIM(cd_file))
+ CALL logger_trace("VAR DEF EXTRA: open "//TRIM(cd_file))
OPEN( il_fileid, FILE=TRIM(cd_file), &
& FORM='FORMATTED', &
@@ -5922,5 +6376,5 @@
! search line do not beginning with comment character
- IF( SCAN( TRIM(fct_concat(cg_com(:))) ,cl_line(1:1)) == 0 )THEN
+ IF( SCAN( TRIM(fct_concat(cp_com(:))) ,cl_line(1:1)) == 0 )THEN
il_nvar=il_nvar+1
ENDIF
@@ -5941,7 +6395,8 @@
ELSE
CALL logger_info("VAR DEF EXTRA: "//TRIM(fct_str(il_nvar))//&
- & " variable to be read on varaible config file")
-
- CALL logger_debug("VAR DEF EXTRA: rewind "//TRIM(cd_file))
+ & " variable to be read on varaible config file"//&
+ & TRIM(cd_file))
+
+ CALL logger_trace("VAR DEF EXTRA: rewind "//TRIM(cd_file))
REWIND( il_fileid, IOSTAT=il_status)
CALL fct_err(il_status)
@@ -5958,5 +6413,5 @@
DO WHILE( il_status == 0 )
- IF( SCAN( TRIM(fct_concat(cg_com(:))) ,cl_line(1:1)) == 0 )THEN
+ IF( SCAN( TRIM(fct_concat(cp_com(:))) ,cl_line(1:1)) == 0 )THEN
tg_varextra(ji)%i_id = ji
tg_varextra(ji)%c_name =TRIM(fct_split(cl_line,1))
@@ -5996,28 +6451,28 @@
END SUBROUTINE var_def_extra
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This subroutine add variable information get from namelist in
- !> global table of variable structure with extra information :tg_varextra.
+ !> global array of variable structure with extra information: tg_varextra.
!>
!> @details
- !> string character format must be : "varname:interp|filter|extrap"
+ !> string character format must be :
+ !> "varname:interp; filter; extrap; > min; < max"
!> you could specify only interpolation, filter or extrapolation method,
- !> or two whatever the order. you could find more
- !> information about available method in interpolation, filter, and
- !> extrapolation module. Here you cuold find some exemples:
- !> cn_varinfo='Bathymetry:2*hamming(2,3)'
- !> cn_varinfo='votemper:cubic|dist_weight'
- !>
- !> @note If you do not specify one method which is required, default one is
+ !> whatever the order. you could find more
+ !> information about available method in \ref interp, \ref filter, and
+ !> \ref extrap module.
+ !> Examples:
+ !> cn_varinfo='Bathymetry:2*hamming(2,3); > 10.'
+ !> cn_varinfo='votemper:cubic; dist_weight; <40.'
+ !>
+ !> @note If you do not specify a method which is required, default one is
!> apply.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_varinfo : variable information from namelist
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_varinfo variable information from namelist
+ !-------------------------------------------------------------------
SUBROUTINE var_chg_extra( cd_varinfo )
IMPLICIT NONE
@@ -6032,5 +6487,5 @@
CHARACTER(LEN=lc), DIMENSION(5) :: cl_filter
- INTEGER(i4) :: il_varid
+ INTEGER(i4) :: il_ind
INTEGER(i4) :: il_nvar
@@ -6044,91 +6499,103 @@
!----------------------------------------------------------------
- ji=1
- DO WHILE( TRIM(cd_varinfo(ji)) /= '' )
-
- cl_name =fct_lower(fct_split(cd_varinfo(ji),1,':'))
- cl_method=fct_split(cd_varinfo(ji),2,':')
-
- dl_min=var__get_min(cl_name, cl_method)
- dl_max=var__get_max(cl_name, cl_method)
- cl_interp(:)=var__get_interp(cl_name, cl_method)
- cl_extrap(:)=var__get_extrap(cl_name, cl_method)
- cl_filter(:)=var__get_filter(cl_name, cl_method)
-
- il_varid=var_get_id(tg_varextra(:), TRIM(cl_name))
- IF( il_varid /= 0 )THEN
- IF( dl_min /= dg_fill ) tg_varextra(il_varid)%d_min=dl_min
- IF( dl_max /= dg_fill ) tg_varextra(il_varid)%d_max=dl_max
- IF(cl_interp(1)/='') tg_varextra(il_varid)%c_interp(:)=cl_interp(:)
- IF(cl_extrap(1)/='') tg_varextra(il_varid)%c_extrap(:)=cl_extrap(:)
- IF(cl_filter(1)/='') tg_varextra(il_varid)%c_filter(:)=cl_filter(:)
- ELSE
-
- IF( ALLOCATED(tg_varextra) )THEN
- il_nvar=SIZE(tg_varextra(:))
- ! save older variable
- ALLOCATE( tl_varextra(il_nvar) )
- tl_varextra(:)=tg_varextra(:)
-
- DEALLOCATE(tg_varextra)
- ALLOCATE( tg_varextra(il_nvar+1) )
-
- tg_varextra(1:il_nvar)=tl_varextra(:)
- DEALLOCATE(tl_varextra)
-
+ IF( ALLOCATED(tg_varextra) )THEN
+ ji=1
+ DO WHILE( TRIM(cd_varinfo(ji)) /= '' )
+
+ cl_name =fct_lower(fct_split(cd_varinfo(ji),1,':'))
+ cl_method=fct_split(cd_varinfo(ji),2,':')
+
+ dl_min=var__get_min(cl_name, cl_method)
+ dl_max=var__get_max(cl_name, cl_method)
+ cl_interp(:)=var__get_interp(cl_name, cl_method)
+ cl_extrap(:)=var__get_extrap(cl_name, cl_method)
+ cl_filter(:)=var__get_filter(cl_name, cl_method)
+
+ il_ind=var_get_index(tg_varextra(:), TRIM(cl_name))
+ IF( il_ind /= 0 )THEN
+ IF( dl_min /= dp_fill ) tg_varextra(il_ind)%d_min=dl_min
+ IF( dl_max /= dp_fill ) tg_varextra(il_ind)%d_max=dl_max
+ IF(cl_interp(1)/='') tg_varextra(il_ind)%c_interp(:)=cl_interp(:)
+ IF(cl_extrap(1)/='') tg_varextra(il_ind)%c_extrap(:)=cl_extrap(:)
+ IF(cl_filter(1)/='') tg_varextra(il_ind)%c_filter(:)=cl_filter(:)
ELSE
- il_varid=0
- ALLOCATE( tg_varextra(1) )
+ IF( ALLOCATED(tg_varextra) )THEN
+ il_nvar=SIZE(tg_varextra(:))
+ ! save older variable
+ ALLOCATE( tl_varextra(il_nvar) )
+ tl_varextra(:)=var_copy(tg_varextra(:))
+
+ CALL var_clean(tg_varextra(:))
+ DEALLOCATE(tg_varextra)
+ ALLOCATE( tg_varextra(il_nvar+1) )
+
+ tg_varextra(1:il_nvar)=var_copy(tl_varextra(:))
+
+ ! clean
+ CALL var_clean(tl_varextra(:))
+ DEALLOCATE(tl_varextra)
+
+ ELSE
+
+ il_nvar=0
+ ALLOCATE( tg_varextra(1) )
+
+ ENDIF
+
+ ! add new variable
+ il_ind=il_nvar+1
+ tg_varextra(il_ind)=var_init( TRIM(cl_name), &
+ & cd_interp=cl_interp(:), &
+ & cd_extrap=cl_extrap(:), &
+ & cd_filter=cl_filter(:), &
+ & dd_min = dl_min, &
+ & dd_max = dl_max )
ENDIF
- ! add new variable
- il_varid=il_nvar+1
- tg_varextra(il_varid)=var_init( TRIM(cl_name), &
- & cd_interp=cl_interp(:), &
- & cd_extrap=cl_extrap(:), &
- & cd_filter=cl_filter(:), &
- & dd_min = dl_min, &
- & dd_max = dl_max )
-
- ENDIF
-
- ji=ji+1
- CALL logger_trace( "VAR CHG EXTRA: name "//&
- & TRIM(tg_varextra(il_varid)%c_name) )
- CALL logger_trace( "VAR CHG EXTRA: interp "//&
- & TRIM(tg_varextra(il_varid)%c_interp(1)) )
- CALL logger_trace( "VAR CHG EXTRA: filter "//&
- & TRIM(tg_varextra(il_varid)%c_filter(1)) )
- CALL logger_trace( "VAR CHG EXTRA: extrap "//&
- & TRIM(tg_varextra(il_varid)%c_extrap(1)) )
- IF( tg_varextra(il_varid)%d_min /= dg_fill )THEN
- CALL logger_trace( "VAR CHG EXTRA: min value "//&
- & TRIM(fct_str(tg_varextra(il_varid)%d_min)) )
- ENDIF
- IF( tg_varextra(il_varid)%d_max /= dg_fill )THEN
- CALL logger_trace( "VAR CHG EXTRA: max value "//&
- & TRIM(fct_str(tg_varextra(il_varid)%d_max)) )
- ENDIF
- ENDDO
+ ji=ji+1
+ CALL logger_trace( "VAR CHG EXTRA: name "//&
+ & TRIM(tg_varextra(il_ind)%c_name) )
+ CALL logger_trace( "VAR CHG EXTRA: interp "//&
+ & TRIM(tg_varextra(il_ind)%c_interp(1)) )
+ CALL logger_trace( "VAR CHG EXTRA: filter "//&
+ & TRIM(tg_varextra(il_ind)%c_filter(1)) )
+ CALL logger_trace( "VAR CHG EXTRA: extrap "//&
+ & TRIM(tg_varextra(il_ind)%c_extrap(1)) )
+ IF( tg_varextra(il_ind)%d_min /= dp_fill )THEN
+ CALL logger_trace( "VAR CHG EXTRA: min value "//&
+ & TRIM(fct_str(tg_varextra(il_ind)%d_min)) )
+ ENDIF
+ IF( tg_varextra(il_ind)%d_max /= dp_fill )THEN
+ CALL logger_trace( "VAR CHG EXTRA: max value "//&
+ & TRIM(fct_str(tg_varextra(il_ind)%d_max)) )
+ ENDIF
+ ENDDO
+ ENDIF
END SUBROUTINE var_chg_extra
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine read matrix value from character string
+ !> This subroutine read matrix value from character string in namelist
!> and fill variable strucutre value.
-
- !> @detail
- !>
- !
+ !>
+ !> @details
+ !> to split matrix, separator use are:
+ !> - ',' for line
+ !> - '/' for row
+ !> - '\' for level
+ !> Example:
+ !> 3,2,3/1,4,5 =>
+ !> @f$ \left( \begin{array}{ccc}
+ !> 3 & 2 & 3 \\
+ !> 1 & 4 & 5 \end{array} \right) @f$
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !> @param[in] cd_matrix : matrix value
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] cd_matrix matrix value
+ !-------------------------------------------------------------------
SUBROUTINE var_read_matrix(td_var, cd_matrix)
IMPLICIT NONE
@@ -6138,5 +6605,5 @@
! local variable
- CHARACTER(LEN=lc) :: cl_table
+ CHARACTER(LEN=lc) :: cl_array
CHARACTER(LEN=lc) :: cl_line
CHARACTER(LEN=lc) :: cl_elt
@@ -6158,13 +6625,13 @@
!1- read matrix
- ALLOCATE( dl_matrix(ig_maxmtx, ig_maxmtx, ig_maxmtx) )
+ ALLOCATE( dl_matrix(ip_maxmtx, ip_maxmtx, ip_maxmtx) )
dl_matrix(:,:,:)=td_var%d_fill
jk=1
- cl_table=fct_split(TRIM(cd_matrix),jk,'\ ')
- CALL logger_debug("VAR MATRIX table "//TRIM(cl_table) )
- DO WHILE( TRIM(cl_table) /= '' )
+ cl_array=fct_split(TRIM(cd_matrix),jk,'\ ')
+ CALL logger_debug("VAR MATRIX array "//TRIM(cl_array) )
+ DO WHILE( TRIM(cl_array) /= '' )
jj=1
- cl_line=fct_split(TRIM(cl_table),jj,'/')
+ cl_line=fct_split(TRIM(cl_array),jj,'/')
CALL logger_debug("VAR MATRIX line "//TRIM(cl_line) )
DO WHILE( TRIM(cl_line) /= '' )
@@ -6179,10 +6646,10 @@
ENDDO
jj=jj+1
- cl_line=fct_split(TRIM(cl_table),jj,'/')
+ cl_line=fct_split(TRIM(cl_array),jj,'/')
CALL logger_debug("VAR MATRIX line "//TRIM(cl_line) )
ENDDO
jk=jk+1
- cl_table=fct_split(TRIM(cd_matrix),jk,'\ ')
- CALL logger_debug("VAR MATRIX table "//TRIM(cl_table) )
+ cl_array=fct_split(TRIM(cd_matrix),jk,'\ ')
+ CALL logger_debug("VAR MATRIX array "//TRIM(cl_array) )
ENDDO
@@ -6200,9 +6667,10 @@
CALL var_add_dim(td_var, tl_dim(:))
+ ! clean
CALL dim_clean(tl_dim)
DEALLOCATE( tl_dim )
IF( ASSOCIATED(td_var%d_value) ) DEALLOCATE(td_var%d_value)
- CALL var_add_value(td_var, dl_value(:,:,:,:))
+ CALL var_add_value(td_var, dl_value(:,:,:,:), id_type=NF90_FLOAT)
DEALLOCATE( dl_value )
@@ -6210,17 +6678,17 @@
END SUBROUTINE var_read_matrix
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine add extra information in variable structure
+ !> This subroutine add extra information in variable structure.
!>
!> @details
- !>
+ !> if variable name is informed in global array of variable structure (tg_varextra).
+ !> fill empty parameter on variable structure.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !>
+ !> @param[inout] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE var__get_extra( td_var )
IMPLICIT NONE
@@ -6229,5 +6697,5 @@
! local variable
- INTEGER(i4) :: il_varid
+ INTEGER(i4) :: il_ind
TYPE(TATT) :: tl_att
@@ -6237,18 +6705,20 @@
IF( ALLOCATED(tg_varextra) )THEN
- il_varid=var_get_id( tg_varextra(:), TRIM(td_var%c_name), &
- TRIM(td_var%c_stdname))
- IF( il_varid /= 0 )THEN
+ il_ind=var_get_index( tg_varextra(:), TRIM(td_var%c_name), &
+ TRIM(td_var%c_stdname))
+ IF( il_ind /= 0 )THEN
! name
IF( TRIM(td_var%c_name) == '' .AND. &
- & TRIM(tg_varextra(il_varid)%c_name) /= '' )THEN
- td_var%c_name=TRIM(tg_varextra(il_varid)%c_name)
+ & TRIM(tg_varextra(il_ind)%c_name) /= '' )THEN
+ td_var%c_name=TRIM(tg_varextra(il_ind)%c_name)
ENDIF
! standard name
- IF( TRIM(td_var%c_stdname) == '' .AND. &
- & TRIM(tg_varextra(il_varid)%c_stdname) /= '' )THEN
- td_var%c_stdname=TRIM(tg_varextra(il_varid)%c_stdname)
+ IF( TRIM(tg_varextra(il_ind)%c_stdname) /= '' .AND. &
+ & ( TRIM(td_var%c_stdname) == '' .OR. &
+ & TRIM(tg_varextra(il_ind)%c_stdname) /= &
+ & TRIM(td_var%c_stdname) ) )THEN
+ td_var%c_stdname=TRIM(tg_varextra(il_ind)%c_stdname)
! create attibute
tl_att=att_init('standard_name',TRIM(td_var%c_stdname))
@@ -6257,9 +6727,11 @@
! long_name
- IF( TRIM(td_var%c_longname) == '' .AND. &
- & TRIM(tg_varextra(il_varid)%c_longname) /= '' )THEN
- td_var%c_longname=TRIM(tg_varextra(il_varid)%c_longname)
+ IF( TRIM(tg_varextra(il_ind)%c_longname) /= '' .AND. &
+ & ( TRIM(td_var%c_longname) == '' .OR. &
+ & TRIM(tg_varextra(il_ind)%c_longname) /= &
+ & TRIM(td_var%c_longname) ) )THEN
+ td_var%c_longname=TRIM(tg_varextra(il_ind)%c_longname)
! create attibute
- tl_att=att_init('long_name',TRIM(td_var%c_stdname))
+ tl_att=att_init('long_name',TRIM(td_var%c_longname))
CALL var_move_att(td_var, tl_att)
ENDIF
@@ -6267,6 +6739,6 @@
! units
IF( TRIM(td_var%c_units) == '' .AND. &
- & TRIM(tg_varextra(il_varid)%c_units) /= '' )THEN
- td_var%c_units=TRIM(tg_varextra(il_varid)%c_units)
+ & TRIM(tg_varextra(il_ind)%c_units) /= '' )THEN
+ td_var%c_units=TRIM(tg_varextra(il_ind)%c_units)
! create attibute
tl_att=att_init('units',TRIM(td_var%c_units))
@@ -6275,7 +6747,9 @@
! axis
- IF( TRIM(td_var%c_axis) == '' .AND. &
- & TRIM(tg_varextra(il_varid)%c_axis) /= '' )THEN
- td_var%c_axis=TRIM(tg_varextra(il_varid)%c_axis)
+ IF( TRIM(tg_varextra(il_ind)%c_axis) /= '' .AND. &
+ & ( TRIM(td_var%c_axis) == '' .OR. &
+ & TRIM(tg_varextra(il_ind)%c_axis) /= &
+ & TRIM(td_var%c_axis) ) )THEN
+ td_var%c_axis=TRIM(tg_varextra(il_ind)%c_axis)
! create attibute
tl_att=att_init('axis',TRIM(td_var%c_axis))
@@ -6284,12 +6758,16 @@
! grid point
- IF( TRIM(td_var%c_point) == '' .AND. &
- & TRIM(tg_varextra(il_varid)%c_point) /= '' )THEN
- td_var%c_point=TRIM(tg_varextra(il_varid)%c_point)
+ IF( TRIM(tg_varextra(il_ind)%c_point) /= '' .AND. &
+ & ( TRIM(td_var%c_point) == '' .OR. &
+ & TRIM(tg_varextra(il_ind)%c_point) /= &
+ & TRIM(td_var%c_point) ) )THEN
+ td_var%c_point=TRIM(tg_varextra(il_ind)%c_point)
ELSE
- CALL logger_warn("VAR GET EXTRA: unknown grid point "//&
- & "for variable "//TRIM(td_var%c_name)//&
- & ". assume it is a T-point.")
- td_var%c_point='T'
+ IF( TRIM(td_var%c_point) == '' )THEN
+ CALL logger_warn("VAR GET EXTRA: unknown grid point "//&
+ & "for variable "//TRIM(td_var%c_name)//&
+ & ". assume it is a T-point.")
+ td_var%c_point='T'
+ ENDIF
ENDIF
! create attibute
@@ -6297,32 +6775,35 @@
CALL var_move_att(td_var, tl_att)
+ ! clean
+ CALL att_clean(tl_att)
+
! interp
IF( TRIM(td_var%c_interp(1)) == '' .AND. &
- & TRIM(tg_varextra(il_varid)%c_interp(1)) /= '' )THEN
- td_var%c_interp(:)=tg_varextra(il_varid)%c_interp(:)
+ & TRIM(tg_varextra(il_ind)%c_interp(1)) /= '' )THEN
+ td_var%c_interp(:)=tg_varextra(il_ind)%c_interp(:)
ENDIF
! extrap
IF( TRIM(td_var%c_extrap(1)) == '' .AND. &
- & TRIM(tg_varextra(il_varid)%c_extrap(1)) /= '' )THEN
- td_var%c_extrap(:)=tg_varextra(il_varid)%c_extrap(:)
+ & TRIM(tg_varextra(il_ind)%c_extrap(1)) /= '' )THEN
+ td_var%c_extrap(:)=tg_varextra(il_ind)%c_extrap(:)
ENDIF
! filter
IF( TRIM(td_var%c_filter(1)) == '' .AND. &
- & TRIM(tg_varextra(il_varid)%c_filter(1)) /= '' )THEN
- td_var%c_filter(:)=tg_varextra(il_varid)%c_filter(:)
+ & TRIM(tg_varextra(il_ind)%c_filter(1)) /= '' )THEN
+ td_var%c_filter(:)=tg_varextra(il_ind)%c_filter(:)
ENDIF
! min value
- IF( td_var%d_min == dg_fill .AND. &
- & tg_varextra(il_varid)%d_min /= dg_fill )THEN
- td_var%d_min=tg_varextra(il_varid)%d_min
+ IF( td_var%d_min == dp_fill .AND. &
+ & tg_varextra(il_ind)%d_min /= dp_fill )THEN
+ td_var%d_min=tg_varextra(il_ind)%d_min
ENDIF
! max value
- IF( td_var%d_max == dg_fill .AND. &
- & tg_varextra(il_varid)%d_max /= dg_fill )THEN
- td_var%d_max=tg_varextra(il_varid)%d_max
+ IF( td_var%d_max == dp_fill .AND. &
+ & tg_varextra(il_ind)%d_max /= dp_fill )THEN
+ td_var%d_max=tg_varextra(il_ind)%d_max
ENDIF
@@ -6346,9 +6827,8 @@
END SUBROUTINE var__get_extra
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function check if variable information read in namelist contains
- !> minimum value and return it if true
+ !> minimum value and return it if true.
!>
!> @details
@@ -6356,9 +6836,10 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_varinfo : variable information read in namelist
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] cd_varinfo variable information read in namelist
+ !> @return minimum value to be used (FillValue if none)
+ !-------------------------------------------------------------------
FUNCTION var__get_min( cd_name, cd_varinfo )
IMPLICIT NONE
@@ -6381,5 +6862,5 @@
! init
cl_min=''
- var__get_min=dg_fill
+ var__get_min=dp_fill
ji=1
@@ -6398,5 +6879,5 @@
IF( fct_is_num(cl_min) )THEN
READ(cl_min,*) var__get_min
- CALL logger_info("VAR GET MIN: will use minimum value of "//&
+ CALL logger_debug("VAR GET MIN: will use minimum value of "//&
& TRIM(fct_str(var__get_min))//" for variable "//TRIM(cd_name) )
ELSE
@@ -6407,9 +6888,8 @@
END FUNCTION var__get_min
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function check if variable information read in namelist contains
- !> maximum value and return it if true
+ !> maximum value and return it if true.
!>
!> @details
@@ -6417,9 +6897,10 @@
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_varinfo : variable information read in namelist
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] cd_varinfo variable information read in namelist
+ !> @return maximum value to be used (FillValue if none)
+ !-------------------------------------------------------------------
FUNCTION var__get_max( cd_name, cd_varinfo )
IMPLICIT NONE
@@ -6442,5 +6923,5 @@
! init
cl_max=''
- var__get_max=dg_fill
+ var__get_max=dp_fill
ji=1
@@ -6459,5 +6940,5 @@
IF( fct_is_num(cl_max) )THEN
READ(cl_max,*) var__get_max
- CALL logger_info("VAR GET MAX: will use maximum value of "//&
+ CALL logger_debug("VAR GET MAX: will use maximum value of "//&
& TRIM(fct_str(var__get_max))//" for variable "//TRIM(cd_name) )
ELSE
@@ -6468,18 +6949,26 @@
END FUNCTION var__get_max
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function check if variable information read in namelist contains
- !> interpolation method and return it if true
+ !> interpolation method and return it if true.
!>
!> @details
+ !> split namelist information, using ';' as separator.
+ !> compare method name with the list of interpolation method available (see
+ !> module global).
+ !> check if factor (*rhoi, /rhoj..) are present.
+ !> Example:
+ !> - cubic/rhoi ; dist_weight
+ !> - bilin
+ !> see @ref interp module for more information.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_varinfo : variable information read in namelist
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] cd_varinfo variable information read in namelist
+ !> @return array of character information about interpolation
+ !-------------------------------------------------------------------
FUNCTION var__get_interp( cd_name, cd_varinfo )
IMPLICIT NONE
@@ -6511,10 +7000,10 @@
cl_tmp=fct_split(cd_varinfo,ji,';')
DO WHILE( TRIM(cl_tmp) /= '' )
- DO jj=1,ig_ninterp
- il_ind= INDEX(fct_lower(cl_tmp),TRIM(cg_interp_list(jj)))
+ DO jj=1,ip_ninterp
+ il_ind= INDEX(fct_lower(cl_tmp),TRIM(cp_interp_list(jj)))
IF( il_ind /= 0 )THEN
- var__get_interp(1)=TRIM(cg_interp_list(jj))
- il_len=LEN(TRIM(cg_interp_list(jj)))
+ var__get_interp(1)=TRIM(cp_interp_list(jj))
+ il_len=LEN(TRIM(cp_interp_list(jj)))
! look for factor
@@ -6563,5 +7052,5 @@
ENDIF
ENDDO
- IF( jj /= ig_ninterp + 1 ) EXIT
+ IF( jj /= ip_ninterp + 1 ) EXIT
ji=ji+1
cl_tmp=fct_split(cd_varinfo,ji,';')
@@ -6569,18 +7058,25 @@
END FUNCTION var__get_interp
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function check if variable information read in namelist contains
- !> extrapolation method and return it if true
+ !> extrapolation method and return it if true.
!>
!> @details
+ !> split namelist information, using ';' as separator.
+ !> compare method name with the list of extrapolation method available (see
+ !> module global).
+ !> Example:
+ !> - cubic ; dist_weight
+ !> - min_error
+ !> see @ref extrap module for more information.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_varinfo : variable information read in namelist
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] cd_varinfo variable information read in namelist
+ !> @return array of character information about extrapolation
+ !-------------------------------------------------------------------
FUNCTION var__get_extrap( cd_name, cd_varinfo )
IMPLICIT NONE
@@ -6605,9 +7101,9 @@
cl_tmp=fct_split(cd_varinfo,ji,';')
DO WHILE( TRIM(cl_tmp) /= '' )
- DO jj=1,ig_nextrap
- IF( TRIM(fct_lower(cl_tmp)) == TRIM(cg_extrap_list(jj)) )THEN
- var__get_extrap(1)=TRIM(cg_extrap_list(jj))
-
- CALL logger_info("VAR GET EXTRAP: variable "//TRIM(cd_name)//&
+ DO jj=1,ip_nextrap
+ IF( TRIM(fct_lower(cl_tmp)) == TRIM(cp_extrap_list(jj)) )THEN
+ var__get_extrap(1)=TRIM(cp_extrap_list(jj))
+
+ CALL logger_trace("VAR GET EXTRAP: variable "//TRIM(cd_name)//&
& " will use extrapolation method "//TRIM(var__get_extrap(1)) )
@@ -6615,5 +7111,5 @@
ENDIF
ENDDO
- IF( jj /= ig_nextrap + 1 ) EXIT
+ IF( jj /= ip_nextrap + 1 ) EXIT
ji=ji+1
cl_tmp=fct_split(cd_varinfo,ji,';')
@@ -6622,5 +7118,4 @@
END FUNCTION var__get_extrap
- !> @endcode
!-------------------------------------------------------------------
!> @brief
@@ -6629,11 +7124,20 @@
!>
!> @details
+ !> split namelist information, using ';' as separator.
+ !> compare method name with the list of filter method available (see
+ !> module global).
+ !> look for the number of turn, using '*' separator, and method parameters inside
+ !> bracket.
+ !> Example:
+ !> - cubic ; 2*hamming(2,3)
+ !> - hann
+ !> see @ref filter module for more information.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] cd_varinfo : variable information read in namelist
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] cd_name variable name
+ !> @param[in] cd_varinfo variable information read in namelist
+ !-------------------------------------------------------------------
FUNCTION var__get_filter( cd_name, cd_varinfo )
IMPLICIT NONE
@@ -6659,8 +7163,8 @@
cl_tmp=fct_split(cd_varinfo,ji,';')
DO WHILE( TRIM(cl_tmp) /= '' )
- DO jj=1,ig_nfilter
- il_ind=INDEX(fct_lower(cl_tmp),TRIM(cg_filter_list(jj)))
+ DO jj=1,ip_nfilter
+ il_ind=INDEX(fct_lower(cl_tmp),TRIM(cp_filter_list(jj)))
IF( il_ind /= 0 )THEN
- var__get_filter(1)=TRIM(cg_filter_list(jj))
+ var__get_filter(1)=TRIM(cp_filter_list(jj))
! look for number of turn
@@ -6711,5 +7215,5 @@
ENDIF
ENDDO
- IF( jj /= ig_nfilter + 1 ) EXIT
+ IF( jj /= ip_nfilter + 1 ) EXIT
ji=ji+1
cl_tmp=fct_split(cd_varinfo,ji,';')
@@ -6717,18 +7221,15 @@
END FUNCTION var__get_filter
- !> @endcode
!-------------------------------------------------------------------
!> @brief
!> This function search and save the biggest dimensions use
- !> in those variables.
- !>
- !
+ !> in an array of variable structure.
+ !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in] td_var : table of variable structure
- !> @return table of dimension
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[in] td_var array of variable structure
+ !> @return array of dimension
+ !-------------------------------------------------------------------
FUNCTION var_max_dim(td_var)
IMPLICIT NONE
@@ -6749,44 +7250,43 @@
il_nvar=SIZE(td_var(:))
- var_max_dim(:)=td_var(1)%t_dim(:)
-
- DO ji=2,il_nvar
-
- IF( td_var(ji)%t_dim(1)%l_use .AND. &
- & td_var(ji)%t_dim(1)%i_len >= var_max_dim(1)%i_len )THEN
- var_max_dim(1)=td_var(ji)%t_dim(1)
- ENDIF
-
- IF( td_var(ji)%t_dim(2)%l_use .AND. &
- & td_var(ji)%t_dim(2)%i_len >= var_max_dim(2)%i_len )THEN
- var_max_dim(2)=td_var(ji)%t_dim(2)
- ENDIF
-
- IF( td_var(ji)%t_dim(3)%l_use .AND. &
- & td_var(ji)%t_dim(3)%i_len >= var_max_dim(3)%i_len )THEN
- var_max_dim(3)=td_var(ji)%t_dim(3)
- ENDIF
-
- IF( td_var(ji)%t_dim(4)%l_use .AND. &
- & td_var(ji)%t_dim(4)%i_len >= var_max_dim(4)%i_len )THEN
- var_max_dim(4)=td_var(ji)%t_dim(4)
- ENDIF
-
- ENDDO
+ var_max_dim(:)=dim_copy(td_var(1)%t_dim(:))
+
+ IF( il_nvar > 1 )THEN
+ DO ji=2,il_nvar
+
+ IF( td_var(ji)%t_dim(1)%l_use .AND. &
+ & td_var(ji)%t_dim(1)%i_len >= var_max_dim(1)%i_len )THEN
+ var_max_dim(1)=dim_copy(td_var(ji)%t_dim(1))
+ ENDIF
+
+ IF( td_var(ji)%t_dim(2)%l_use .AND. &
+ & td_var(ji)%t_dim(2)%i_len >= var_max_dim(2)%i_len )THEN
+ var_max_dim(2)=dim_copy(td_var(ji)%t_dim(2))
+ ENDIF
+
+ IF( td_var(ji)%t_dim(3)%l_use .AND. &
+ & td_var(ji)%t_dim(3)%i_len >= var_max_dim(3)%i_len )THEN
+ var_max_dim(3)=dim_copy(td_var(ji)%t_dim(3))
+ ENDIF
+
+ IF( td_var(ji)%t_dim(4)%l_use .AND. &
+ & td_var(ji)%t_dim(4)%i_len >= var_max_dim(4)%i_len )THEN
+ var_max_dim(4)=dim_copy(td_var(ji)%t_dim(4))
+ ENDIF
+
+ ENDDO
+ ENDIF
END FUNCTION var_max_dim
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine forced minimum and maximum value of variable.
+ !> This subroutine forced minimum and maximum value of variable,
+ !> with value of variable structure attribute d_min and d_max.
!>
- !> @details
- !>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE var_limit_value( td_var )
IMPLICIT NONE
@@ -6801,5 +7301,5 @@
IF( ASSOCIATED(td_var%d_value) )THEN
!1- forced minimum value
- IF( td_var%d_min /= dg_fill )THEN
+ IF( td_var%d_min /= dp_fill )THEN
WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill .AND. &
& td_var%d_value(:,:,:,:) < td_var%d_min )
@@ -6809,5 +7309,5 @@
!2- forced maximum value
- IF( td_var%d_max /= dg_fill )THEN
+ IF( td_var%d_max /= dp_fill )THEN
WHERE( td_var%d_value(:,:,:,:) /= td_var%d_fill .AND. &
& td_var%d_value(:,:,:,:) > td_var%d_max )
@@ -6819,17 +7319,18 @@
END SUBROUTINE var_limit_value
- !> @endcode
!-------------------------------------------------------------------
!> @brief
- !> This subroutine forced minimum and maximum value of variable.
+ !> This subroutine check variable dimension expected, as defined in
+ !> file 'variable.cfg'.
!>
!> @details
+ !> compare dimension used in variable structure with string character
+ !> axis from configuration file.
!>
!> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[inout] td_var : variable structure
- !-------------------------------------------------------------------
- !> @code
+ !> - November, 2013- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !-------------------------------------------------------------------
SUBROUTINE var_check_dim( td_var )
IMPLICIT NONE
@@ -6879,13 +7380,17 @@
CALL logger_warn("VAR CHECK DIM: too much dimension for "//&
& "variable "//TRIM(td_var%c_name)//".")
+ cl_dim=TRIM(fct_upper(cp_dimorder))
+ il_ndim =LEN( TRIM(ADJUSTL(cl_dim)) )
DO ji=1,il_ndim
IF( INDEX(TRIM(td_var%c_axis),cl_dim(ji:ji)) == 0 )THEN
- IF( td_var%t_dim(ji)%i_len == 1 )THEN
- ! remove unuseful dimension
- CALL var_del_dim(td_var,td_var%t_dim(ji))
- ELSE
- CALL logger_warn("VAR CHECK DIM: variable "//&
- & TRIM(td_var%c_name)//" should not use"//&
- & " dimension "//TRIM(td_var%t_dim(ji)%c_name))
+ IF( td_var%t_dim(ji)%l_use )THEN
+ IF( td_var%t_dim(ji)%i_len == 1 )THEN
+ ! remove unuseful dimension
+ CALL var_del_dim(td_var,td_var%t_dim(ji))
+ ELSE
+ CALL logger_warn("VAR CHECK DIM: variable "//&
+ & TRIM(td_var%c_name)//" should not use"//&
+ & " dimension "//TRIM(td_var%t_dim(ji)%c_name))
+ ENDIF
ENDIF
ENDIF
@@ -6898,5 +7403,154 @@
END SUBROUTINE var_check_dim
- !> @endcode
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This subroutine reshape variable value and dimension
+ !> in variable structure.
+ !> @details
+ !> output dimension will be ordered as defined in
+ !> input array of dimension
+ !> Optionaly you could specify output dimension order with
+ !> string character of dimension
+ !>
+ !> @author J.Paul
+ !> - August, 2014- Initial Version
+ !
+ !> @param[inout] td_var variable structure
+ !> @param[in] cd_dimorder string character of dimension order to be used
+ !-------------------------------------------------------------------
+ SUBROUTINE var_reorder( td_var, cd_dimorder )
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR) , INTENT(INOUT) :: td_var
+ CHARACTER(LEN=ip_maxdim), INTENT(IN ), OPTIONAL :: cd_dimorder
+
+ ! local variable
+ CHARACTER(LEN=lc) :: cl_dimorder
+
+ REAL(dp) , DIMENSION(:,:,:,:) , ALLOCATABLE :: dl_value
+
+ TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim
+
+ ! loop indices
+ !----------------------------------------------------------------
+
+ cl_dimorder=TRIM(cp_dimorder)
+ IF( PRESENT(cd_dimorder) ) cl_dimorder=TRIM(ADJUSTL(cd_dimorder))
+
+ tl_dim(:)=dim_copy(td_var%t_dim(:))
+
+ CALL dim_unorder(tl_dim(:))
+ CALL dim_reorder(tl_dim(:),TRIM(cl_dimorder))
+
+ ALLOCATE(dl_value(tl_dim(1)%i_len, &
+ & tl_dim(2)%i_len, &
+ & tl_dim(3)%i_len, &
+ & tl_dim(4)%i_len ))
+
+ dl_value(:,:,:,:)=dim_reshape_2xyzt(tl_dim, &
+ & td_var%d_value(:,:,:,:))
+
+ ! change dimension
+ td_var%t_dim(:)=dim_copy(tl_dim(:))
+ ! change value
+ DEALLOCATE( td_var%d_value )
+ CALL var_add_value(td_var, dl_value(:,:,:,:))
+
+ ! clean
+ DEALLOCATE(dl_value)
+ CALL dim_clean(tl_dim(:))
+
+ END SUBROUTINE var_reorder
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This function get the next unused unit in array of variable structure.
+ !>
+ !> @author J.Paul
+ !> - September, 2014- Initial Version
+ !
+ !> @param[in] td_var array of variable structure
+ !> @return free variable id
+ !-------------------------------------------------------------------
+ FUNCTION var_get_unit(td_var)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_var
+
+ ! function
+ INTEGER(i4) :: var_get_unit
+
+ ! local variable
+ ! loop indices
+ !----------------------------------------------------------------
+
+ var_get_unit=MAXVAL(td_var(:)%i_id)+1
+
+ END FUNCTION var_get_unit
+ !-------------------------------------------------------------------
+ !> @brief
+ !> This function convert a time variable structure in date structure.
+ !>
+ !> @author J.Paul
+ !> - November, 2014- Initial Version
+ !
+ !> @param[in] td_var time variable structure
+ !> @return date structure
+ !-------------------------------------------------------------------
+ FUNCTION var_to_date(td_var)
+ IMPLICIT NONE
+ ! Argument
+ TYPE(TVAR), INTENT(IN) :: td_var
+
+ ! function
+ TYPE(TDATE) :: var_to_date
+
+ ! local variable
+ CHARACTER(LEN=lc) :: cl_step
+ CHARACTER(LEN=lc) :: cl_date
+
+ INTEGER(i4) :: il_attid
+
+ INTEGER(i8) :: kl_nsec
+
+ TYPE(TDATE) :: tl_dateo
+ ! loop indices
+ !----------------------------------------------------------------
+
+ IF( INDEX(TRIM(td_var%c_name),'time') /= 0 )THEN
+ IF( ASSOCIATED(td_var%d_value) )THEN
+
+ il_attid=att_get_index(td_var%t_att(:),'units')
+ IF( il_attid /=0 )THEN
+ cl_step=fct_split(td_var%t_att(il_attid)%c_value,1,'since')
+ cl_date=fct_split(td_var%t_att(il_attid)%c_value,2,'since')
+
+ SELECT CASE(TRIM(cl_step))
+ CASE('seconds')
+ kl_nsec=INT(td_var%d_value(1,1,1,1),i8)
+ CASE('days')
+ kl_nsec=INT(td_var%d_value(1,1,1,1)*86400,i8)
+ CASE DEFAULT
+ CALL logger_error("VAR TO DATE: unknown units format "//&
+ & "in variable "//TRIM(td_var%c_name))
+ END SELECT
+
+ tl_dateo=date_init(cl_date)
+
+ var_to_date=date_init(kl_nsec,tl_dateo)
+
+ ELSE
+ CALL logger_error("VAR TO DATE: no attribute units in "//&
+ & "variable "//TRIM(td_var%c_name))
+ ENDIF
+ ELSE
+ CALL logger_error("VAR TO DATE: no value associated to "//&
+ & "variable "//TRIM(td_var%c_name))
+ ENDIF
+ ELSE
+ CALL logger_error("VAR TO DATE: variable "//TRIM(td_var%c_name)//&
+ & "can not be convert in date.")
+ ENDIF
+
+ END FUNCTION var_to_date
END MODULE var
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/vgrid.f90
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/vgrid.f90 (revision 5213)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/src/vgrid.f90 (revision 5214)
@@ -6,32 +6,87 @@
!
! DESCRIPTION:
-!> @brief vertical grid manager
+!> @brief This module manage vertical grid.
!>
!> @details
+!> to set the depth of model levels and the resulting vertical scale
+!> factors:
+!> @code
+!> CALL vgrid_zgr_z(dd_gdepw(:), dd_gdept(:), dd_e3w(:), dd_e3t(:),
+!> dd_ppkth, dd_ppkth2, dd_ppacr, dd_ppacr2,
+!> dd_ppdzmin, dd_pphmax, dd_pp_to_be_computed,
+!> dd_ppa0, dd_ppa1, dd_ppa2, dd_ppsur)
+!> @endcode
+!> - dd_gdepw is array of depth value on W point
+!> - dd_gdept is array of depth value on T point
+!> - dd_e3w is array of vertical mesh size on W point
+!> - dd_e3t is array of vertical mesh size on T point
+!> - dd_ppkth see NEMO documentation
+!> - dd_ppkth2 see NEMO documentation
+!> - dd_ppacr see NEMO documentation
+!> - dd_ppdzmin see NEMO documentation
+!> - dd_pphmax see NEMO documentation
+!> - dd_pp_to_be_computed see NEMO documentation
+!> - dd_ppa1 see NEMO documentation
+!> - dd_ppa2 see NEMO documentation
+!> - dd_ppa0 see NEMO documentation
+!> - dd_ppsur see NEMO documentation
+!>
!>
+!> to set the depth and vertical scale factor in partial step z-coordinate
+!> case:
+!> @code
+!> CALL vgrid_zgr_zps(id_mbathy(:,:), dd_bathy(:,:), id_jpkmax, dd_gdepw(:),
+!> dd_e3t(:), dd_e3zps_min, dd_e3zps_rat)
+!> @endcode
+!> - id_mbathy is array of bathymetry level
+!> - dd_bathy is array of bathymetry
+!> - id_jpkmax is the maximum number of level to be used
+!> - dd_gdepw is array of vertical mesh size on W point
+!> - dd_e3t is array of vertical mesh size on T point
+!> - dd_e3zps_min see NEMO documentation
+!> - dd_e3zps_rat see NEMO documentation
+!>
+!> to check the bathymetry in levels:
+!> @code
+!> CALL vgrid_zgr_bat_ctl(id_mbathy, id_jpkmax, id_jpk)
+!> @endcode
+!> - id_mbathy is array of bathymetry level
+!> - id_jpkmax is the maximum number of level to be used
+!> - id_jpk is the number of level
+!>
+!> to compute bathy level in T,U,V,F point from Bathymetry file:
+!> @code
+!> tl_level(:)=vgrid_get_level(td_bathy, [cd_namelist,] [td_dom,] [id_nlevel])
+!> @endcode
+!> - td_bathy is Bathymetry file structure
+!> - cd_namelist is namelist [optional]
+!> - td_dom is domain structure [optional]
+!> - id_nlevel is number of lelvel to be used [optional]
+!>
!> @author
!> J.Paul
! REVISION HISTORY:
-!> @date Nov, 2013 - Initial Version
-!
+!> @date November, 2013 - Initial Version
+!> @date Spetember, 2014
+!> - add header
+!>
!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-!> @todo
!----------------------------------------------------------------------
MODULE vgrid
- USE netcdf
+ USE netcdf ! nf90 library
USE kind ! F90 kind parameter
USE fct ! basic usefull function
USE global ! global parameter
USE phycst ! physical constant
- USE logger ! log file manager
+ USE logger ! log file manager
USE file ! file manager
USE var ! variable manager
USE dim ! dimension manager
USE dom ! domain manager
+ USE grid ! grid manager
USE iom ! I/O manager
USE mpp ! MPP manager
USE iom_mpp ! I/O MPP manager
IMPLICIT NONE
- PRIVATE
! NOTE_avoid_public_variables_if_possible
@@ -43,7 +98,4 @@
PUBLIC :: vgrid_zgr_bat_ctl
PUBLIC :: vgrid_get_level
-
-! PRIVATE ::
-
CONTAINS
@@ -86,5 +138,4 @@
!> @param[in] dd_ppsur
!-------------------------------------------------------------------
- !> @code
SUBROUTINE vgrid_zgr_z( dd_gdepw, dd_gdept, dd_e3w, dd_e3t, &
& dd_ppkth, dd_ppkth2, dd_ppacr, dd_ppacr2, &
@@ -218,5 +269,4 @@
END SUBROUTINE vgrid_zgr_z
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine set the depth and vertical scale factor in partial step
@@ -231,21 +281,22 @@
!> function the derivative of which gives the reference vertical
!> scale factors.
- !> From depth and scale factors reference, we compute there new value
+ !> From depth and scale factors reference, we compute there new value
!> with partial steps on 3d arrays ( i, j, k ).
!>
- !> w-level: gdepw_ps(i,j,k) = fsdep(k)
- !> e3w_ps(i,j,k) = dk(fsdep)(k) = fse3(i,j,k)
- !> t-level: gdept_ps(i,j,k) = fsdep(k+0.5)
- !> e3t_ps(i,j,k) = dk(fsdep)(k+0.5) = fse3(i,j,k+0.5)
- !>
- !> With the help of the bathymetric file ( bathymetry_depth_ORCA_R2.nc),
+ !> w-level:
+ !> - gdepw_ps(i,j,k) = fsdep(k)
+ !> - e3w_ps(i,j,k) = dk(fsdep)(k) = fse3(i,j,k)
+ !> t-level:
+ !> - gdept_ps(i,j,k) = fsdep(k+0.5)
+ !> - e3t_ps(i,j,k) = dk(fsdep)(k+0.5) = fse3(i,j,k+0.5)
+ !>
+ !> With the help of the bathymetric file ( bathymetry_depth_ORCA_R2.nc),
!> we find the mbathy index of the depth at each grid point.
!> This leads us to three cases:
- !>
- !> - bathy = 0 => mbathy = 0
- !> - 1 < mbathy < jpkm1
- !> - bathy > gdepw(jpk) => mbathy = jpkm1
- !>
- !> Then, for each case, we find the new depth at t- and w- levels
+ !> - bathy = 0 => mbathy = 0
+ !> - 1 < mbathy < jpkm1
+ !> - bathy > gdepw(jpk) => mbathy = jpkm1
+ !>
+ !> Then, for each case, we find the new depth at t- and w- levels
!> and the new vertical scale factors at t-, u-, v-, w-, uw-, vw-
!> and f-points.
@@ -257,6 +308,7 @@
!> schemes.
!>
- !> c a u t i o n : gdept, gdepw and e3 are positives
- !> - - - - - - - gdept_ps, gdepw_ps and e3_ps are positives
+ !> @warning
+ !> - gdept, gdepw and e3 are positives
+ !> - gdept_ps, gdepw_ps and e3_ps are positives
!
!> @author A. Bozec, G. Madec
@@ -274,5 +326,4 @@
!> @param[in] dd_e3zps_rat
!-------------------------------------------------------------------
- !> @code
SUBROUTINE vgrid_zgr_zps( id_mbathy, dd_bathy, id_jpkmax, &
& dd_gdepw, dd_e3t, &
@@ -362,5 +413,4 @@
END SUBROUTINE vgrid_zgr_zps
- !> @endcode
!-------------------------------------------------------------------
!> @brief This subroutine check the bathymetry in levels
@@ -386,7 +436,8 @@
!> - 03-08 Original code
!
- !> @param[in]
+ !> @param[in] id_mbathy
+ !> @param[in] id_jpkmax
+ !> @param[in] id_jpk
!-------------------------------------------------------------------
- !> @code
SUBROUTINE vgrid_zgr_bat_ctl( id_mbathy, id_jpkmax, id_jpk)
IMPLICIT NONE
@@ -477,38 +528,39 @@
END SUBROUTINE vgrid_zgr_bat_ctl
- !> @endcode
!-------------------------------------------------------------------
- !> @brief This function
+ !> @brief This function compute bathy level in T,U,V,F point, and return
+ !> them as array of variable structure
!
!> @details
+ !> Bathymetry is read on Bathymetry file, then bathy level is computed
+ !> on T point, and finally fit to U,V,F point.
+ !>
+ !> you could specify :
+ !> - namelist where find parameter to set the depth of model levels
+ !> (default use GLORYS 75 levels parameters)
+ !> - domain structure to specify on e area to work on
+ !> - number of level to be used
+ !>
+ !> @author J.Paul
+ !> - November, 2013- Initial Version
!
- !> @author J.Paul
- !> - Nov, 2013- Initial Version
- !
- !> @param[in]
+ !> @param[in] td_bathy Bathymetry file structure
+ !> @param[in] cd_namelist namelist
+ !> @param[in] td_dom domain structure
+ !> @param[in] id_nlevel number of lelvel to be used
+ !> @return array of level on T,U,V,F point (variable structure)
!-------------------------------------------------------------------
- !> @code
FUNCTION vgrid_get_level(td_bathy, cd_namelist, td_dom, id_nlevel)
IMPLICIT NONE
! Argument
- TYPE(TFILE) , INTENT(IN) :: td_bathy
- CHARACTER(LEN=*), INTENT(IN) :: cd_namelist
+ TYPE(TMPP) , INTENT(IN) :: td_bathy
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_namelist
TYPE(TDOM) , INTENT(IN), OPTIONAL :: td_dom
INTEGER(i4) , INTENT(IN), OPTIONAL :: id_nlevel
! function
- TYPE(TVAR), DIMENSION(ig_npoint) :: vgrid_get_level
+ TYPE(TVAR), DIMENSION(ip_npoint) :: vgrid_get_level
! local variable
- TYPE(TFILE) :: tl_bathy
- TYPE(TMPP) :: tl_mppbathy
-
- TYPE(TDOM) :: tl_dom
-
- TYPE(TVAR) :: tl_var
- TYPE(TVAR) , DIMENSION(ig_npoint) :: tl_level
-
- TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
-
REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_gdepw
REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_gdept
@@ -519,8 +571,17 @@
INTEGER(i4) :: il_fileid
INTEGER(i4) :: il_jpkmax
+ INTEGER(i4), DIMENSION(2,2) :: il_xghost
INTEGER(i4), DIMENSION(:,:) , ALLOCATABLE :: il_mbathy
INTEGER(i4), DIMENSION(:,:,:,:), ALLOCATABLE :: il_level
LOGICAL :: ll_exist
+
+ TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
+
+ TYPE(TDOM) :: tl_dom
+
+ TYPE(TVAR) :: tl_var
+
+ TYPE(TMPP) :: tl_bathy
! loop indices
@@ -567,62 +628,60 @@
!----------------------------------------------------------------
- !1- read namelist
- INQUIRE(FILE=TRIM(cd_namelist), EXIST=ll_exist)
- IF( ll_exist )THEN
+ IF( PRESENT(cd_namelist) )THEN
+ !1- read namelist
+ INQUIRE(FILE=TRIM(cd_namelist), EXIST=ll_exist)
+ IF( ll_exist )THEN
- il_fileid=fct_getunit()
-
- OPEN( il_fileid, FILE=TRIM(cd_namelist), &
- & FORM='FORMATTED', &
- & ACCESS='SEQUENTIAL', &
- & STATUS='OLD', &
- & ACTION='READ', &
- & IOSTAT=il_status)
- CALL fct_err(il_status)
- IF( il_status /= 0 )THEN
- CALL logger_fatal("VGRID GET LEVEL: ERROR opening "//TRIM(cd_namelist))
+ il_fileid=fct_getunit()
+
+ OPEN( il_fileid, FILE=TRIM(cd_namelist), &
+ & FORM='FORMATTED', &
+ & ACCESS='SEQUENTIAL', &
+ & STATUS='OLD', &
+ & ACTION='READ', &
+ & IOSTAT=il_status)
+ CALL fct_err(il_status)
+ IF( il_status /= 0 )THEN
+ CALL logger_fatal("VGRID GET LEVEL: ERROR opening "//&
+ & TRIM(cd_namelist))
+ ENDIF
+
+ READ( il_fileid, NML = namzgr )
+ READ( il_fileid, NML = namzps )
+
+ CLOSE( il_fileid, IOSTAT=il_status )
+ CALL fct_err(il_status)
+ IF( il_status /= 0 )THEN
+ CALL logger_error("VGRID GET LEVELL: ERROR closing "//&
+ & TRIM(cd_namelist))
+ ENDIF
+
+ ELSE
+
+ CALL logger_fatal("VGRID GET LEVEL: ERROR. can not find "//&
+ & TRIM(cd_namelist))
+
ENDIF
-
- READ( il_fileid, NML = namzgr )
- READ( il_fileid, NML = namzps )
-
- CLOSE( il_fileid, IOSTAT=il_status )
- CALL fct_err(il_status)
- IF( il_status /= 0 )THEN
- CALL logger_error("VGRID GET LEVELL: ERROR closing "//TRIM(cd_namelist))
- ENDIF
-
+ ENDIF
+
+ ! copy structure
+ tl_bathy=mpp_copy(td_bathy)
+
+ ! get domain
+ IF( PRESENT(td_dom) )THEN
+ tl_dom=dom_copy(td_dom)
ELSE
-
- CALL logger_fatal("VGRID GET LEVEL: ERROR. can not find "//TRIM(cd_namelist))
-
- ENDIF
-
- !2- open files
- tl_bathy=td_bathy
- !2-1 get domain
- IF( PRESENT(td_dom) )THEN
- tl_dom=td_dom
- ELSE
- CALL iom_open(tl_bathy)
-
CALL logger_debug("VGRID GET LEVEL: get dom from "//&
& TRIM(tl_bathy%c_name))
tl_dom=dom_init(tl_bathy)
-
- CALL iom_close(tl_bathy)
ENDIF
- !2-2 open mpp
- tl_mppbathy=mpp_init(tl_bathy)
- CALL file_clean(tl_bathy)
-
- !2-3 get processor to be used
- CALL mpp_get_use( tl_mppbathy, tl_dom )
-
- !2-4 open mpp files
- CALL iom_mpp_open(tl_mppbathy)
-
- !3- check namelist
+ ! get ghoste cell
+ il_xghost(:,:)=grid_get_ghost(tl_bathy)
+
+ ! open mpp files
+ CALL iom_dom_open(tl_bathy, tl_dom)
+
+ ! check namelist
IF( PRESENT(id_nlevel) ) in_nlevel=id_nlevel
IF( in_nlevel == 0 )THEN
@@ -631,16 +690,22 @@
ENDIF
- !4- read bathymetry
- tl_var=iom_mpp_read_var(tl_mppbathy,'bathymetry',td_dom=tl_dom)
-
+ ! read bathymetry
+ tl_var=iom_dom_read_var(tl_bathy,'bathymetry',tl_dom)
+ ! clean
+ CALL dom_clean(tl_dom)
+
+ ! remove ghost cell
+ CALL grid_del_ghost(tl_var, il_xghost(:,:))
+
+ ! force _FillValue (land) to be 0
WHERE( tl_var%d_value(:,:,1,1) == tl_var%d_fill )
tl_var%d_value(:,:,1,1)=0
END WHERE
- !5 clean
- CALL iom_mpp_close(tl_mppbathy)
- CALL mpp_clean(tl_mppbathy)
-
- !5- compute vertical grid
+ ! clean
+ CALL iom_dom_close(tl_bathy)
+ CALL mpp_clean(tl_bathy)
+
+ ! compute vertical grid
ALLOCATE( dl_gdepw(in_nlevel), dl_gdept(in_nlevel) )
ALLOCATE( dl_e3w(in_nlevel), dl_e3t(in_nlevel) )
@@ -650,5 +715,5 @@
& dn_ppa0, dn_ppa1, dn_ppa2, dn_ppsur )
- !6- compute bathy level on T point
+ ! compute bathy level on T point
ALLOCATE( il_mbathy(tl_var%t_dim(1)%i_len, &
& tl_var%t_dim(2)%i_len ) )
@@ -660,8 +725,8 @@
DEALLOCATE( dl_e3w, dl_e3t )
- !7- compute bathy level in T,U,V,F point
+ ! compute bathy level in T,U,V,F point
ALLOCATE( il_level(tl_var%t_dim(1)%i_len, &
& tl_var%t_dim(2)%i_len, &
- & ig_npoint,1) )
+ & ip_npoint,1) )
DO jj=1,tl_var%t_dim(2)%i_len
@@ -686,5 +751,6 @@
DEALLOCATE( il_mbathy )
- tl_dim(:)=tl_var%t_dim(:)
+ tl_dim(:)=dim_copy(tl_var%t_dim(:))
+ ! clean
CALL var_clean(tl_var)
@@ -692,61 +758,24 @@
tl_dim(3:4)%l_use=.FALSE.
- tl_level(jp_T)=var_init('tlevel',il_level(:,:,jp_T:jp_T,:),td_dim=tl_dim(:))
- tl_level(jp_U)=var_init('ulevel',il_level(:,:,jp_U:jp_U,:),td_dim=tl_dim(:))
- tl_level(jp_V)=var_init('vlevel',il_level(:,:,jp_V:jp_V,:),td_dim=tl_dim(:))
- tl_level(jp_F)=var_init('flevel',il_level(:,:,jp_F:jp_F,:),td_dim=tl_dim(:))
+ vgrid_get_level(jp_T)=var_init( 'tlevel', il_level(:,:,jp_T:jp_T,:), &
+ & td_dim=tl_dim(:) )
+ vgrid_get_level(jp_U)=var_init( 'ulevel', il_level(:,:,jp_U:jp_U,:), &
+ & td_dim=tl_dim(:))
+ vgrid_get_level(jp_V)=var_init( 'vlevel', il_level(:,:,jp_V:jp_V,:), &
+ & td_dim=tl_dim(:))
+ vgrid_get_level(jp_F)=var_init( 'flevel', il_level(:,:,jp_F:jp_F,:), &
+ & td_dim=tl_dim(:))
DEALLOCATE( il_level )
- ! save result
- vgrid_get_level(:)=tl_level(:)
-
- DO ji=1,ig_npoint
- CALL var_clean(tl_level(ji))
- ENDDO
+ CALL grid_add_ghost( vgrid_get_level(jp_T), il_xghost(:,:) )
+ CALL grid_add_ghost( vgrid_get_level(jp_U), il_xghost(:,:) )
+ CALL grid_add_ghost( vgrid_get_level(jp_V), il_xghost(:,:) )
+ CALL grid_add_ghost( vgrid_get_level(jp_F), il_xghost(:,:) )
+
+ ! clean
+ CALL dim_clean(tl_dim(:))
END FUNCTION vgrid_get_level
- !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This function
-! !
-! !> @details
-! !
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !-------------------------------------------------------------------
-! !> @code
-! FUNCTION vgrid_()
-! IMPLICIT NONE
-! ! Argument
-! ! function
-! ! local variable
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END FUNCTION vgrid_
-! !> @endcode
-! !-------------------------------------------------------------------
-! !> @brief This subroutine
-! !
-! !> @details
-! !
-! !> @author J.Paul
-! !> - Nov, 2013- Initial Version
-! !
-! !> @param[in]
-! !-------------------------------------------------------------------
-! !> @code
-! SUBROUTINE vgrid_()
-! IMPLICIT NONE
-! ! Argument
-! ! local variable
-! ! loop indices
-! !----------------------------------------------------------------
-!
-! END SUBROUTINE vgrid_
-! !> @endcode
END MODULE vgrid
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_bathy.nam
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_bathy.nam (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_bathy.nam (revision 5214)
@@ -0,0 +1,32 @@
+&namlog
+ cn_logfile="bathy_out.log"
+ cn_verbosity=
+ in_maxerror=
+/
+
+&namcfg
+ cn_varcfg="./cfg/variable.cfg"
+/
+
+&namcrs
+ cn_coord0=
+ in_perio0=
+/
+
+&namfin
+ cn_coord1=
+/
+
+&namvar
+ cn_varinfo=
+ cn_varfile=
+/
+
+&namnst
+ in_rhoi=
+ in_rhoj=
+/
+
+&namout
+ cn_fileout="bathy_out.nc"
+/
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_boundary.nam
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_boundary.nam (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_boundary.nam (revision 5214)
@@ -0,0 +1,67 @@
+&namlog
+ cn_logfile="boundary.log"
+ cn_verbosity=
+ in_maxerror =
+/
+
+&namcfg
+ cn_varcfg="./cfg/variable.cfg"
+/
+
+&namcrs
+ cn_coord0=
+ in_perio0=
+/
+
+&namfin
+ cn_coord1=
+ cn_bathy1=
+ in_perio1=
+/
+
+&namzgr
+ dn_pp_to_be_computed=
+ dn_ppsur =
+ dn_ppa0 =
+ dn_ppa1 =
+ dn_ppa2 =
+ dn_ppkth =
+ dn_ppkth2 =
+ dn_ppacr =
+ dn_ppacr2 =
+ dn_ppdzmin =
+ dn_pphmax =
+ in_nlevel =
+/
+
+&namzps
+ dn_e3zps_min =
+ dn_e3zps_rat =
+/
+
+&namvar
+ cn_varinfo=
+ cn_varfile=
+/
+
+&namnst
+ in_rhoi=
+ in_rhoj=
+/
+
+&nambdy
+ ln_north =
+ ln_south =
+ ln_east =
+ ln_west =
+ cn_north =
+ cn_south =
+ cn_east =
+ cn_west =
+ ln_oneseg=
+ in_extrap=
+/
+
+&namout
+ cn_fileout="boundary_out.nc"
+/
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_coord.nam
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_coord.nam (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_coord.nam (revision 5214)
@@ -0,0 +1,33 @@
+&namlog
+ cn_logfile="coord_out.log"
+ cn_verbosity=
+ in_maxerror=
+/
+
+&namcfg
+ cn_varcfg="./cfg/variable.cfg"
+/
+
+&namcrs
+ cn_coord0=
+ in_perio0=
+/
+
+&namvar
+ cn_varinfo=
+/
+
+&namnst
+ in_imin0=
+ in_imax0=
+ in_jmin0=
+ in_jmax0=
+
+ in_rhoi=
+ in_rhoj=
+/
+
+&namout
+ cn_fileout="coord_out.nc"
+/
+
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_restart.nam
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_restart.nam (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/create_restart.nam (revision 5214)
@@ -0,0 +1,55 @@
+&namlog
+ cn_logfile="restart_out.log"
+ cn_verbosity=
+ in_maxerror =
+/
+
+&namcfg
+ cn_varcfg="./cfg/variable.cfg"
+/
+
+&namcrs
+ cn_coord0=
+ in_perio0=
+/
+
+&namzgr
+ dn_pp_to_be_computed=
+ dn_ppsur =
+ dn_ppa0 =
+ dn_ppa1 =
+ dn_ppa2 =
+ dn_ppkth =
+ dn_ppkth2 =
+ dn_ppacr =
+ dn_ppacr2 =
+ dn_ppdzmin =
+ dn_pphmax =
+ in_nlevel =
+/
+
+&namzps
+ dn_e3zps_min =
+ dn_e3zps_rat =
+/
+
+&namfin
+ cn_coord1=
+ cn_bathy1=
+ in_perio1=
+ in_extrap=
+/
+
+&namvar
+ cn_varinfo=
+ cn_varfile=
+/
+
+&namnst
+ in_rhoi=
+ in_rhoj=
+/
+
+&namout
+ cn_fileout="restart_out.nc"
+/
Index: /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/merge_bathy.nam
===================================================================
--- /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/merge_bathy.nam (revision 5214)
+++ /branches/2014/dev_r4650_UKMO11_restart_functionality/NEMOGCM/TOOLS/SIREN/templates/merge_bathy.nam (revision 5214)
@@ -0,0 +1,44 @@
+&namlog
+ cn_logfile="merge_out.log"
+ cn_verbosity=
+ in_maxerror =
+/
+
+&namcfg
+ cn_varcfg="./cfg/variable.cfg"
+/
+
+&namcrs
+ cn_bathy0=
+ in_perio0=
+/
+
+&namfin
+ cn_bathy1=
+ in_perio1=
+/
+
+&namvar
+ cn_varinfo=
+/
+
+&namnst
+ in_rhoi=
+ in_rhoj=
+/
+
+&nambdy
+ ln_north=
+ ln_south=
+ ln_east=
+ ln_west=
+ cn_north=
+ cn_south=
+ cn_east=
+ cn_west=
+ ln_oneseg=
+/
+
+&namout
+ cn_fileout="merge_out.nc"
+/