MODULE fliocom !- !$Id: fliocom.f90 2512 2010-12-23 15:27:09Z smasson $ !- ! This software is governed by the CeCILL license ! See IOIPSL/IOIPSL_License_CeCILL.txt !--------------------------------------------------------------------- USE netcdf !- USE defprec USE calendar, ONLY : lock_calendar,ioget_calendar, & & ioconf_calendar,ju2ymds,ymds2ju USE errioipsl, ONLY : ipslerr,ipsldbg USE stringop, ONLY : strlowercase,str_xfw !- IMPLICIT NONE !- PRIVATE !- PUBLIC :: & & fliocrfd, fliopstc, fliodefv, flioputv, flioputa, & & flioopfd, flioinqf, flioinqn, fliogstc, & & flioinqv, fliogetv, flioinqa, fliogeta, & & fliorenv, fliorena, fliodela, fliocpya, & & flioqstc, fliosync, flioclo, fliodmpf, & & flio_dom_set, flio_dom_unset, & & flio_dom_defset, flio_dom_defunset, flio_dom_definq, & & flio_dom_file, flio_dom_att !- !!-------------------------------------------------------------------- !! The following PUBLIC parameters (with "flio_" prefix) !! are used in the module "fliocom" : !! !! flio_max_files : maximum number of simultaneously opened files !! flio_max_dims : maximum number of dimensions for a file !! flio_max_var_dims : maximum number of dimensions for a variable !! !! FLIO_DOM_NONE : "named constant" for no_domain identifier !! FLIO_DOM_DEFAULT : "named constant" for default_domain identifier !! !! flio_i : standard INTEGER external type !! flio_r : standard REAL external type !! flio_c : CHARACTER external type !! flio_i1 : INTEGER*1 external type !! flio_i2 : INTEGER*2 external type !! flio_i4 : INTEGER*4 external type !! flio_r4 : REAL*4 external type !! flio_r8 : REAL*8 external type !!-------------------------------------------------------------------- INTEGER,PARAMETER,PUBLIC :: & & flio_max_files=100, flio_max_dims=10, flio_max_var_dims=5 INTEGER,PARAMETER,PUBLIC :: & & flio_i = -1, flio_r = -2, flio_c =nf90_char, & & flio_i1=nf90_int1, flio_i2=nf90_int2, flio_i4=nf90_int4, & & flio_r4=nf90_real4, flio_r8=nf90_real8 !- INTEGER,PARAMETER,PUBLIC :: FLIO_DOM_NONE =-1 INTEGER,PARAMETER,PUBLIC :: FLIO_DOM_DEFAULT = 0 !- !!-------------------------------------------------------------------- !! The "fliocrfd" routine creates a model file !! which contains the dimensions needed. !! !! SUBROUTINE fliocrfd (f_n,f_d_n,f_d_l,f_i,id_dom,mode,c_f_n) !! !! INPUT !! !! (C) f_n : Name of the file to be created !! (C) f_d_n(:) : Array of (max nb_fd_mx) names of the dimensions !! (I) f_d_l(:) : Array of (max nb_fd_mx) lengths of the dimensions !! For an unlimited dimension, enter a length of -1. !! Actually, only one unlimited dimension is supported. !! !! OUTPUT !! !! (I) f_i : Model file identifier !! !! Optional INPUT arguments !! !! (I) id_dom : Identifier of a domain defined by calling !! "flio_dom_set". If this argument is present, !! and not equal to FLIO_DOM_NONE, it will be !! appended to the file name and !! the attributes describing the related DOMAIN !! will be put in the created file. !! This argument can be equal to FLIO_DOM_DEFAULT !! (see "flio_dom_defset"). !! (C) mode : String of (case insensitive) blank-separated words !! defining the mode used to create the file. !! Supported keywords : REPLACE, 32, 64 !! If this argument is present with the keyword "REPLACE", !! the file will be created in mode "CLOBBER", !! else the file will be created in mode "NOCLOBBER". !! "32/64" defines the offset mode. !! The default offset mode is 64 bits. !! Keywords "NETCDF4" and "CLASSIC" are reserved !! for future use. !! !! Optional OUTPUT arguments !! !! (C) c_f_n : Name of the created file. !! This name can be different of "f_n", !! if a suffix is added to the original name !! (".nc" or "DOMAIN_identifier.nc"). !! The length of "c_f_n" must be sufficient !! to receive the created file name. !! !!- NOTES !! !! The names used to identify the spatio-temporal dimensions !! (dimension associated to a coordinate variable) !! are the following : !! !! Axis Names !! !! x 'x[...]' 'lon[...]' !! y 'y[...]' 'lat[...]' !! z 'z[...]' 'lev[...]' 'plev[...]' 'depth[...]' !! t 't' 'time' 'tstep[...]' 'time_counter[...]' !! !! Please, apply these rules so that coordinates are !! correctly defined. !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "fliopstc" routine defines the major coordinates system !! (spatio-temporal axis) of the model file (created by fliocrfd). !! !! SUBROUTINE fliopstc & !! & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & !! & t_axis,t_init,t_step,t_calendar) !! !! INPUT !! !! (I) f_i : Model file identifier !! !! Optional INPUT arguments !! !! (R) x_axis(:) : longitudinal grids !! (R) x_axis_2d(:,:) : longitudinal grids !! (R) y_axis(:) : latitudinal grids !! (R) y_axis_2d(:,:) : latitudinal grids !! (R) z_axis(:) : vertical grid !! (I) t_axis(:) : timesteps on the time axis !! (R) t_init : date in julian days at the beginning !! (R) t_step : timestep in seconds between t_axis steps !! (C) t_calendar : calendar !! !! [x/y]_axis and [x/y]_axis_2d are mutually exclusive. !! !!- NOTES !! !! The variables corresponding to the spatio-temporal coordinates !! are created according to the following characteristics : !! !!- Longitude axis x_axis / x_axis_2d !! Variable name 'lon' / 'nav_lon' !! Attributes Values !! 'axis' "X" !! 'standard_name' "longitude" !! 'units' "degrees_east" !! 'valid_min' MINVAL(x_axis/x_axis_2d) !! 'valid_max' MAXVAL(x_axis/x_axis_2d) !! !!- Latitude axis y_axis / y_axis_2d !! Variable name 'lat' / 'nav_lat' !! Attributes Values !! 'axis' "Y" !! 'standard_name' "latitude" !! 'units' "degrees_north" !! 'valid_min' MINVAL(y_axis/y_axis_2d) !! 'valid_max' MAXVAL(y_axis/y_axis_2d) !! !!- Vertical axis z_axis !! Variable name 'lev' !! Attributes Values !! 'axis' "Z" !! 'standard_name' "model_level_number" !! 'units' "sigma_level" !! 'long_name' "Sigma Levels" !! 'valid_min' MINVAL(z_axis) !! 'valid_max' MAXVAL(z_axis) !! !!- Time axis t_axis !! Variable name 'time' !! Attributes Values !! 'axis' "T" !! 'standard_name' "time" !! 'long_name' "time steps" !! ['calendar' user/default valued] !! 'units' calculated !! !! If you are not satisfied, it is possible !! to rename variables ("fliorenv") !! or overload the values of attributes ("flioputa"). !! Be careful : the new values you use must allow to read variables !! as coordinates. !! !! The dimensions associated to the coordinates variables !! are searched according to their names (see "fliocrfd") !!-------------------------------------------------------------------- !- INTERFACE fliodefv !!-------------------------------------------------------------------- !! The "fliodefv" routines define a variable in a model file. !! !! SUBROUTINE fliodefv & !! & (f_i,v_n,[v_d],v_t, & !! & axis,standard_name,long_name,units, & !! & valid_min,valid_max,fillvalue) !! !! INPUT !! !! (I) f_i : Model file identifier !! (C) v_n : Name of variable to be defined !! (I) [v_d] : !! "not present" !! --> scalar variable !! "array of one or several integers containing !! the identifiers of the dimensions of the variable !! (in the order specified to "fliocrfd" !! or obtained from "flioopfd")" !! --> multidimensioned variable !! !! Optional INPUT arguments !! !! (I) v_t : External type of the variable !! "present" --> see flio_.. !! "not present" --> type of standard real !! (C) axis,standard_name,long_name,units : Attributes !! (axis should be used only for coordinates) !! (R) valid_min,valid_max,fillvalue : Attributes !!-------------------------------------------------------------------- MODULE PROCEDURE & & fliodv_r0d,fliodv_rnd END INTERFACE !- INTERFACE flioputv !!-------------------------------------------------------------------- !! The "flioputv" routines put a variable (defined by fliodefv) !! in a model file. !! !! SUBROUTINE flioputv (f_i,v_n,v_v,start,count) !! !! INPUT !! !! (I) f_i : model file identifier !! (C) v_n : name of the variable to be written !! (R/I) v_v : scalar or array (up to flio_max_var_dims dimensions) !! containing the (standard) real/integer values !! !! Optional INPUT arguments !! !! (I) start(:) : array of integers specifying the index !! where the first data value will be written !! (I) count(:) : array of integers specifying the number of !! indices that will be written along each dimension !! (not present if v_v is a scalar) !!-------------------------------------------------------------------- !?INTEGERS of KIND 1 are not supported on all computers MODULE PROCEDURE & & fliopv_i40,fliopv_i41,fliopv_i42,fliopv_i43,fliopv_i44,fliopv_i45, & & fliopv_i20,fliopv_i21,fliopv_i22,fliopv_i23,fliopv_i24,fliopv_i25, & !& fliopv_i10,fliopv_i11,fliopv_i12,fliopv_i13,fliopv_i14,fliopv_i15, & & fliopv_r40,fliopv_r41,fliopv_r42,fliopv_r43,fliopv_r44,fliopv_r45, & & fliopv_r80,fliopv_r81,fliopv_r82,fliopv_r83,fliopv_r84,fliopv_r85 END INTERFACE !- INTERFACE flioputa !!-------------------------------------------------------------------- !! The "flioputa" routines put a value for an attribute !! in a model file. !! If this attribute does not exist, it will be created. !! !! SUBROUTINE flioputa (f_i,v_n,a_n,a_v) !! !! INPUT !! !! (I) f_i : Model file identifier !! (C) v_n : Name of variable to which the attribute is assigned. !! If this name is "?", the attribute will be global. !! (C) a_n : Name of the attribute to be defined. !! ( ) a_v : scalar or array of real (kind 4 or 8) or integer values, !! or character string !!-------------------------------------------------------------------- MODULE PROCEDURE & & fliopa_r4_0d,fliopa_r4_1d,fliopa_r8_0d,fliopa_r8_1d, & & fliopa_i4_0d,fliopa_i4_1d,fliopa_tx_0d END INTERFACE !- !!-------------------------------------------------------------------- !! The "flioopfd" routine opens an existing model file, !! and returns the dimensions used in the file and a file identifier. !! This information can be used to allocate the space needed !! to extract the data from the file. !! !! SUBROUTINE flioopfd (f_n,f_i,mode,nb_dim,nb_var,nb_gat) !! !! INPUT !! !! (C) f_n : Name of the file to be opened !! !! OUTPUT !! !! (I) f_i : Model file identifier !! !! Optional INPUT arguments !! !! (C) mode : Access mode to the file. !! If this argument is present with the value "WRITE", !! the file will be accessed in mode "READ-WRITE", !! else the file will be accessed in mode "READ-ONLY". !! !! Optional OUTPUT arguments !! !! (I) nb_dim : number of dimensions !! (I) nb_var : number of variables !! (I) nb_gat : number of global attributes !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "flioinqf" routine returns information !! about an opened model file given its identifier. !! !! SUBROUTINE flioinqf & !! & (f_i,nb_dim,nb_var,nb_gat,id_uld,id_dim,ln_dim) !! !! INPUT !! !! (I) f_i : Model file identifier !! !! Optional OUTPUT arguments !! !! (I) nb_dim : number of dimensions !! (I) nb_var : number of variables !! (I) nb_gat : number of global attributes !! (I) id_uld : identifier of the unlimited dimension (0 if none) !! (I) id_dim(:) : identifiers of the dimensions !! (I) ln_dim(:) : lengths of the dimensions !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "flioinqn" routine returns the names !! of the entities encountered in an opened model file. !! !! SUBROUTINE flioinqn & !! & (f_i,cn_dim,cn_var,cn_gat,cn_uld, & !! & id_start,id_count,iv_start,iv_count,ia_start,ia_count) !! !! INPUT !! !! (I) f_i : Model file identifier !! !! Optional OUTPUT arguments !! !! (C) cn_dim(:) : names of dimensions !! (C) cn_var(:) : names of variables !! (C) cn_gat(:) : names of global attributes !! (C) cn_uld : names of the unlimited dimension !! !! Optional INPUT arguments !! !! (I) id_start,id_count,iv_start,iv_count,ia_start,ia_count !! !! The prefix ( id / iv / ia ) specifies !! the (dimensions/variables/global attributes) entities !! !! The suffix "start" specify the index from which !! the first name will be retrieved (1 by default) !! !! The suffix "count" specifies the number of names to be retrieved !! (all by default) !! !! If a requested entity is not available, a "?" will be returned. !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "fliogstc" routine extracts the major coordinates system !! (spatio-temporal axis) of the model file (opened by flioopfd). !! !! SUBROUTINE fliogstc & !! & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & !! & t_axis,t_init,t_step,t_calendar, & !! & x_start,x_count,y_start,y_count, & !! & z_start,z_count,t_start,t_count) !! !! INPUT !! !! (I) f_i : Model file identifier !! !! Optional OUTPUT arguments !! !! (R) x_axis(:) : longitudinal grids !! (R) x_axis_2d(:,:) : longitudinal grids !! (R) y_axis(:) : latitudinal grids !! (R) y_axis_2d(:,:) : latitudinal grids !! (R) z_axis(:) : vertical grid !! (I) t_axis(:) : timesteps on the time axis !! (R) t_init : date in julian days at the beginning !! (R) t_step : timestep in seconds between t_axis steps !! (C) t_calendar : calendar attribute !! (the value is "not found" if the attribute !! is not present in the model file) !! !! [x/y]_axis and [x/y]_axis_2d are mutually exclusive. !! !! Optional INPUT arguments !! !! (I) x_start,x_count,y_start,y_count,z_start,z_count,t_start,t_count !! !! The prefix (x/y/z/t) specifies the concerned direction. !! !! The suffix "start" specify the index from which !! the first data value will be read (1 by default) !! !! The suffix "count" specifies the number of values to be read !! (all by default) !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "flioinqv" routine returns information about a model !! variable given its name. !! This information can be used to allocate the space needed !! to extract the variable from the file. !! !! SUBROUTINE flioinqv & !! & (f_i,v_n,l_ex,nb_dims,len_dims,id_dims, & !! & nb_atts,cn_atts,ia_start,ia_count) !! !! INPUT !! !! (I) f_i : Model file identifier !! (C) v_n : Name of the variable !! !! OUTPUT !! !! (L) l_ex : Existence of the variable !! !! Optional OUTPUT arguments !! !! (I) v_t : External type of the variable (see flio_..) !! (I) nb_dims : number of dimensions of the variable !! (I) len_dims(:) : list of dimension lengths of the variable !! (I) id_dims(:) : list of dimension identifiers of the variable !! (I) nb_atts : number of attributes of the variable !! (C) cn_atts(:) : names of the attributes !! !! Optional INPUT arguments !! !! (I) ia_start : index of the first attribute whose the name !! will be retrieved (1 by default) !! (I) ia_count : number of names to be retrieved (all by default) !! !! If a requested entity is not available, a "?" will be returned. !!-------------------------------------------------------------------- !- INTERFACE fliogetv !!-------------------------------------------------------------------- !! The "fliogetv" routines get a variable from a model file. !! !! SUBROUTINE fliogetv (f_i,v_n,v_v,start,count) !! !! INPUT !! !! (I) f_i : Model file identifier !! (C) v_n : Name of the variable to be read !! !! OUTPUT !! !! (R/I) v_v : scalar or array (up to flio_max_var_dims dimensions) !! that will contain the (standard) real/integer values !! !! Optional INPUT arguments !! !! (I) start(:) : array of integers specifying the index !! from which the first data value will be read !! (I) count(:) : array of integers specifying the number of !! indices that will be read along each dimension !! (not present if v_v is a scalar) !!-------------------------------------------------------------------- !?INTEGERS of KIND 1 are not supported on all computers MODULE PROCEDURE & & fliogv_i40,fliogv_i41,fliogv_i42,fliogv_i43,fliogv_i44,fliogv_i45, & & fliogv_i20,fliogv_i21,fliogv_i22,fliogv_i23,fliogv_i24,fliogv_i25, & !& fliogv_i10,fliogv_i11,fliogv_i12,fliogv_i13,fliogv_i14,fliogv_i15, & & fliogv_r40,fliogv_r41,fliogv_r42,fliogv_r43,fliogv_r44,fliogv_r45, & & fliogv_r80,fliogv_r81,fliogv_r82,fliogv_r83,fliogv_r84,fliogv_r85 END INTERFACE !- !!-------------------------------------------------------------------- !! The "flioinqa" routine returns information about an !! attribute of a variable given their names, in a model file. !! Information about a variable includes its existence, !! and the number of values currently stored in the attribute. !! For a string-valued attribute, this is the number of !! characters in the string. !! This information can be used to allocate the space needed !! to extract the attribute from the file. !! !! SUBROUTINE flioinqa (f_i,v_n,a_n,l_ex,a_t,a_l) !! !! INPUT !! !! (I) f_i : Model file identifier !! (C) v_n : Name of variable to which the attribute is assigned. !! This name is "?" for a global attribute. !! (C) a_n : Name of the concerned attribute. !! !! OUTPUT !! !! (L) l_ex : existence of the variable !! !! Optional OUTPUT arguments !! !! (I) a_t : external type of the attribute !! (I) a_l : number of values of the attribute !!-------------------------------------------------------------------- !- INTERFACE fliogeta !!-------------------------------------------------------------------- !! The "fliogeta" routines get a value for an attribute !! in a model file. !! !! SUBROUTINE fliogeta (f_i,v_n,a_n,a_v) !! !! INPUT !! !! (I) f_i : Model file identifier !! (C) v_n : Name of variable to which the attribute is assigned. !! This name is "?" for a global attribute. !! (C) a_n : Name of the attribute to be retrieved. !! ( ) a_v : scalar or array of real (kind 4 or 8) or integer values, !! or character string !!-------------------------------------------------------------------- MODULE PROCEDURE & & flioga_r4_0d,flioga_r4_1d,flioga_r8_0d,flioga_r8_1d, & & flioga_i4_0d,flioga_i4_1d,flioga_tx_0d END INTERFACE !- !!-------------------------------------------------------------------- !! The "fliorenv" routine renames a variable, in a model file. !! !! SUBROUTINE fliorenv (f_i,v_o_n,v_n_n) !! !! INPUT !! !! (I) f_i : Model file identifier !! (C) v_o_n : Old name of the variable !! (C) v_n_n : New name of the variable !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "fliorena" routine renames an attribute !! of a variable, in a model file. !! !! SUBROUTINE fliorena (f_i,v_n,a_o_n,a_n_n) !! !! INPUT !! !! (I) f_i : Model file identifier !! (C) v_n : Name of variable to which the attribute is assigned. !! This name is "?" for a global attribute. !! (C) a_o_n : Old name of the concerned attribute. !! (C) a_n_n : New name of the concerned attribute. !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "fliodela" routine deletes an attribute in a model file. !! !! SUBROUTINE fliodela (f_i,v_n,a_n) !! !! INPUT !! !! (I) f_i : Model file identifier !! (C) v_n : Name of variable to which the attribute is assigned. !! This name is "?" for a global attribute. !! (C) a_n : Name of the concerned attribute. !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "fliocpya" routine copies an attribute !! from one open model file to another. !! It can also be used to copy an attribute from !! one variable to another within the same model file. !! !! SUBROUTINE fliocpya (f_i_i,v_n_i,a_n,f_i_o,v_n_o) !! !! INPUT !! !! (I) f_i_i : Identifier of the input model file !! (C) v_n_i : Name of the input variable !! This name is "?" for a global attribute. !! (C) a_n : Name of the concerned attribute. !! (I) f_i_o : Identifier of the output model file !! It can be the same as the input identifier. !! (C) v_n_o : Name of the output variable !! This name is "?" for a global attribute. !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "flioqstc" routine search for a spatio-temporal coordinate !! in a model file and returns its name. !! !! SUBROUTINE flioqstc (f_i,c_type,l_ex,c_name) !! !! INPUT !! !! (I) f_i : Model file identifier !! (C) c_type : Type of the coordinate ("x"/"y"/"z"/"t") !! !! OUTPUT !! !! (L) l_ex : existence of the coordinate !! (C) c_name : name of the coordinate !! !!- NOTES !! !! The following rules are used for searching variables !! which are spatio-temporal coordinates (x/y/z/t). !! !!-- Rule 1 : we look for a variable with one dimension !!-- and which has the same name as its dimension !! !!-- Rule 2 : we look for a correct "axis" attribute !! !! Axis Axis attribute Number of dimensions !! (case insensitive) !! !! x X 1/2 !! y Y 1/2 !! z Z 1 !! t T 1 !! !!-- Rule 3 : we look for a correct "standard_name" attribute !! !! Axis Axis attribute Number of dimensions !! (case insensitive) !! !! x longitude 1/2 !! y latitude 1/2 !! z model_level_number 1 !! t time 1 !! !!-- Rule 4 : we look for a specific name !! !! Axis Names !! !! x 'nav_lon' 'lon' 'longitude' !! y 'nav_lat' 'lat' 'latitude' !! z 'depth' 'deptht' 'height' 'level' !! 'lev' 'plev' 'sigma_level' 'layer' !! t 'time' 'tstep' 'timesteps' !! !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "fliosync" routine synchronise one or all opened model files, !! to minimize data loss in case of abnormal termination. !! !! SUBROUTINE fliosync (f_i) !! !! Optional INPUT arguments !! !! (I) f_i : Model file identifier !! If this argument is not present, !! all the opened model files are synchronised. !--------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "flioclo" routine closes one or all opened model files !! and frees the space needed to keep information about the files !! !! SUBROUTINE flioclo (f_i) !! !! Optional INPUT arguments !! !! (I) f_i : Model file identifier !! If this argument is not present, !! all the opened model files are closed. !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! The "fliodmpf" routine dumps a model file !! and prints the result on the standard output. !! !! SUBROUTINE fliodmpf (f_n) !! !! INPUT !! !! (C) f_n : Name of the model file to be dumped !!-------------------------------------------------------------------- !- !!-------------------------------------------------------------------- !! This "flio_dom_set" sets up the domain activity of IOIPSL. !! It stores all the domain information and allows it to be stored !! in the model file and change the file names. !! !! This routine must be called by the user before opening !! the model file. !! !! SUBROUTINE flio_dom_set & !! & (dtnb,dnb,did,dsg,dsl,dpf,dpl,dhs,dhe,cdnm,id_dom) !! !! INPUT !! !! (I) dtnb : total number of domains !! (I) dnb : domain number !! (I) did(:) : distributed dimensions identifiers !! (up to 5 dimensions are supported) !! (I) dsg(:) : total number of points for each dimension !! (I) dsl(:) : local number of points for each dimension !! (I) dpf(:) : position of first local point for each dimension !! (I) dpl(:) : position of last local point for each dimension !! (I) dhs(:) : start halo size for each dimension !! (I) dhe(:) : end halo size for each dimension !! (C) cdnm : Model domain definition name. !! The names actually supported are : !! "BOX", "APPLE", "ORANGE". !! These names are case insensitive. !! !! OUTPUT argument !! !! (I) id_dom : Model domain identifier !! !!-------------------------------------------------------------------- !! !!-------------------------------------------------------------------- !! The "flio_dom_unset" routine unsets one or all set domains !! and frees the space needed to keep information about the domains !! !! This routine should be called by the user to free useless domains. !! !! SUBROUTINE flio_dom_unset (id_dom) !! !! Optional INPUT arguments !! !! (I) id_dom : Model domain identifier !! >=1 & <= dom_max_nb : the domain is closed !! not present : all the set model domains are unset !!-------------------------------------------------------------------- !! !!-------------------------------------------------------------------- !! The "flio_dom_defset" sets !! the default domain identifier. !! !! SUBROUTINE flio_dom_defset (id_dom) !! !! INPUT argument !! !! (I) id_dom : Model default domain identifier !! ( >=1 & <= dom_max_nb ) !! This identifier will be able to be taken by calling !! "flio_dom_definq" and used to create model files !! with the corresponding domain definitions !!-------------------------------------------------------------------- !! !!-------------------------------------------------------------------- !! The "flio_dom_defunset" routine unsets !! the default domain identifier. !! !! SUBROUTINE flio_dom_defunset () !! !!-------------------------------------------------------------------- !! !!-------------------------------------------------------------------- !! The "flio_dom_definq" routine inquires about !! the default domain identifier. !! You should call this procedure to safeguard the current !! default domain identifier if you wish to use locally !! another default domain, in order to restore it. !! !! SUBROUTINE flio_dom_definq (id_dom) !! !! OUTPUT argument !! !! (I) id_dom : Model default domain identifier !! IF no default domain identifier has been set, !! the returned value is "FLIO_DOM_NONE". !!-------------------------------------------------------------------- !- !--------------------------------------------------------------------- ! This is the data we keep concerning each file we open !--------------------------------------------------------------------- !- For each file !- (I) nw_id(f_i) : index to access at this file !- (I) nw_nd(f_i) : number of dimensions !- (I) nw_nv(f_i) : number of variables !- (I) nw_na(f_i) : number of global attributes !- (I) nw_un(f_i) : ID of the first unlimited dimension !- (L) lw_hm(f_i) : for mode handling (.TRUE. define, .FALSE. data) !- (I) nw_di(:,f_i) : dimension IDs in the file "f_i" !- (I) nw_dl(:,f_i) : dimension lengths in the file "f_i" !- (I) nw_ai(:,f_i) : dimension Ids for the axis in the file "f_i" !--------------------------------------------------------------------- INTEGER,PARAMETER :: & & nb_fi_mx=flio_max_files, & & nb_fd_mx=flio_max_dims, & & nb_vd_mx=flio_max_var_dims INTEGER,PARAMETER :: nb_ax_mx=4 !- INTEGER,PARAMETER :: k_lon=1, k_lat=2, k_lev=3, k_tim=4 !- INTEGER,DIMENSION(nb_fi_mx),SAVE :: & & nw_id=-1,nw_nd,nw_nv,nw_na,nw_un LOGICAL,DIMENSION(nb_fi_mx),SAVE :: lw_hm INTEGER,DIMENSION(nb_fd_mx,nb_fi_mx),SAVE :: nw_di=-1,nw_dl=-1 INTEGER,DIMENSION(nb_ax_mx,nb_fi_mx),SAVE :: nw_ai=-1 !- ! Maximum number of simultaneously defined domains INTEGER,PARAMETER :: dom_max_nb=200 !- ! Maximum number of distributed dimensions for each domain INTEGER,PARAMETER :: dom_max_dims=5 !- ! Default domain identifier INTEGER,SAVE :: id_def_dom=FLIO_DOM_NONE !- ! Supported domain definition names INTEGER,PARAMETER :: n_dns=3, l_dns=7 CHARACTER(LEN=l_dns),DIMENSION(n_dns),SAVE :: & & c_dns=(/ "box ","apple ","orange "/) !- ! DOMAINS related variables INTEGER,DIMENSION(1:dom_max_nb),SAVE :: & & d_d_n=-1, d_n_t=0, d_n_c=0 INTEGER,DIMENSION(1:dom_max_dims,1:dom_max_nb),SAVE :: & & d_d_i, d_s_g, d_s_l, d_p_f, d_p_l, d_h_s, d_h_e CHARACTER(LEN=l_dns),DIMENSION(1:dom_max_nb),SAVE :: c_d_t !- !=== CONTAINS !=== !- !--------------------------------------------------------------------- !- Public procedures !--------------------------------------------------------------------- !- !=== SUBROUTINE fliocrfd (f_n,f_d_n,f_d_l,f_i,id_dom,mode,c_f_n) !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*),INTENT(IN) :: f_n CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: f_d_n INTEGER,DIMENSION(:),INTENT(IN) :: f_d_l INTEGER,INTENT(OUT) :: f_i INTEGER,OPTIONAL,INTENT(IN) :: id_dom CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: c_f_n !- INTEGER :: i_rc,f_e,idid,ii,m_c,n_u CHARACTER(LEN=NF90_MAX_NAME) :: f_nw INTEGER,PARAMETER :: l_string=80,l_word=10 CHARACTER(LEN=l_string) :: c_string CHARACTER(LEN=l_word) :: c_word LOGICAL :: l_ok INTEGER,PARAMETER :: k_replace=1 INTEGER,PARAMETER :: k_32=1,k_64=2 !- !? : Code to be activated for NETCDF4 !? INTEGER,PARAMETER :: k_netcdf4=1,k_classic=1 INTEGER,PARAMETER :: n_opt=4 INTEGER,DIMENSION(n_opt) :: i_opt !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->fliocrfd - file name : ",TRIM(f_n) ENDIF !- ! Search for a free local identifier f_i = flio_rid() IF (f_i < 0) THEN CALL ipslerr (3,'fliocrfd', & & 'Too many files.','Please increase nb_fi_mx', & & 'in module fliocom.f90.') ENDIF !- ! Update the name of the file f_nw = f_n CALL flio_dom_file (f_nw,id_dom) !- ! Check the dimensions IF (SIZE(f_d_l) /= SIZE(f_d_n)) THEN CALL ipslerr (3,'fliocrfd', & & 'The number of names is not equal to the number of lengths', & & 'for the dimensions of the file',TRIM(f_nw)) ENDIF IF (SIZE(f_d_l) > nb_fd_mx) THEN CALL ipslerr (3,'fliocrfd', & & 'Too many dimensions','to create the file',TRIM(f_nw)) ENDIF !- ! Check the mode !- i_opt(:)=-1 !- IF (PRESENT(mode)) THEN !--- IF (LEN_TRIM(mode) > l_string) THEN CALL ipslerr (3,'fliocrfd', & & '"mode" argument','too long','to be treated') ENDIF c_string = mode(:) CALL strlowercase (c_string) !--- DO CALL str_xfw (c_string,c_word,l_ok) IF (l_ok) THEN !- !? : Code to be activated for NETCDF4 SELECT CASE (TRIM(c_word)) CASE('replace') IF (i_opt(1) > 0) THEN CALL ipslerr (3,'fliocrfd', & & 'Replace option','already','defined') ELSE i_opt(1) = k_replace ENDIF !? CASE('netcdf4') !? IF (i_opt(2) > 0) THEN !? CALL ipslerr (3,'fliocrfd', & !? & 'Netcdf4 format','already','defined') !? ELSE !? i_opt(2) = k_netcdf4 !? ENDIF CASE('32') IF (i_opt(3) > 0) THEN CALL ipslerr (3,'fliocrfd', & & 'Offset format','already','defined') ELSE i_opt(3) = k_32 ENDIF CASE('64') IF (i_opt(3) > 0) THEN CALL ipslerr (3,'fliocrfd', & & 'Offset format','already','defined') ELSE i_opt(3) = k_64 ENDIF !? CASE('CLASSIC') !? IF (i_opt(4) > 0) THEN !? CALL ipslerr (3,'fliocrfd', & !? & 'Netcdf4 classic format','already','defined') !? ELSE !? i_opt(4) = k_classic !? ENDIF CASE DEFAULT CALL ipslerr (3,'fliocrfd', & & 'Option '//TRIM(c_word),'not','supported') END SELECT ELSE EXIT ENDIF ENDDO ENDIF !- IF (i_opt(1) == k_replace) THEN m_c = NF90_CLOBBER ELSE m_c = NF90_NOCLOBBER ENDIF !- !- Code to be replaced by the following for NETCDF4 !? IF (i_opt(2) == k_netcdf4) THEN !? m_c = IOR(m_c,NF90_NETCDF4) !? IF (i_opt(3) > 0) THEN !? CALL ipslerr (3,'fliocrfd', & !? & 'Netcdf4 format','and offset option','are not compatible') !? ELSE IF (i_opt(4) == k_classic) THEN !? m_c = IOR(m_c,NF90_CLASSIC_MODEL) !? ENDIF !? LSE IF (i_opt(4) > 0) THEN !? CALL ipslerr (3,'fliocrfd', & !? & 'Classic option','is reserved','for the Netcdf4 format') !? ELSE IF (i_opt(3) /= k_32) THEN m_c = IOR(m_c,NF90_64BIT_OFFSET) ENDIF !? ENDIF !- ! Create file (and enter the definition mode) i_rc = NF90_CREATE(f_nw,m_c,f_e) lw_hm(f_i) = .TRUE. IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliocrfd', & & 'Could not create file :',TRIM(f_nw), & & TRIM(NF90_STRERROR(i_rc))//' (Netcdf)') ENDIF !- IF (l_dbg) THEN WRITE(*,*) ' fliocrfd, external model file-id : ',f_e ENDIF !- ! Create dimensions n_u = 0 DO ii=1,SIZE(f_d_l) IF (f_d_l(ii) == -1) THEN IF (n_u == 0) THEN i_rc = NF90_DEF_DIM(f_e,TRIM(f_d_n(ii)),NF90_UNLIMITED,idid) n_u = n_u+1 ELSE CALL ipslerr (3,'fliocrfd', & & 'Can not handle more than one unlimited dimension', & & 'for file :',TRIM(f_nw)) ENDIF ELSE IF (f_d_l(ii) > 0) THEN i_rc = NF90_DEF_DIM(f_e,TRIM(f_d_n(ii)),f_d_l(ii),idid) ENDIF IF ( ((f_d_l(ii) == -1).OR.(f_d_l(ii) > 0)) & & .AND.(i_rc /= NF90_NOERR) ) THEN CALL ipslerr (3,'fliocrfd', & & 'One dimension can not be defined', & & 'for the file :',TRIM(f_nw)) ENDIF ENDDO !- ! Define "Conventions" global attribute i_rc = NF90_PUT_ATT(f_e,NF90_GLOBAL,'Conventions',"CF-1.1") !- ! Add the DOMAIN attributes if needed CALL flio_dom_att (f_e,id_dom) !- ! Keep the file information nw_id(f_i) = f_e CALL flio_inf (f_e, & & nb_dims=nw_nd(f_i),id_unlm=nw_un(f_i),nb_atts=nw_na(f_i), & & nn_idm=nw_di(:,f_i),nn_ldm=nw_dl(:,f_i),nn_aid=nw_ai(:,f_i)) !- ! Return the created file name if needed IF (PRESENT(c_f_n)) THEN IF (LEN(c_f_n) >= LEN_TRIM(f_nw)) THEN c_f_n = TRIM(f_nw) ELSE CALL ipslerr (3,'fliocrfd', & & 'the length of "c_f_n" is not sufficient to receive', & & 'the name of the created file :',TRIM(f_nw)) ENDIF ENDIF !- IF (l_dbg) THEN WRITE(*,*) '<-fliocrfd' ENDIF !---------------------- END SUBROUTINE fliocrfd !=== SUBROUTINE fliopstc & & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & & t_axis,t_init,t_step,t_calendar) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i REAL,DIMENSION(:),OPTIONAL,INTENT(IN) :: x_axis,y_axis REAL,DIMENSION(:,:),OPTIONAL,INTENT(IN) :: x_axis_2d,y_axis_2d REAL,DIMENSION(:),OPTIONAL,INTENT(IN) :: z_axis INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: t_axis CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: t_calendar REAL,OPTIONAL,INTENT(IN) :: t_init,t_step !- INTEGER :: i_rc,f_e INTEGER :: lonid,latid,levid,timeid INTEGER :: j_yy,j_mo,j_dd,j_hh,j_mn,j_ss REAL :: dt,r_ss,v_min,v_max INTEGER :: k,k_1,k_2 LOGICAL :: l_tmp CHARACTER(LEN=20) :: c_tmp1 CHARACTER(LEN=40) :: c_tmp2 CHARACTER(LEN=80) :: c_tmp3 !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->fliopstc" ENDIF !- ! Retrieve the external file index CALL flio_qvid ('fliopstc',f_i,f_e) !- ! Validate the coherence of the arguments !- IF ( (PRESENT(x_axis).AND.PRESENT(x_axis_2d)) & & .OR.(PRESENT(y_axis).AND.PRESENT(y_axis_2d)) ) THEN CALL ipslerr (3,'fliopstc', & & 'The [x/y]_axis arguments', & & 'are not coherent :',& & 'can not handle two [x/y]_axis') ENDIF !- IF ( PRESENT(x_axis).OR.PRESENT(x_axis_2d) & & .OR.PRESENT(y_axis).OR.PRESENT(y_axis_2d) ) THEN k_1=nw_ai(k_lon,f_i); k_2=nw_ai(k_lat,f_i); ENDIF !- ! Define the longitude axis !- IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN !--- IF (l_dbg) THEN WRITE(*,*) ' fliopstc : Define the Longitude axis' ENDIF !--- IF (PRESENT(x_axis)) THEN IF (SIZE(x_axis) /= nw_dl(k_1,f_i)) THEN CALL ipslerr (3,'fliopstc', & & 'Invalid x_axis dimension :', & & 'not equal to the dimension', & & 'defined at the creation of the file') ENDIF ELSE IF ( (SIZE(x_axis_2d,DIM=1) /= nw_dl(k_1,f_i)) & & .OR.(SIZE(x_axis_2d,DIM=2) /= nw_dl(k_2,f_i)) ) THEN CALL ipslerr (3,'fliopstc', & & 'Invalid x_axis_2d dimensions :', & & 'not equal to the dimensions', & & 'defined at the creation of the file') ENDIF ENDIF !--- CALL flio_hdm (f_i,f_e,.TRUE.) IF (PRESENT(x_axis)) THEN i_rc = NF90_DEF_VAR(f_e,"lon",NF90_REAL4, & & nw_di(k_1,f_i),lonid) v_min = MINVAL(x_axis) v_max = MAXVAL(x_axis) ELSE i_rc = NF90_DEF_VAR(f_e,"nav_lon",NF90_REAL4, & & nw_di((/k_1,k_2/),f_i),lonid) v_min = MINVAL(x_axis_2d) v_max = MAXVAL(x_axis_2d) ENDIF i_rc = NF90_PUT_ATT(f_e,lonid,"axis","X") i_rc = NF90_PUT_ATT(f_e,lonid,'standard_name',"longitude") i_rc = NF90_PUT_ATT(f_e,lonid,'units',"degrees_east") i_rc = NF90_PUT_ATT(f_e,lonid,'valid_min',REAL(v_min,KIND=4)) i_rc = NF90_PUT_ATT(f_e,lonid,'valid_max',REAL(v_max,KIND=4)) ENDIF !- ! Define the Latitude axis !- IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN !--- IF (l_dbg) THEN WRITE(*,*) ' fliopstc : Define the Latitude axis' ENDIF !--- IF (PRESENT(y_axis)) THEN IF (SIZE(y_axis) /= nw_dl(k_2,f_i)) THEN CALL ipslerr (3,'fliopstc', & & 'Invalid y_axis dimension :', & & 'not equal to the dimension', & & 'defined at the creation of the file') ENDIF ELSE IF ( (SIZE(y_axis_2d,DIM=1) /= nw_dl(k_1,f_i)) & & .OR.(SIZE(y_axis_2d,DIM=2) /= nw_dl(k_2,f_i)) ) THEN CALL ipslerr (3,'fliopstc', & & 'Invalid y_axis_2d dimensions :', & & 'not equal to the dimensions', & & 'defined at the creation of the file') ENDIF ENDIF !--- CALL flio_hdm (f_i,f_e,.TRUE.) IF (PRESENT(y_axis)) THEN i_rc = NF90_DEF_VAR(f_e,"lat",NF90_REAL4, & & nw_di(k_2,f_i),latid) v_min = MINVAL(y_axis) v_max = MAXVAL(y_axis) ELSE i_rc = NF90_DEF_VAR(f_e,"nav_lat",NF90_REAL4, & & nw_di((/k_1,k_2/),f_i),latid) v_min = MINVAL(y_axis_2d) v_max = MAXVAL(y_axis_2d) ENDIF i_rc = NF90_PUT_ATT(f_e,latid,"axis","Y") i_rc = NF90_PUT_ATT(f_e,latid,'standard_name',"latitude") i_rc = NF90_PUT_ATT(f_e,latid,'units',"degrees_north") i_rc = NF90_PUT_ATT(f_e,latid,'valid_min',REAL(v_min,KIND=4)) i_rc = NF90_PUT_ATT(f_e,latid,'valid_max',REAL(v_max,KIND=4)) ENDIF !- ! Define the Vertical axis !- IF (PRESENT(z_axis)) THEN !--- IF (l_dbg) THEN WRITE(*,*) ' fliopstc : Define the Vertical axis' ENDIF !--- k_1=nw_ai(k_lev,f_i); !--- IF (SIZE(z_axis) /= nw_dl(k_1,f_i)) THEN CALL ipslerr (3,'fliopstc', & & 'Invalid z_axis dimension :', & & 'not equal to the dimension', & & 'defined at the creation of the file') ENDIF !--- v_min = MINVAL(z_axis) v_max = MAXVAL(z_axis) !--- CALL flio_hdm (f_i,f_e,.TRUE.) i_rc = NF90_DEF_VAR(f_e,'lev',NF90_REAL4, & & nw_di(k_1,f_i),levid) i_rc = NF90_PUT_ATT(f_e,levid,"axis","Z") i_rc = NF90_PUT_ATT(f_e,levid,'standard_name','model_level_number') i_rc = NF90_PUT_ATT(f_e,levid,'units','sigma_level') i_rc = NF90_PUT_ATT(f_e,levid,'long_name','Sigma Levels') i_rc = NF90_PUT_ATT(f_e,levid,'valid_min',REAL(v_min,KIND=4)) i_rc = NF90_PUT_ATT(f_e,levid,'valid_max',REAL(v_max,KIND=4)) ENDIF !- ! Define the Time axis !- IF (PRESENT(t_axis).AND.PRESENT(t_init).AND.PRESENT(t_step)) THEN !--- IF (l_dbg) THEN WRITE(*,*) ' fliopstc : Define the Time axis' ENDIF !--- k_1=nw_ai(k_tim,f_i); !--- IF ( (nw_dl(k_1,f_i) /= 0) & & .AND.(SIZE(t_axis) /= nw_dl(k_1,f_i)) ) THEN CALL ipslerr (3,'fliopstc', & & 'Invalid t_axis dimension :', & & 'not equal to the dimension', & & 'defined at the creation of the file') ENDIF !-- Retrieve the calendar date CALL lock_calendar (old_status=l_tmp) IF (PRESENT(t_calendar)) THEN CALL ioget_calendar (c_tmp1) CALL lock_calendar (new_status=.FALSE.) CALL ioconf_calendar (TRIM(t_calendar)) ENDIF CALL ju2ymds (t_init,j_yy,j_mo,j_dd,r_ss) IF (PRESENT(t_calendar)) THEN CALL lock_calendar (new_status=.FALSE.) CALL ioconf_calendar (TRIM(c_tmp1)) ENDIF CALL lock_calendar (new_status=l_tmp) !-- k=NINT(r_ss) j_hh=k/3600 k=k-3600*j_hh j_mn=k/60 j_ss=k-60*j_mn !-- Calculate the step unit IF (ABS(t_step) >= 604800.) THEN dt = t_step/604800. c_tmp2 = 'weeks' ELSE IF (ABS(t_step) >= 86400.) THEN dt = t_step/86400. c_tmp2 = 'days' ELSE IF (ABS(t_step) >= 3600.) THEN dt = t_step/3600. c_tmp2 = 'hours' ELSE IF (ABS(t_step) >= 60.) THEN dt = t_step/60. c_tmp2 = 'minutes' ELSE dt = t_step c_tmp2 = 'seconds' ENDIF !--- c_tmp1 = '' IF (ABS(dt-NINT(dt)) <= ABS(10.*EPSILON(dt))) THEN IF (NINT(dt) /= 1) THEN WRITE (UNIT=c_tmp1,FMT='(I15)') NINT(dt) ENDIF ELSE IF (dt < 1.) THEN WRITE (UNIT=c_tmp1,FMT='(F8.5)') dt ELSE WRITE (UNIT=c_tmp1,FMT='(F17.5)') dt ENDIF DO k=LEN_TRIM(c_tmp1),1,-1 IF (c_tmp1(k:k) /= '0') THEN EXIT ELSE c_tmp1(k:k) = ' ' ENDIF ENDDO ENDIF c_tmp2 = TRIM(c_tmp1)//' '//TRIM(c_tmp2) WRITE (UNIT=c_tmp3, & & FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & & TRIM(ADJUSTL(c_tmp2))//' since ',j_yy,j_mo,j_dd,j_hh,j_mn,j_ss !--- CALL flio_hdm (f_i,f_e,.TRUE.) i_rc = NF90_DEF_VAR(f_e,'time',NF90_REAL4, & & nw_di(k_1,f_i),timeid) i_rc = NF90_PUT_ATT(f_e,timeid,"axis",'T') i_rc = NF90_PUT_ATT(f_e,timeid,'standard_name','time') i_rc = NF90_PUT_ATT(f_e,timeid,'long_name','time steps') IF (PRESENT(t_calendar)) THEN i_rc = NF90_PUT_ATT(f_e,timeid,'calendar',TRIM(t_calendar)) ENDIF i_rc = NF90_PUT_ATT(f_e,timeid,'units',TRIM(c_tmp3)) ELSE IF (PRESENT(t_axis).OR.PRESENT(t_init).OR.PRESENT(t_step)) THEN CALL ipslerr (3,'fliopstc', & & 'For time axis and coordinates', & & 'arguments t_axis AND t_init AND t_step', & & 'must be PRESENT') ENDIF !- ! Ensuring data mode !- CALL flio_hdm (f_i,f_e,.FALSE.) !- ! Create the longitude axis !- IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN IF (l_dbg) THEN WRITE(*,*) ' fliopstc : Create the Longitude axis' ENDIF IF (PRESENT(x_axis)) THEN i_rc = NF90_PUT_VAR(f_e,lonid,x_axis(:)) ELSE i_rc = NF90_PUT_VAR(f_e,lonid,x_axis_2d(:,:)) ENDIF ENDIF !- ! Create the Latitude axis !- IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN IF (l_dbg) THEN WRITE(*,*) ' fliopstc : Create the Latitude axis' ENDIF IF (PRESENT(y_axis)) THEN i_rc = NF90_PUT_VAR(f_e,latid,y_axis(:)) ELSE i_rc = NF90_PUT_VAR(f_e,latid,y_axis_2d(:,:)) ENDIF ENDIF !- ! Create the Vertical axis !- IF (PRESENT(z_axis)) THEN IF (l_dbg) THEN WRITE(*,*) ' fliopstc : Create the Vertical axis' ENDIF i_rc = NF90_PUT_VAR(f_e,levid,z_axis(:)) ENDIF !- ! Create the Time axis !- IF (PRESENT(t_axis)) THEN IF (l_dbg) THEN WRITE(*,*) ' fliopstc : Create the Time axis' ENDIF i_rc = NF90_PUT_VAR(f_e,timeid,REAL(t_axis(:))) ENDIF !- ! Keep all this information !- CALL flio_inf (f_e,nb_vars=nw_nv(f_i),nb_atts=nw_na(f_i)) !- IF (l_dbg) THEN WRITE(*,*) "<-fliopstc" ENDIF !---------------------- END SUBROUTINE fliopstc !=== SUBROUTINE fliodv_r0d & & (f_i,v_n,v_t, & & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER,OPTIONAL,INTENT(IN) :: v_t CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & & axis,standard_name,long_name,units REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue !--------------------------------------------------------------------- CALL flio_udv & & (f_i,0,v_n,(/0/),v_t, & & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) !------------------------ END SUBROUTINE fliodv_r0d !=== SUBROUTINE fliodv_rnd & & (f_i,v_n,v_d,v_t, & & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER,DIMENSION(:),INTENT(IN) :: v_d INTEGER,OPTIONAL,INTENT(IN) :: v_t CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & & axis,standard_name,long_name,units REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue !--------------------------------------------------------------------- CALL flio_udv & & (f_i,SIZE(v_d),v_n,v_d,v_t, & & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) !------------------------ END SUBROUTINE fliodv_rnd !=== SUBROUTINE flio_udv & & (f_i,n_d,v_n,v_d,v_t, & & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i,n_d CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER,DIMENSION(:),INTENT(IN) :: v_d INTEGER,OPTIONAL,INTENT(IN) :: v_t CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & & axis,standard_name,long_name,units REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue !- INTEGER :: f_e,m_k,i_v,i_rc,ii,idd INTEGER,DIMENSION(nb_vd_mx) :: a_i !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->fliodefv ",TRIM(v_n)," ",n_d,"D" ENDIF !- ! Retrieve the external file index CALL flio_qvid ('fliodefv',f_i,f_e) !- IF (n_d > 0) THEN IF (n_d > nb_vd_mx) THEN CALL ipslerr (3,'fliodefv', & & 'Too many dimensions', & & 'required for the variable',TRIM(v_n)) ENDIF ENDIF !- DO ii=1,n_d IF ( (v_d(ii) >= 1).AND.(v_d(ii) <= nb_fd_mx) ) THEN idd = nw_di(v_d(ii),f_i) IF (idd > 0) THEN a_i(ii) = idd ELSE CALL ipslerr (3,'fliodefv', & & 'Invalid dimension identifier','(not defined)',' ') ENDIF ELSE CALL ipslerr (3,'fliodefv', & & 'Invalid dimension identifier','(not supported)',' ') ENDIF ENDDO !- i_rc = NF90_INQ_VARID(f_e,v_n,i_v) IF (i_rc /= NF90_NOERR) THEN CALL flio_hdm (f_i,f_e,.TRUE.) !--- IF (PRESENT(v_t)) THEN SELECT CASE (v_t) CASE(flio_i) IF (i_std == i_8) THEN !-------- I8 not yet supported by NETCDF !-------- m_k = flio_i8 m_k = flio_i4 ELSE m_k = flio_i4 ENDIF CASE(flio_r) IF (r_std == r_8) THEN m_k = flio_r8 ELSE m_k = flio_r4 ENDIF CASE(flio_c,flio_i1,flio_i2,flio_i4,flio_r4,flio_r8) m_k = v_t CASE DEFAULT CALL ipslerr (3,'fliodefv', & & 'Variable '//TRIM(v_n),'External type','not supported') END SELECT ELSE IF (r_std == r_8) THEN m_k = flio_r8 ELSE m_k = flio_r4 ENDIF !--- IF (n_d > 0) THEN i_rc = NF90_DEF_VAR(f_e,v_n,m_k,a_i(1:n_d),i_v) ELSE i_rc = NF90_DEF_VAR(f_e,v_n,m_k,i_v) ENDIF IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliodefv', & & 'Variable '//TRIM(v_n)//' not defined','Error :', & & TRIM(NF90_STRERROR(i_rc))) ENDIF nw_nv(f_i) = nw_nv(f_i)+1 !--- IF (PRESENT(axis)) THEN i_rc = NF90_PUT_ATT(f_e,i_v,'axis',TRIM(axis)) ENDIF IF (PRESENT(standard_name)) THEN i_rc = NF90_PUT_ATT(f_e,i_v,'standard_name',TRIM(standard_name)) ENDIF IF (PRESENT(long_name)) THEN i_rc = NF90_PUT_ATT(f_e,i_v,'long_name',TRIM(long_name)) ENDIF IF (PRESENT(units)) THEN i_rc = NF90_PUT_ATT(f_e,i_v,'units',TRIM(units)) ENDIF IF (PRESENT(valid_min)) THEN SELECT CASE (m_k) CASE(flio_i1,flio_i2) i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',NINT(valid_min,KIND=i_2)) CASE(flio_i4) i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',NINT(valid_min,KIND=i_4)) CASE(flio_r4) i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',REAL(valid_min,KIND=r_4)) CASE(flio_r8) i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',REAL(valid_min,KIND=r_8)) CASE DEFAULT CALL ipslerr (2,'fliodefv', & & 'Variable '//TRIM(v_n),'attribute valid_min', & & 'not supported for this external type') END SELECT ENDIF IF (PRESENT(valid_max)) THEN SELECT CASE (m_k) CASE(flio_i1,flio_i2) i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',NINT(valid_max,KIND=i_2)) CASE(flio_i4) i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',NINT(valid_max,KIND=i_4)) CASE(flio_r4) i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',REAL(valid_max,KIND=r_4)) CASE(flio_r8) i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',REAL(valid_max,KIND=r_8)) CASE DEFAULT CALL ipslerr (2,'fliodefv', & & 'Variable '//TRIM(v_n),'attribute valid_max', & & 'not supported for this external type') END SELECT ENDIF IF (PRESENT(fillvalue)) THEN SELECT CASE (m_k) CASE(flio_i1,flio_i2) i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',NINT(fillvalue,KIND=i_2)) CASE(flio_i4) i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',NINT(fillvalue,KIND=i_4)) CASE(flio_r4) i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',REAL(fillvalue,KIND=r_4)) CASE(flio_r8) i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',REAL(fillvalue,KIND=r_8)) CASE DEFAULT CALL ipslerr (2,'fliodefv', & & 'Variable '//TRIM(v_n),'attribute fillvalue', & & 'not supported for this external type') END SELECT ENDIF !--- ELSE CALL ipslerr (3,'fliodefv','Variable',TRIM(v_n),'already exist') ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-fliodefv" ENDIF !---------------------- END SUBROUTINE flio_udv !=== SUBROUTINE fliopv_i40 (f_i,v_n,v_v,start) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_40=v_v,start=start) !------------------------ END SUBROUTINE fliopv_i40 !=== SUBROUTINE fliopv_i41 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),DIMENSION(:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_41=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_i41 !=== SUBROUTINE fliopv_i42 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_42=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_i42 !=== SUBROUTINE fliopv_i43 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_43=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_i43 !=== SUBROUTINE fliopv_i44 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_44=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_i44 !=== SUBROUTINE fliopv_i45 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_45=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_i45 !=== SUBROUTINE fliopv_i20 (f_i,v_n,v_v,start) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_20=v_v,start=start) !------------------------ END SUBROUTINE fliopv_i20 !=== SUBROUTINE fliopv_i21 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),DIMENSION(:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_21=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_i21 !=== SUBROUTINE fliopv_i22 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_22=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_i22 !=== SUBROUTINE fliopv_i23 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_23=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_i23 !=== SUBROUTINE fliopv_i24 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_24=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_i24 !=== SUBROUTINE fliopv_i25 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,i_25=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_i25 !=== !?INTEGERS of KIND 1 are not supported on all computers !?SUBROUTINE fliopv_i10 (f_i,v_n,v_v,start) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),INTENT(IN) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start !?!--------------------------------------------------------------------- !? CALL flio_upv (f_i,v_n,i_10=v_v,start=start) !?!------------------------ !?END SUBROUTINE fliopv_i10 !?!=== !?SUBROUTINE fliopv_i11 (f_i,v_n,v_v,start,count) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),DIMENSION(:),INTENT(IN) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !?!--------------------------------------------------------------------- !? CALL flio_upv (f_i,v_n,i_11=v_v,start=start,count=count) !?!------------------------ !?END SUBROUTINE fliopv_i11 !?!=== !?SUBROUTINE fliopv_i12 (f_i,v_n,v_v,start,count) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(IN) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !?!--------------------------------------------------------------------- !? CALL flio_upv (f_i,v_n,i_12=v_v,start=start,count=count) !?!------------------------ !?END SUBROUTINE fliopv_i12 !?!=== !?SUBROUTINE fliopv_i13 (f_i,v_n,v_v,start,count) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(IN) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !?!--------------------------------------------------------------------- !? CALL flio_upv (f_i,v_n,i_13=v_v,start=start,count=count) !?!------------------------ !?END SUBROUTINE fliopv_i13 !?!=== !?SUBROUTINE fliopv_i14 (f_i,v_n,v_v,start,count) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(IN) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !?!--------------------------------------------------------------------- !? CALL flio_upv (f_i,v_n,i_14=v_v,start=start,count=count) !?!------------------------ !?END SUBROUTINE fliopv_i14 !?!=== !?SUBROUTINE fliopv_i15 (f_i,v_n,v_v,start,count) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !?!--------------------------------------------------------------------- !? CALL flio_upv (f_i,v_n,i_15=v_v,start=start,count=count) !?!------------------------ !?END SUBROUTINE fliopv_i15 !=== SUBROUTINE fliopv_r40 (f_i,v_n,v_v,start) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_40=v_v,start=start) !------------------------ END SUBROUTINE fliopv_r40 !=== SUBROUTINE fliopv_r41 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),DIMENSION(:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_41=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_r41 !=== SUBROUTINE fliopv_r42 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),DIMENSION(:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_42=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_r42 !=== SUBROUTINE fliopv_r43 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_43=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_r43 !=== SUBROUTINE fliopv_r44 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_44=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_r44 !=== SUBROUTINE fliopv_r45 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_45=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_r45 !=== SUBROUTINE fliopv_r80 (f_i,v_n,v_v,start) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_80=v_v,start=start) !------------------------ END SUBROUTINE fliopv_r80 !=== SUBROUTINE fliopv_r81 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),DIMENSION(:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_81=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_r81 !=== SUBROUTINE fliopv_r82 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),DIMENSION(:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_82=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_r82 !=== SUBROUTINE fliopv_r83 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_83=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_r83 !=== SUBROUTINE fliopv_r84 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_84=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_r84 !=== SUBROUTINE fliopv_r85 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_upv (f_i,v_n,r_85=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliopv_r85 !=== SUBROUTINE flio_upv & & (f_i,v_n, & & i_40,i_41,i_42,i_43,i_44,i_45, & & i_20,i_21,i_22,i_23,i_24,i_25, & !? & i_10,i_11,i_12,i_13,i_14,i_15, & & r_40,r_41,r_42,r_43,r_44,r_45, & & r_80,r_81,r_82,r_83,r_84,r_85, & & start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),INTENT(IN),OPTIONAL :: i_40 INTEGER(KIND=i_4),DIMENSION(:),INTENT(IN),OPTIONAL :: i_41 INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_42 INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_43 INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_44 INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_45 INTEGER(KIND=i_2),INTENT(IN),OPTIONAL :: i_20 INTEGER(KIND=i_2),DIMENSION(:),INTENT(IN),OPTIONAL :: i_21 INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_22 INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_23 INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_24 INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_25 !?INTEGERS of KIND 1 are not supported on all computers !?INTEGER(KIND=i_1),INTENT(IN),OPTIONAL :: i_10 !?INTEGER(KIND=i_1),DIMENSION(:),INTENT(IN),OPTIONAL :: i_11 !?INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_12 !?INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_13 !?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_14 !?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_15 REAL(KIND=r_4),INTENT(IN),OPTIONAL :: r_40 REAL(KIND=r_4),DIMENSION(:),INTENT(IN),OPTIONAL :: r_41 REAL(KIND=r_4),DIMENSION(:,:),INTENT(IN),OPTIONAL :: r_42 REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: r_43 REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: r_44 REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: r_45 REAL(KIND=r_8),INTENT(IN),OPTIONAL :: r_80 REAL(KIND=r_8),DIMENSION(:),INTENT(IN),OPTIONAL :: r_81 REAL(KIND=r_8),DIMENSION(:,:),INTENT(IN),OPTIONAL :: r_82 REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: r_83 REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: r_84 REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: r_85 INTEGER,DIMENSION(:),INTENT(IN),OPTIONAL :: start,count !- INTEGER :: f_e,i_v,i_rc CHARACTER(LEN=5) :: cvr_d !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN IF (PRESENT(i_40)) THEN; cvr_d = "I1 0D"; ELSE IF (PRESENT(i_41)) THEN; cvr_d = "I1 1D"; ELSE IF (PRESENT(i_42)) THEN; cvr_d = "I1 2D"; ELSE IF (PRESENT(i_43)) THEN; cvr_d = "I1 3D"; ELSE IF (PRESENT(i_44)) THEN; cvr_d = "I1 4D"; ELSE IF (PRESENT(i_45)) THEN; cvr_d = "I1 5D"; ELSE IF (PRESENT(i_20)) THEN; cvr_d = "I2 0D"; ELSE IF (PRESENT(i_21)) THEN; cvr_d = "I2 1D"; ELSE IF (PRESENT(i_22)) THEN; cvr_d = "I2 2D"; ELSE IF (PRESENT(i_23)) THEN; cvr_d = "I2 3D"; ELSE IF (PRESENT(i_24)) THEN; cvr_d = "I2 4D"; ELSE IF (PRESENT(i_25)) THEN; cvr_d = "I2 5D"; !? ELSE IF (PRESENT(i_10)) THEN; cvr_d = "I4 0D"; !? ELSE IF (PRESENT(i_11)) THEN; cvr_d = "I4 1D"; !? ELSE IF (PRESENT(i_12)) THEN; cvr_d = "I4 2D"; !? ELSE IF (PRESENT(i_13)) THEN; cvr_d = "I4 3D"; !? ELSE IF (PRESENT(i_14)) THEN; cvr_d = "I4 4D"; !? ELSE IF (PRESENT(i_15)) THEN; cvr_d = "I4 5D"; ELSE IF (PRESENT(r_40)) THEN; cvr_d = "R4 0D"; ELSE IF (PRESENT(r_41)) THEN; cvr_d = "R4 1D"; ELSE IF (PRESENT(r_42)) THEN; cvr_d = "R4 2D"; ELSE IF (PRESENT(r_43)) THEN; cvr_d = "R4 3D"; ELSE IF (PRESENT(r_44)) THEN; cvr_d = "R4 4D"; ELSE IF (PRESENT(r_45)) THEN; cvr_d = "R4 5D"; ELSE IF (PRESENT(r_80)) THEN; cvr_d = "R8 0D"; ELSE IF (PRESENT(r_81)) THEN; cvr_d = "R8 1D"; ELSE IF (PRESENT(r_82)) THEN; cvr_d = "R8 2D"; ELSE IF (PRESENT(r_83)) THEN; cvr_d = "R8 3D"; ELSE IF (PRESENT(r_84)) THEN; cvr_d = "R8 4D"; ELSE IF (PRESENT(r_85)) THEN; cvr_d = "R8 5D"; ENDIF WRITE(*,*) "->flioputv ",TRIM(v_n)," ",TRIM(cvr_d) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('flioputv',f_i,f_e) !- ! Ensuring data mode !- CALL flio_hdm (f_i,f_e,.FALSE.) !- i_rc = NF90_INQ_VARID(f_e,v_n,i_v) IF (i_rc == NF90_NOERR) THEN IF (PRESENT(i_40)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_40,start=start) ELSE IF (PRESENT(i_41)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_41,start=start,count=count) ELSE IF (PRESENT(i_42)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_42,start=start,count=count) ELSE IF (PRESENT(i_43)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_43,start=start,count=count) ELSE IF (PRESENT(i_44)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_44,start=start,count=count) ELSE IF (PRESENT(i_45)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_45,start=start,count=count) ELSE IF (PRESENT(i_20)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_20,start=start) ELSE IF (PRESENT(i_21)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_21,start=start,count=count) ELSE IF (PRESENT(i_22)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_22,start=start,count=count) ELSE IF (PRESENT(i_23)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_23,start=start,count=count) ELSE IF (PRESENT(i_24)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_24,start=start,count=count) ELSE IF (PRESENT(i_25)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,i_25,start=start,count=count) !? ELSE IF (PRESENT(i_10)) THEN !? i_rc = NF90_PUT_VAR(f_e,i_v,i_10,start=start) !? ELSE IF (PRESENT(i_11)) THEN !? i_rc = NF90_PUT_VAR(f_e,i_v,i_11,start=start,count=count) !? ELSE IF (PRESENT(i_12)) THEN !? i_rc = NF90_PUT_VAR(f_e,i_v,i_12,start=start,count=count) !? ELSE IF (PRESENT(i_13)) THEN !? i_rc = NF90_PUT_VAR(f_e,i_v,i_13,start=start,count=count) !? ELSE IF (PRESENT(i_14)) THEN !? i_rc = NF90_PUT_VAR(f_e,i_v,i_14,start=start,count=count) !? ELSE IF (PRESENT(i_15)) THEN !? i_rc = NF90_PUT_VAR(f_e,i_v,i_15,start=start,count=count) ELSE IF (PRESENT(r_40)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_40,start=start) ELSE IF (PRESENT(r_41)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_41,start=start,count=count) ELSE IF (PRESENT(r_42)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_42,start=start,count=count) ELSE IF (PRESENT(r_43)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_43,start=start,count=count) ELSE IF (PRESENT(r_44)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_44,start=start,count=count) ELSE IF (PRESENT(r_45)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_45,start=start,count=count) ELSE IF (PRESENT(r_80)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_80,start=start) ELSE IF (PRESENT(r_81)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_81,start=start,count=count) ELSE IF (PRESENT(r_82)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_82,start=start,count=count) ELSE IF (PRESENT(r_83)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_83,start=start,count=count) ELSE IF (PRESENT(r_84)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_84,start=start,count=count) ELSE IF (PRESENT(r_85)) THEN i_rc = NF90_PUT_VAR(f_e,i_v,r_85,start=start,count=count) ENDIF IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'flioputv', & & 'Variable '//TRIM(v_n)//' not put','Error :', & & TRIM(NF90_STRERROR(i_rc))) ENDIF ELSE CALL ipslerr (3,'flioputv','Variable',TRIM(v_n),'not defined') ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-flioputv" ENDIF !---------------------- END SUBROUTINE flio_upv !=== SUBROUTINE fliopa_r4_0d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n REAL(KIND=4),INTENT(IN) :: a_v !--------------------------------------------------------------------- CALL flio_upa (f_i,1,v_n,a_n,avr4=(/a_v/)) !-------------------------- END SUBROUTINE fliopa_r4_0d !=== SUBROUTINE fliopa_r4_1d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n REAL(KIND=4),DIMENSION(:),INTENT(IN) :: a_v !--------------------------------------------------------------------- CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avr4=a_v) !-------------------------- END SUBROUTINE fliopa_r4_1d !=== SUBROUTINE fliopa_r8_0d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n REAL(KIND=8),INTENT(IN) :: a_v !--------------------------------------------------------------------- CALL flio_upa (f_i,1,v_n,a_n,avr8=(/a_v/)) !-------------------------- END SUBROUTINE fliopa_r8_0d !=== SUBROUTINE fliopa_r8_1d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n REAL(KIND=8),DIMENSION(:),INTENT(IN) :: a_v !--------------------------------------------------------------------- CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avr8=a_v) !-------------------------- END SUBROUTINE fliopa_r8_1d !=== SUBROUTINE fliopa_i4_0d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n INTEGER(KIND=4),INTENT(IN) :: a_v !--------------------------------------------------------------------- CALL flio_upa (f_i,1,v_n,a_n,avi4=(/a_v/)) !-------------------------- END SUBROUTINE fliopa_i4_0d !=== SUBROUTINE fliopa_i4_1d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n INTEGER(KIND=4),DIMENSION(:),INTENT(IN) :: a_v !--------------------------------------------------------------------- CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avi4=a_v) !-------------------------- END SUBROUTINE fliopa_i4_1d !=== SUBROUTINE fliopa_tx_0d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n CHARACTER(LEN=*),INTENT(IN) :: a_v !--------------------------------------------------------------------- CALL flio_upa (f_i,1,v_n,a_n,avtx=a_v) !-------------------------- END SUBROUTINE fliopa_tx_0d !=== SUBROUTINE flio_upa (f_i,l_a,v_n,a_n,avr4,avr8,avi4,avtx) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i,l_a CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n REAL(KIND=4),DIMENSION(:),OPTIONAL,INTENT(IN) :: avr4 REAL(KIND=8),DIMENSION(:),OPTIONAL,INTENT(IN) :: avr8 INTEGER(KIND=4),DIMENSION(:),OPTIONAL,INTENT(IN) :: avi4 CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: avtx !- INTEGER :: f_e,i_v,i_a,i_rc !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->flioputa ",TRIM(v_n)," ",TRIM(a_n) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('flioputa',f_i,f_e) !- IF (TRIM(v_n) == '?') THEN i_v = NF90_GLOBAL ELSE i_rc = NF90_INQ_VARID(f_e,v_n,i_v) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'flioputa', & 'Variable :',TRIM(v_n),'not found') ENDIF ENDIF !- i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,attnum=i_a) IF ( (i_v == NF90_GLOBAL).AND.(i_rc /= NF90_NOERR) ) THEN nw_na(f_i) = nw_na(f_i)+1 ENDIF CALL flio_hdm (f_i,f_e,.TRUE.) IF (PRESENT(avr4)) THEN i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avr4(1:l_a)) ELSE IF (PRESENT(avr8)) THEN i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avr8(1:l_a)) ELSE IF (PRESENT(avi4)) THEN i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avi4(1:l_a)) ELSE IF (PRESENT(avtx)) THEN i_rc = NF90_PUT_ATT(f_e,i_v,a_n,TRIM(avtx)) ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-flioputa" ENDIF !---------------------- END SUBROUTINE flio_upa !=== SUBROUTINE flioopfd (f_n,f_i,mode,nb_dim,nb_var,nb_gat) !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*),INTENT(IN) :: f_n INTEGER,INTENT(OUT) :: f_i CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: mode INTEGER,OPTIONAL,INTENT(OUT) :: nb_dim,nb_var,nb_gat !- INTEGER :: i_rc,f_e,m_c !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) '->flioopfd, file name : ',TRIM(f_n) ENDIF !- ! Search for a free local identifier !- f_i = flio_rid() IF (f_i < 0) THEN CALL ipslerr (3,'flioopfd', & 'Too many files.','Please increase nb_fi_mx', & 'in module fliocom.f90.') ENDIF !- ! Check the mode !- IF (PRESENT(mode)) THEN IF (TRIM(mode) == "WRITE") THEN m_c = NF90_WRITE ELSE m_c = NF90_NOWRITE ENDIF ELSE m_c = NF90_NOWRITE ENDIF !- ! Open the file. !- i_rc = NF90_OPEN(TRIM(f_n),m_c,f_e) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'flioopfd', & & 'Could not open file :',TRIM(f_n), & & TRIM(NF90_STRERROR(i_rc))//' (Netcdf)') ENDIF !- IF (l_dbg) THEN WRITE(*,*) ' flioopfd, model file-id : ',f_e ENDIF !- ! Retrieve and keep information about the file !- nw_id(f_i) = f_e lw_hm(f_i) = .FALSE. CALL flio_inf (f_e, & & nb_dims=nw_nd(f_i),nb_vars=nw_nv(f_i), & & nb_atts=nw_na(f_i),id_unlm=nw_un(f_i), & & nn_idm=nw_di(:,f_i),nn_ldm=nw_dl(:,f_i),nn_aid=nw_ai(:,f_i)) !- ! Return information to the user !- IF (PRESENT(nb_dim)) THEN nb_dim = nw_nd(f_i) ENDIF IF (PRESENT(nb_var)) THEN nb_var = nw_nv(f_i) ENDIF IF (PRESENT(nb_gat)) THEN nb_gat = nw_na(f_i) ENDIF !- IF (l_dbg) THEN WRITE(*,'(" flioopfd - dimensions :",/,(5(1X,I10),:))') & & nw_dl(:,f_i) WRITE(*,*) "<-flioopfd" ENDIF !---------------------- END SUBROUTINE flioopfd !=== SUBROUTINE flioinqf & & (f_i,nb_dim,nb_var,nb_gat,id_uld,id_dim,ln_dim) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i INTEGER,OPTIONAL,INTENT(OUT) :: nb_dim,nb_var,nb_gat,id_uld INTEGER,OPTIONAL,INTENT(OUT),DIMENSION(:) :: id_dim,ln_dim !- INTEGER :: lll !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->flioinqf" ENDIF !- IF ( (f_i < 1).OR.(f_i > nb_fi_mx) ) THEN CALL ipslerr (2,'flioinqf', & & 'Invalid file identifier',' ',' ') ELSE IF (nw_id(f_i) <= 0) THEN CALL ipslerr (2,'flioinqf', & & 'Unable to inquire about the file :','probably','not opened') ELSE IF (PRESENT(nb_dim)) THEN nb_dim = nw_nd(f_i) ENDIF IF (PRESENT(nb_var)) THEN nb_var = nw_nv(f_i) ENDIF IF (PRESENT(nb_gat)) THEN nb_gat = nw_na(f_i) ENDIF IF (PRESENT(id_uld)) THEN id_uld = nw_un(f_i) ENDIF IF (PRESENT(id_dim)) THEN lll = SIZE(id_dim) IF (lll < nw_nd(f_i)) THEN CALL ipslerr (2,'flioinqf', & & 'Only the first identifiers', & & 'of the dimensions','will be returned') ENDIF lll=MIN(SIZE(id_dim),nw_nd(f_i)) id_dim(1:lll) = nw_di(1:lll,f_i) ENDIF IF (PRESENT(ln_dim)) THEN lll = SIZE(ln_dim) IF (lll < nw_nd(f_i)) THEN CALL ipslerr (2,'flioinqf', & & 'Only the first lengths', & & 'of the dimensions','will be returned') ENDIF lll=MIN(SIZE(ln_dim),nw_nd(f_i)) ln_dim(1:lll) = nw_dl(1:lll,f_i) ENDIF ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-flioinqf" ENDIF !---------------------- END SUBROUTINE flioinqf !=== SUBROUTINE flioinqn & & (f_i,cn_dim,cn_var,cn_gat,cn_uld, & & id_start,id_count,iv_start,iv_count,ia_start,ia_count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: & & cn_dim,cn_var,cn_gat CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: & & cn_uld INTEGER,OPTIONAL,INTENT(IN) :: & & id_start,id_count,iv_start,iv_count,ia_start,ia_count !- INTEGER :: f_e,i_s,i_w,iws,iwc,i_rc LOGICAL :: l_ok !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->flioinqn" ENDIF !- ! Retrieve the external file index CALL flio_qvid ('flioinqn',f_i,f_e) !- IF (PRESENT(cn_dim)) THEN l_ok = .TRUE. i_s = SIZE(cn_dim) DO i_w=1,i_s cn_dim(i_w)(:) = '?' ENDDO IF (PRESENT(id_start)) THEN iws = id_start ELSE iws = 1 ENDIF IF (PRESENT(id_count)) THEN iwc = id_count ELSE iwc = nw_nd(f_i) ENDIF IF (iws > nw_nd(f_i)) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqn', & & 'The start index of requested dimensions', & & 'is greater than the number of dimensions', & & 'in the file') ELSE IF (iws < 1) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqn', & & 'The start index of requested dimensions', & & 'is invalid', & & '( < 1 )') ENDIF IF ((iws+iwc-1) > nw_nd(f_i)) THEN CALL ipslerr (2,'flioinqn', & & 'The number of requested dimensions', & & 'is greater than the number of dimensions', & & 'in the file') ENDIF IF (iwc > i_s) THEN CALL ipslerr (2,'flioinqn', & & 'The number of dimensions to retrieve', & & 'is greater than the size of the array,', & & 'only the first dimensions of the file will be returned') ELSE IF (iwc < 1) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqn', & & 'The number of requested dimensions', & & 'is invalid', & & '( < 1 )') ENDIF IF (l_ok) THEN DO i_w=1,MIN(iwc,i_s,nw_nd(f_i)-iws+1) i_rc = NF90_INQUIRE_DIMENSION(f_e,i_w+iws-1,name=cn_dim(i_w)) ENDDO ENDIF ENDIF !- IF (PRESENT(cn_var)) THEN l_ok = .TRUE. i_s = SIZE(cn_var) DO i_w=1,i_s cn_var(i_w)(:) = '?' ENDDO IF (PRESENT(iv_start)) THEN iws = iv_start ELSE iws = 1 ENDIF IF (PRESENT(iv_count)) THEN iwc = iv_count ELSE iwc = nw_nv(f_i) ENDIF IF (iws > nw_nv(f_i)) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqn', & & 'The start index of requested variables', & & 'is greater than the number of variables', & & 'in the file') ELSE IF (iws < 1) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqn', & & 'The start index of requested variables', & & 'is invalid', & & '( < 1 )') ENDIF IF ((iws+iwc-1) > nw_nv(f_i)) THEN CALL ipslerr (2,'flioinqn', & & 'The number of requested variables', & & 'is greater than the number of variables', & & 'in the file') ENDIF IF (iwc > i_s) THEN CALL ipslerr (2,'flioinqn', & & 'The number of variables to retrieve', & & 'is greater than the size of the array,', & & 'only the first variables of the file will be returned') ELSE IF (iwc < 1) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqn', & & 'The number of requested variables', & & 'is invalid', & & '( < 1 )') ENDIF IF (l_ok) THEN DO i_w=1,MIN(iwc,i_s,nw_nv(f_i)-iws+1) i_rc = NF90_INQUIRE_VARIABLE(f_e,i_w+iws-1,name=cn_var(i_w)) ENDDO ENDIF ENDIF !- IF (PRESENT(cn_gat)) THEN l_ok = .TRUE. i_s = SIZE(cn_gat) DO i_w=1,i_s cn_gat(i_w)(:) = '?' ENDDO IF (PRESENT(ia_start)) THEN iws = ia_start ELSE iws = 1 ENDIF IF (PRESENT(ia_count)) THEN iwc = ia_count ELSE iwc = nw_na(f_i) ENDIF IF (iws > nw_na(f_i)) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqn', & & 'The start index of requested global attributes', & & 'is greater than the number of global attributes', & & 'in the file') ELSE IF (iws < 1) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqn', & & 'The start index of requested global attributes', & & 'is invalid', & & '( < 1 )') ENDIF IF ((iws+iwc-1) > nw_na(f_i)) THEN CALL ipslerr (2,'flioinqn', & & 'The number of requested global attributes', & & 'is greater than the number of global attributes', & & 'in the file') ENDIF IF (iwc > i_s) THEN CALL ipslerr (2,'flioinqn', & & 'The number of global attributes to retrieve', & & 'is greater than the size of the array,', & & 'only the first global attributes of the file will be returned') ELSE IF (iwc < 1) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqn', & & 'The number of requested global attributes', & & 'is invalid', & & '( < 1 )') ENDIF IF (l_ok) THEN DO i_w=1,MIN(iwc,i_s,nw_na(f_i)-iws+1) i_rc = NF90_INQ_ATTNAME(f_e, & & NF90_GLOBAL,i_w+iws-1,name=cn_gat(i_w)) ENDDO ENDIF ENDIF !- IF (PRESENT(cn_uld)) THEN cn_uld = '?' IF (nw_un(f_i) > 0) THEN i_rc = NF90_INQUIRE_DIMENSION(f_e,nw_un(f_i),name=cn_uld) ENDIF ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-flioinqn" ENDIF !---------------------- END SUBROUTINE flioinqn !=== SUBROUTINE fliogstc & & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & & t_axis,t_init,t_step,t_calendar, & & x_start,x_count,y_start,y_count, & & z_start,z_count,t_start,t_count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i REAL,DIMENSION(:),OPTIONAL,INTENT(OUT) :: x_axis,y_axis REAL,DIMENSION(:,:),OPTIONAL,INTENT(OUT) :: x_axis_2d,y_axis_2d REAL,DIMENSION(:),OPTIONAL,INTENT(OUT) :: z_axis INTEGER,DIMENSION(:),OPTIONAL,INTENT(OUT) :: t_axis REAL,OPTIONAL,INTENT(OUT) :: t_init,t_step CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: t_calendar INTEGER,OPTIONAL,INTENT(IN) :: & & x_start,x_count,y_start,y_count,z_start,z_count,t_start,t_count !- INTEGER :: i_rc,f_e,i_v,it_t,nbdim,kv INTEGER :: m_x,i_x,l_x,m_y,i_y,l_y,m_z,i_z,l_z,m_t,i_t,l_t CHARACTER(LEN=NF90_MAX_NAME) :: name CHARACTER(LEN=80) :: units CHARACTER(LEN=20) :: c_tmp CHARACTER(LEN=1) :: c_1 REAL :: r_yy,r_mo,r_dd,r_ss,dtv,dtn INTEGER :: j_yy,j_mo,j_dd,j_hh,j_mn,j_ss LOGICAL :: l_ok,l_tmp !- REAL,DIMENSION(:),ALLOCATABLE :: v_tmp !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->fliogstc" ENDIF !- ! Retrieve the external file index CALL flio_qvid ('fliogstc',f_i,f_e) !- ! Validate the coherence of the arguments !- IF ( (PRESENT(x_axis).AND.PRESENT(x_axis_2d)) & & .OR.(PRESENT(y_axis).AND.PRESENT(y_axis_2d)) ) THEN CALL ipslerr (3,'fliogstc', & & 'The [x/y]_axis arguments', & & 'are not coherent :',& & 'can not handle two [x/y]_axis') ENDIF !- ! Retrieve spatio-temporal dimensions !- IF (nw_ai(k_lon,f_i) > 0) THEN m_x = nw_dl(nw_ai(k_lon,f_i),f_i); ELSE m_x = -1; ENDIF IF (nw_ai(k_lat,f_i) > 0) THEN m_y = nw_dl(nw_ai(k_lat,f_i),f_i); ELSE m_y = -1; ENDIF IF (nw_ai(k_lev,f_i) > 0) THEN m_z = nw_dl(nw_ai(k_lev,f_i),f_i); ELSE m_z = -1; ENDIF IF (nw_ai(k_tim,f_i) > 0) THEN m_t = nw_dl(nw_ai(k_tim,f_i),f_i); ELSE m_t = -1; ENDIF !- IF (l_dbg) THEN WRITE(*,'(" fliogstc - dimensions :",/,(5(1X,I10),:))') & & m_x,m_y,m_z,m_t ENDIF !- ! Initialize the x-y indices !- IF ( PRESENT(x_axis) & & .OR.PRESENT(x_axis_2d) & & .OR.PRESENT(y_axis_2d) ) THEN IF (PRESENT(x_start)) THEN i_x = x_start ELSE i_x = 1 ENDIF IF (PRESENT(x_count)) THEN l_x = x_count ELSE l_x = m_x-i_x+1 ENDIF ENDIF IF ( PRESENT(y_axis) & & .OR.PRESENT(y_axis_2d) & & .OR.PRESENT(x_axis_2d) ) THEN IF (PRESENT(y_start)) THEN i_y = y_start ELSE i_y = 1 ENDIF IF (PRESENT(y_count)) THEN l_y = y_count ELSE l_y = m_y-i_y+1 ENDIF ENDIF IF (PRESENT(x_axis)) THEN IF (m_x <= 0) THEN CALL ipslerr (3,'fliogstc', & & 'Requested x_axis', & & 'but the coordinate is not present','in the file') ELSE IF ((i_x+l_x-1) > m_x) THEN CALL ipslerr (3,'fliogstc', & & 'The requested size for the x_axis', & & 'is greater than the size of the coordinate','in the file') ENDIF ENDIF IF (PRESENT(y_axis)) THEN IF (m_y <= 0) THEN CALL ipslerr (3,'fliogstc', & & 'Requested y_axis', & & 'but the coordinate is not present','in the file') ELSE IF ((i_y+l_y-1) > m_y) THEN CALL ipslerr (3,'fliogstc', & & 'The requested size for the y_axis', & & 'is greater than the size of the coordinate','in the file') ENDIF ENDIF IF (PRESENT(x_axis_2d).OR.PRESENT(y_axis_2d) )THEN IF ( (m_x <= 0).OR.(m_y <= 0) ) THEN CALL ipslerr (3,'fliogstc', & & 'Requested [x/y]_axis_2d', & & 'but the coordinates are not iboth present','in the file') ELSE IF ( ((i_x+l_x-1) > m_x).OR.((i_y+l_y-1) > m_y) ) THEN CALL ipslerr (3,'fliogstc', & & 'The requested size for the [x/y]_axis_2d', & & 'is greater than the size of the coordinate','in the file') ENDIF ENDIF !- ! Ensuring data mode !- CALL flio_hdm (f_i,f_e,.FALSE.) !- ! Extracting the x coordinate, if needed !- IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN CALL flio_qax (f_i,'x',i_v,nbdim) IF (i_v > 0) THEN IF (nbdim == 1) THEN IF (PRESENT(x_axis)) THEN i_rc = NF90_GET_VAR(f_e,i_v,x_axis, & & start=(/i_x/),count=(/l_x/)) ELSE ALLOCATE(v_tmp(l_x)) i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & & start=(/i_x/),count=(/l_x/)) DO kv=1,l_y x_axis_2d(:,kv) = v_tmp(:) ENDDO DEALLOCATE(v_tmp) ENDIF ELSE IF (nbdim == 2) THEN IF (PRESENT(x_axis)) THEN l_ok = .TRUE. IF (l_y > 1) THEN ALLOCATE(v_tmp(l_y)) DO kv=i_x,i_x+l_x-1 i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & & start=(/kv,i_y/),count=(/1,l_y/)) IF (ANY(v_tmp(2:l_y) /= v_tmp(1))) THEN l_ok = .FALSE. EXIT ENDIF ENDDO DEALLOCATE(v_tmp) ENDIF IF (l_ok) THEN i_rc = NF90_GET_VAR(f_e,i_v,x_axis, & & start=(/i_x,i_y/),count=(/l_x,1/)) ELSE CALL ipslerr (3,'fliogstc', & & 'Requested 1D x_axis', & & 'which have 2 not regular dimensions', & & 'in the file') ENDIF ELSE i_rc = NF90_GET_VAR(f_e,i_v,x_axis_2d, & & start=(/i_x,i_y/),count=(/l_x,l_y/)) ENDIF ELSE CALL ipslerr (3,'fliogstc', & & 'Can not handle x_axis', & & 'that have more than 2 dimensions', & & 'in the file') ENDIF ELSE CALL ipslerr (3,'fliogstc','No x_axis found','in the file',' ') ENDIF ENDIF !- ! Extracting the y coordinate, if needed !- IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN CALL flio_qax (f_i,'y',i_v,nbdim) IF (i_v > 0) THEN IF (nbdim == 1) THEN IF (PRESENT(y_axis)) THEN i_rc = NF90_GET_VAR(f_e,i_v,y_axis, & & start=(/i_y/),count=(/l_y/)) ELSE ALLOCATE(v_tmp(l_y)) i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & & start=(/i_y/),count=(/l_y/)) DO kv=1,l_x y_axis_2d(kv,:) = v_tmp(:) ENDDO DEALLOCATE(v_tmp) ENDIF ELSE IF (nbdim == 2) THEN IF (PRESENT(y_axis)) THEN l_ok = .TRUE. IF (l_x > 1) THEN ALLOCATE(v_tmp(l_x)) DO kv=i_y,i_y+l_y-1 i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & & start=(/i_x,kv/),count=(/l_x,1/)) IF (ANY(v_tmp(2:l_x) /= v_tmp(1))) THEN l_ok = .FALSE. EXIT ENDIF ENDDO DEALLOCATE(v_tmp) ENDIF IF (l_ok) THEN i_rc = NF90_GET_VAR(f_e,i_v,y_axis, & & start=(/i_x,i_y/),count=(/1,l_y/)) ELSE CALL ipslerr (3,'fliogstc', & & 'Requested 1D y_axis', & & 'which have 2 not regular dimensions', & & 'in the file') ENDIF ELSE i_rc = NF90_GET_VAR(f_e,i_v,y_axis_2d, & & start=(/i_x,i_y/),count=(/l_x,l_y/)) ENDIF ELSE CALL ipslerr (3,'fliogstc', & & 'Can not handle y axis', & & 'that have more than 2 dimensions', & & 'in the file') ENDIF ELSE CALL ipslerr (3,'fliogstc','No y_axis found','in the file',' ') ENDIF ENDIF !- ! Extracting the z coordinate, if needed !- IF (PRESENT(z_axis)) THEN IF (PRESENT(z_start)) THEN i_z = z_start ELSE i_z = 1 ENDIF IF (PRESENT(z_count)) THEN l_z = z_count ELSE l_z = m_z-i_z+1 ENDIF IF ((i_z+l_z-1) > m_z) THEN CALL ipslerr (3,'fliogstc', & & 'The requested size for the z axis', & & 'is greater than the size of the coordinate',& & 'in the file') ENDIF CALL flio_qax (f_i,'z',i_v,nbdim) IF (i_v > 0) THEN IF (nbdim == 1) THEN i_rc = NF90_GET_VAR(f_e,i_v,z_axis, & & start=(/i_z/),count=(/l_z/)) ELSE CALL ipslerr (3,'fliogstc', & & 'Can not handle z_axis', & & 'that have more than 1 dimension', & & 'in the file') ENDIF ELSE CALL ipslerr (3,'fliogstc','No z_axis found','in the file',' ') ENDIF ENDIF !- ! Extracting the t coordinate, if needed !- IF (PRESENT(t_axis).OR.PRESENT(t_init).OR.PRESENT(t_step)) THEN CALL flio_qax (f_i,'t',i_v,nbdim) IF (i_v < 0) THEN CALL ipslerr (3,'fliogstc','No t_axis found','in the file',' ') ENDIF !--- IF (l_dbg) THEN WRITE(*,*) ' fliogstc - get time details' ENDIF !--- !-- Get all the details for the time !-- Prefered method is '"time_steps" since' !--- name='' i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,name=name) units='' i_rc = NF90_GET_ATT(f_e,i_v,'units',units) IF (INDEX(units,' since ') > 0) THEN it_t = 1 ELSE IF (INDEX(name,'tstep') > 0) THEN it_t = 2 ELSE it_t = 0; ENDIF ENDIF !- ! Extracting the t coordinate, if needed !- IF (PRESENT(t_axis)) THEN IF (PRESENT(t_start)) THEN i_t = t_start ELSE i_t = 1 ENDIF IF (PRESENT(t_count)) THEN l_t = t_count ELSE l_t = m_t-i_t+1 ENDIF IF ((i_t+l_t-1) > m_t) THEN CALL ipslerr (3,'fliogstc', & & 'The requested size for the t axis', & & 'is greater than the size of the coordinate',& & 'in the file') ENDIF ALLOCATE(v_tmp(l_t)) i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & & start=(/i_t/),count=(/l_t/)) t_axis(1:l_t) = NINT(v_tmp(1:l_t)) DEALLOCATE(v_tmp) !--- IF (l_dbg) THEN WRITE(*,*) ' fliogstc - first time : ',t_axis(1:1) ENDIF ENDIF !- ! Extracting the time at the beginning, if needed !- IF (PRESENT(t_init)) THEN !-- Find the calendar CALL lock_calendar (old_status=l_tmp) CALL ioget_calendar (c_tmp) units = '' i_rc = NF90_GET_ATT(f_e,i_v,'calendar',units) IF (i_rc == NF90_NOERR) THEN CALL lock_calendar (new_status=.FALSE.) CALL ioconf_calendar (TRIM(units)) ENDIF IF (it_t == 1) THEN units = '' i_rc = NF90_GET_ATT(f_e,i_v,'units',units) units = units(INDEX(units,' since ')+7:LEN_TRIM(units)) READ (units,'(I4.4,5(A,I2.2))') & & j_yy,c_1,j_mo,c_1,j_dd,c_1,j_hh,c_1,j_mn,c_1,j_ss r_ss = j_hh*3600.+j_mn*60.+j_ss CALL ymds2ju (j_yy,j_mo,j_dd,r_ss,t_init) ELSE IF (it_t == 2) THEN i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'year0',r_yy) i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'month0',r_mo) i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'day0',r_dd) i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'sec0',r_ss) j_yy = NINT(r_yy); j_mo = NINT(r_mo); j_dd = NINT(r_dd); CALL ymds2ju (j_yy,j_mo,j_dd,r_ss,t_init) ELSE t_init = 0. ENDIF CALL lock_calendar (new_status=.FALSE.) CALL ioconf_calendar (TRIM(c_tmp)) CALL lock_calendar (new_status=l_tmp) IF (l_dbg) THEN WRITE(*,*) ' fliogstc - time_type : ' WRITE(*,*) it_t WRITE(*,*) ' fliogstc - year month day second t_init : ' WRITE(*,*) j_yy,j_mo,j_dd,r_ss,t_init ENDIF ENDIF !- ! Extracting the timestep in seconds, if needed !- IF (PRESENT(t_step)) THEN IF (it_t == 1) THEN units = '' i_rc = NF90_GET_ATT(f_e,i_v,'units',units) units = ADJUSTL(units(1:INDEX(units,' since ')-1)) dtn = 1. IF (INDEX(units,"week") /= 0) THEN kv = INDEX(units,"week") dtv = 604800. ELSE IF (INDEX(units,"day") /= 0) THEN kv = INDEX(units,"day") dtv = 86400. ELSE IF (INDEX(units,"h") /= 0) THEN kv = INDEX(units,"h") dtv = 3600. ELSE IF (INDEX(units,"min") /= 0) THEN kv = INDEX(units,"min") dtv = 60. ELSE IF (INDEX(units,"sec") /= 0) THEN kv = INDEX(units,"sec") dtv = 1. ELSE IF (INDEX(units,"timesteps") /= 0) THEN kv = INDEX(units,"timesteps") i_rc = NF90_GET_ATT(f_e,i_v,'tstep_sec',dtv) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliogstc','"timesteps" value', & & 'not found','in the file') ENDIF ELSE kv = 1 dtv = 1. ENDIF IF (kv > 1) THEN READ (unit=units(1:kv-1),FMT=*) dtn ENDIF t_step = dtn*dtv ELSE IF (it_t == 2) THEN i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'delta_tstep_sec',t_step) ELSE t_step = 1. ENDIF ENDIF !- ! Extracting the calendar attribute, if needed !- IF (PRESENT(t_calendar)) THEN units = '' i_rc = NF90_GET_ATT(f_e,i_v,'calendar',units) IF (i_rc == NF90_NOERR) THEN t_calendar = units ELSE t_calendar = "not found" ENDIF ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-fliogstc" ENDIF !---------------------- END SUBROUTINE fliogstc !=== SUBROUTINE flioinqv & & (f_i,v_n,l_ex,v_t,nb_dims,len_dims,id_dims, & & nb_atts,cn_atts,ia_start,ia_count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n LOGICAL,INTENT(OUT) :: l_ex INTEGER,OPTIONAL,INTENT(OUT) :: v_t,nb_dims,nb_atts INTEGER,OPTIONAL,INTENT(OUT),DIMENSION(:) :: len_dims,id_dims CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: cn_atts INTEGER,OPTIONAL,INTENT(IN) :: ia_start,ia_count !- INTEGER :: f_e,i_v,n_w,i_s,i_w,iws,iwc,i_rc LOGICAL :: l_ok INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: dim_ids !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->flioinqv ",TRIM(v_n) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('flioinqv',f_i,f_e) !- i_v = -1 i_rc = NF90_INQ_VARID(f_e,v_n,i_v) !- l_ex = ( (i_v >= 0).AND.(i_rc == NF90_NOERR) ) !- IF (l_ex) THEN IF (PRESENT(v_t)) THEN i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,xtype=v_t) ENDIF n_w = -1 IF (PRESENT(nb_dims).OR.PRESENT(len_dims)) THEN i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v, & & ndims=n_w,dimids=dim_ids) IF (PRESENT(nb_dims)) THEN nb_dims = n_w ENDIF IF (PRESENT(len_dims)) THEN i_s = SIZE(len_dims) len_dims(:) = -1 IF (i_s < n_w) THEN CALL ipslerr (2,'flioinqv', & & 'Only the first dimensions of the variable', & & TRIM(v_n),'will be returned') ENDIF DO i_w=1,MIN(n_w,i_s) i_rc = NF90_INQUIRE_DIMENSION(f_e,dim_ids(i_w), & & len=len_dims(i_w)) ENDDO ENDIF IF (PRESENT(id_dims)) THEN i_s = SIZE(id_dims) id_dims(:) = -1 IF (i_s < n_w) THEN CALL ipslerr (2,'flioinqv', & & 'The number of dimensions to retrieve', & & 'is greater than the size of the array,', & & 'only the first dimensions of "' & & //TRIM(v_n)//'" will be returned') ENDIF i_w = MIN(n_w,i_s) id_dims(1:i_w) = dim_ids(1:i_w) ENDIF ENDIF IF (PRESENT(nb_atts).OR.PRESENT(cn_atts)) THEN i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,nAtts=n_w) IF (PRESENT(nb_atts)) THEN nb_atts = n_w ENDIF IF (PRESENT(cn_atts)) THEN l_ok = .TRUE. i_s = SIZE(cn_atts) DO i_w=1,i_s cn_atts(i_w)(:) = '?' ENDDO IF (PRESENT(ia_start)) THEN iws = ia_start ELSE iws = 1 ENDIF IF (PRESENT(ia_count)) THEN iwc = ia_count ELSE iwc = n_w ENDIF IF (iws > n_w) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqv', & & 'The start index of requested attributes', & & 'is greater than the number of attributes of', & & '"'//TRIM(v_n)//'"') ELSE IF (iws < 1) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqv', & & 'The start index of requested attributes', & & 'is invalid ( < 1 ) for', & & '"'//TRIM(v_n)//'"') ENDIF IF ((iws+iwc-1) > n_w) THEN CALL ipslerr (2,'flioinqv', & & 'The number of requested attributes', & & 'is greater than the number of attributes of', & & '"'//TRIM(v_n)//'"') ENDIF IF (iwc > i_s) THEN CALL ipslerr (2,'flioinqv', & & 'The number of attributes to retrieve', & & 'is greater than the size of the array,', & & 'only the first attributes of "' & & //TRIM(v_n)//'" will be returned') ELSE IF (iwc < 1) THEN l_ok = .FALSE. CALL ipslerr (2,'flioinqv', & & 'The number of requested attributes', & & 'is invalid ( < 1 ) for', & & '"'//TRIM(v_n)//'"') ENDIF IF (l_ok) THEN DO i_w=1,MIN(iwc,i_s,n_w-iws+1) i_rc = NF90_INQ_ATTNAME(f_e, & & i_v,i_w+iws-1,name=cn_atts(i_w)) ENDDO ENDIF ENDIF ENDIF ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-flioinqv" ENDIF !---------------------- END SUBROUTINE flioinqv !=== SUBROUTINE fliogv_i40 (f_i,v_n,v_v,start) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_40=v_v,start=start) !------------------------ END SUBROUTINE fliogv_i40 !=== SUBROUTINE fliogv_i41 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),DIMENSION(:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_41=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_i41 !=== SUBROUTINE fliogv_i42 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_42=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_i42 !=== SUBROUTINE fliogv_i43 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_43=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_i43 !=== SUBROUTINE fliogv_i44 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_44=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_i44 !=== SUBROUTINE fliogv_i45 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_45=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_i45 !=== SUBROUTINE fliogv_i20 (f_i,v_n,v_v,start) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_20=v_v,start=start) !------------------------ END SUBROUTINE fliogv_i20 !=== SUBROUTINE fliogv_i21 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),DIMENSION(:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_21=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_i21 !=== SUBROUTINE fliogv_i22 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_22=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_i22 !=== SUBROUTINE fliogv_i23 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_23=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_i23 !=== SUBROUTINE fliogv_i24 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_24=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_i24 !=== SUBROUTINE fliogv_i25 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,i_25=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_i25 !=== !?INTEGERS of KIND 1 are not supported on all computers !?SUBROUTINE fliogv_i10 (f_i,v_n,v_v,start) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),INTENT(OUT) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start !?!--------------------------------------------------------------------- !? CALL flio_ugv (f_i,v_n,i_10=v_v,start=start) !?!------------------------ !?END SUBROUTINE fliogv_i10 !?!=== !?SUBROUTINE fliogv_i11 (f_i,v_n,v_v,start,count) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),DIMENSION(:),INTENT(OUT) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !?!--------------------------------------------------------------------- !? CALL flio_ugv (f_i,v_n,i_11=v_v,start=start,count=count) !?!------------------------ !?END SUBROUTINE fliogv_i11 !?!=== !?SUBROUTINE fliogv_i12 (f_i,v_n,v_v,start,count) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(OUT) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !?!--------------------------------------------------------------------- !? CALL flio_ugv (f_i,v_n,i_12=v_v,start=start,count=count) !?!------------------------ !?END SUBROUTINE fliogv_i12 !?!=== !?SUBROUTINE fliogv_i13 (f_i,v_n,v_v,start,count) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(OUT) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !?!--------------------------------------------------------------------- !? CALL flio_ugv (f_i,v_n,i_13=v_v,start=start,count=count) !?!------------------------ !?END SUBROUTINE fliogv_i13 !?!=== !?SUBROUTINE fliogv_i14 (f_i,v_n,v_v,start,count) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !?!--------------------------------------------------------------------- !? CALL flio_ugv (f_i,v_n,i_14=v_v,start=start,count=count) !?!------------------------ !?END SUBROUTINE fliogv_i14 !?!=== !?SUBROUTINE fliogv_i15 (f_i,v_n,v_v,start,count) !?!--------------------------------------------------------------------- !? IMPLICIT NONE !?!- !? INTEGER,INTENT(IN) :: f_i !? CHARACTER(LEN=*),INTENT(IN) :: v_n !? INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v !? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !?!--------------------------------------------------------------------- !? CALL flio_ugv (f_i,v_n,i_15=v_v,start=start,count=count) !?!------------------------ !?END SUBROUTINE fliogv_i15 !=== SUBROUTINE fliogv_r40 (f_i,v_n,v_v,start) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_40=v_v,start=start) !------------------------ END SUBROUTINE fliogv_r40 !=== SUBROUTINE fliogv_r41 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),DIMENSION(:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_41=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_r41 !=== SUBROUTINE fliogv_r42 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),DIMENSION(:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_42=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_r42 !=== SUBROUTINE fliogv_r43 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_43=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_r43 !=== SUBROUTINE fliogv_r44 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_44=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_r44 !=== SUBROUTINE fliogv_r45 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_45=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_r45 !=== SUBROUTINE fliogv_r80 (f_i,v_n,v_v,start) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_80=v_v,start=start) !------------------------ END SUBROUTINE fliogv_r80 !=== SUBROUTINE fliogv_r81 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),DIMENSION(:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_81=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_r81 !=== SUBROUTINE fliogv_r82 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),DIMENSION(:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_82=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_r82 !=== SUBROUTINE fliogv_r83 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_83=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_r83 !=== SUBROUTINE fliogv_r84 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_84=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_r84 !=== SUBROUTINE fliogv_r85 (f_i,v_n,v_v,start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count !--------------------------------------------------------------------- CALL flio_ugv (f_i,v_n,r_85=v_v,start=start,count=count) !------------------------ END SUBROUTINE fliogv_r85 !=== SUBROUTINE flio_ugv & & (f_i,v_n, & & i_40,i_41,i_42,i_43,i_44,i_45, & & i_20,i_21,i_22,i_23,i_24,i_25, & !? & i_10,i_11,i_12,i_13,i_14,i_15, & & r_40,r_41,r_42,r_43,r_44,r_45, & & r_80,r_81,r_82,r_83,r_84,r_85, & & start,count) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n INTEGER(KIND=i_4),INTENT(OUT),OPTIONAL :: i_40 INTEGER(KIND=i_4),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_41 INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_42 INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_43 INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_44 INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_45 INTEGER(KIND=i_2),INTENT(OUT),OPTIONAL :: i_20 INTEGER(KIND=i_2),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_21 INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_22 INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_23 INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_24 INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_25 !?INTEGERS of KIND 1 are not supported on all computers !?INTEGER(KIND=i_1),INTENT(OUT),OPTIONAL :: i_10 !?INTEGER(KIND=i_1),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_11 !?INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_12 !?INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_13 !?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_14 !?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_15 REAL(KIND=r_4),INTENT(OUT),OPTIONAL :: r_40 REAL(KIND=r_4),DIMENSION(:),INTENT(OUT),OPTIONAL :: r_41 REAL(KIND=r_4),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: r_42 REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: r_43 REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: r_44 REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: r_45 REAL(KIND=r_8),INTENT(OUT),OPTIONAL :: r_80 REAL(KIND=r_8),DIMENSION(:),INTENT(OUT),OPTIONAL :: r_81 REAL(KIND=r_8),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: r_82 REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: r_83 REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: r_84 REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: r_85 INTEGER,DIMENSION(:),INTENT(IN),OPTIONAL :: start,count !- INTEGER :: f_e,i_v,i_rc CHARACTER(LEN=5) :: cvr_d !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN IF (PRESENT(i_40)) THEN; cvr_d = "I1 0D"; ELSE IF (PRESENT(i_41)) THEN; cvr_d = "I1 1D"; ELSE IF (PRESENT(i_42)) THEN; cvr_d = "I1 2D"; ELSE IF (PRESENT(i_43)) THEN; cvr_d = "I1 3D"; ELSE IF (PRESENT(i_44)) THEN; cvr_d = "I1 4D"; ELSE IF (PRESENT(i_45)) THEN; cvr_d = "I1 5D"; ELSE IF (PRESENT(i_20)) THEN; cvr_d = "I2 0D"; ELSE IF (PRESENT(i_21)) THEN; cvr_d = "I2 1D"; ELSE IF (PRESENT(i_22)) THEN; cvr_d = "I2 2D"; ELSE IF (PRESENT(i_23)) THEN; cvr_d = "I2 3D"; ELSE IF (PRESENT(i_24)) THEN; cvr_d = "I2 4D"; ELSE IF (PRESENT(i_25)) THEN; cvr_d = "I2 5D"; !? ELSE IF (PRESENT(i_10)) THEN; cvr_d = "I4 0D"; !? ELSE IF (PRESENT(i_11)) THEN; cvr_d = "I4 1D"; !? ELSE IF (PRESENT(i_12)) THEN; cvr_d = "I4 2D"; !? ELSE IF (PRESENT(i_13)) THEN; cvr_d = "I4 3D"; !? ELSE IF (PRESENT(i_14)) THEN; cvr_d = "I4 4D"; !? ELSE IF (PRESENT(i_15)) THEN; cvr_d = "I4 5D"; ELSE IF (PRESENT(r_40)) THEN; cvr_d = "R4 0D"; ELSE IF (PRESENT(r_41)) THEN; cvr_d = "R4 1D"; ELSE IF (PRESENT(r_42)) THEN; cvr_d = "R4 2D"; ELSE IF (PRESENT(r_43)) THEN; cvr_d = "R4 3D"; ELSE IF (PRESENT(r_44)) THEN; cvr_d = "R4 4D"; ELSE IF (PRESENT(r_45)) THEN; cvr_d = "R4 5D"; ELSE IF (PRESENT(r_80)) THEN; cvr_d = "R8 0D"; ELSE IF (PRESENT(r_81)) THEN; cvr_d = "R8 1D"; ELSE IF (PRESENT(r_82)) THEN; cvr_d = "R8 2D"; ELSE IF (PRESENT(r_83)) THEN; cvr_d = "R8 3D"; ELSE IF (PRESENT(r_84)) THEN; cvr_d = "R8 4D"; ELSE IF (PRESENT(r_85)) THEN; cvr_d = "R8 5D"; ENDIF WRITE(*,*) "->fliogetv ",TRIM(v_n)," ",TRIM(cvr_d) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('fliogetv',f_i,f_e) !- ! Ensuring data mode !- CALL flio_hdm (f_i,f_e,.FALSE.) !- i_rc = NF90_INQ_VARID(f_e,v_n,i_v) IF (i_rc == NF90_NOERR) THEN IF (PRESENT(i_40)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_40,start=start) ELSE IF (PRESENT(i_41)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_41,start=start,count=count) ELSE IF (PRESENT(i_42)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_42,start=start,count=count) ELSE IF (PRESENT(i_43)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_43,start=start,count=count) ELSE IF (PRESENT(i_44)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_44,start=start,count=count) ELSE IF (PRESENT(i_45)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_45,start=start,count=count) ELSE IF (PRESENT(i_20)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_20,start=start) ELSE IF (PRESENT(i_21)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_21,start=start,count=count) ELSE IF (PRESENT(i_22)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_22,start=start,count=count) ELSE IF (PRESENT(i_23)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_23,start=start,count=count) ELSE IF (PRESENT(i_24)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_24,start=start,count=count) ELSE IF (PRESENT(i_25)) THEN i_rc = NF90_GET_VAR(f_e,i_v,i_25,start=start,count=count) !? ELSE IF (PRESENT(i_10)) THEN !? i_rc = NF90_GET_VAR(f_e,i_v,i_10,start=start) !? ELSE IF (PRESENT(i_11)) THEN !? i_rc = NF90_GET_VAR(f_e,i_v,i_11,start=start,count=count) !? ELSE IF (PRESENT(i_12)) THEN !? i_rc = NF90_GET_VAR(f_e,i_v,i_12,start=start,count=count) !? ELSE IF (PRESENT(i_13)) THEN !? i_rc = NF90_GET_VAR(f_e,i_v,i_13,start=start,count=count) !? ELSE IF (PRESENT(i_14)) THEN !? i_rc = NF90_GET_VAR(f_e,i_v,i_14,start=start,count=count) !? ELSE IF (PRESENT(i_15)) THEN !? i_rc = NF90_GET_VAR(f_e,i_v,i_15,start=start,count=count) ELSE IF (PRESENT(r_40)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_40,start=start) ELSE IF (PRESENT(r_41)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_41,start=start,count=count) ELSE IF (PRESENT(r_42)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_42,start=start,count=count) ELSE IF (PRESENT(r_43)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_43,start=start,count=count) ELSE IF (PRESENT(r_44)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_44,start=start,count=count) ELSE IF (PRESENT(r_45)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_45,start=start,count=count) ELSE IF (PRESENT(r_80)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_80,start=start) ELSE IF (PRESENT(r_81)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_81,start=start,count=count) ELSE IF (PRESENT(r_82)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_82,start=start,count=count) ELSE IF (PRESENT(r_83)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_83,start=start,count=count) ELSE IF (PRESENT(r_84)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_84,start=start,count=count) ELSE IF (PRESENT(r_85)) THEN i_rc = NF90_GET_VAR(f_e,i_v,r_85,start=start,count=count) ENDIF IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliogetv', & & 'Variable '//TRIM(v_n)//' not get','Error :', & & TRIM(NF90_STRERROR(i_rc))) ENDIF ELSE CALL ipslerr (3,'fliogetv','Variable',TRIM(v_n),'not found') ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-fliogetv" ENDIF !---------------------- END SUBROUTINE flio_ugv !=== SUBROUTINE flioinqa (f_i,v_n,a_n,l_ex,a_t,a_l) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n LOGICAL,INTENT(OUT) :: l_ex INTEGER,OPTIONAL,INTENT(OUT) :: a_t,a_l !- INTEGER :: i_rc,f_e,i_v,t_ea,l_ea !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->flioinqa ",TRIM(v_n),"-",TRIM(a_n) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('flioinqa',f_i,f_e) !- IF (TRIM(v_n) == '?') THEN i_v = NF90_GLOBAL ELSE i_rc = NF90_INQ_VARID(f_e,v_n,i_v) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'flioinqa', & 'Variable :',TRIM(v_n),'not found') ENDIF ENDIF !- i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,xtype=t_ea,len=l_ea) !- l_ex = (i_rc == NF90_NOERR) !- IF (l_ex) THEN IF (PRESENT(a_t)) THEN a_t = t_ea ENDIF IF (PRESENT(a_l)) THEN a_l = l_ea ENDIF ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-flioinqa" ENDIF !---------------------- END SUBROUTINE flioinqa !=== SUBROUTINE flioga_r4_0d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n REAL(KIND=4),INTENT(OUT) :: a_v !--------------------------------------------------------------------- CALL flio_uga (f_i,v_n,a_n,avr_4_0=a_v) !--------------------------- END SUBROUTINE flioga_r4_0d !=== SUBROUTINE flioga_r4_1d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n REAL(KIND=4),DIMENSION(:),INTENT(OUT) :: a_v !--------------------------------------------------------------------- CALL flio_uga (f_i,v_n,a_n,avr_4_1=a_v) !-------------------------- END SUBROUTINE flioga_r4_1d !=== SUBROUTINE flioga_r8_0d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n REAL(KIND=8),INTENT(OUT) :: a_v !--------------------------------------------------------------------- CALL flio_uga (f_i,v_n,a_n,avr_8_0=a_v) !--------------------------- END SUBROUTINE flioga_r8_0d !=== SUBROUTINE flioga_r8_1d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n REAL(KIND=8),DIMENSION(:),INTENT(OUT) :: a_v !--------------------------------------------------------------------- CALL flio_uga (f_i,v_n,a_n,avr_8_1=a_v) !-------------------------- END SUBROUTINE flioga_r8_1d !=== SUBROUTINE flioga_i4_0d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n INTEGER(KIND=4),INTENT(OUT) :: a_v !--------------------------------------------------------------------- CALL flio_uga (f_i,v_n,a_n,avi_4_0=a_v) !--------------------------- END SUBROUTINE flioga_i4_0d !=== SUBROUTINE flioga_i4_1d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n INTEGER(KIND=4),DIMENSION(:),INTENT(OUT) :: a_v !--------------------------------------------------------------------- CALL flio_uga (f_i,v_n,a_n,avi_4_1=a_v) !-------------------------- END SUBROUTINE flioga_i4_1d !=== SUBROUTINE flioga_tx_0d (f_i,v_n,a_n,a_v) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n CHARACTER(LEN=*),INTENT(OUT) :: a_v !--------------------------------------------------------------------- CALL flio_uga (f_i,v_n,a_n,avtx=a_v) !--------------------------- END SUBROUTINE flioga_tx_0d !=== SUBROUTINE flio_uga & & (f_i,v_n,a_n, & & avr_4_0,avr_4_1,avr_8_0,avr_8_1,avi_4_0,avi_4_1,avtx) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n REAL(KIND=4),OPTIONAL,INTENT(OUT) :: avr_4_0 REAL(KIND=4),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avr_4_1 REAL(KIND=8),OPTIONAL,INTENT(OUT) :: avr_8_0 REAL(KIND=8),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avr_8_1 INTEGER(KIND=4),OPTIONAL,INTENT(OUT) :: avi_4_0 INTEGER(KIND=4),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avi_4_1 CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: avtx !- INTEGER :: f_e,l_ua,i_v,t_ea,l_ea,i_rc !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->fliogeta ",TRIM(v_n)," ",TRIM(a_n) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('fliogeta',f_i,f_e) !- IF (TRIM(v_n) == '?') THEN i_v = NF90_GLOBAL ELSE i_rc = NF90_INQ_VARID(f_e,v_n,i_v) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliogeta', & 'Variable :',TRIM(v_n),'not found') ENDIF ENDIF !- i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,xtype=t_ea,len=l_ea) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliogeta', & & 'Attribute :',TRIM(a_n),'not found') ENDIF !- IF ( (.NOT.PRESENT(avtx).AND.(t_ea == NF90_CHAR)) & & .OR.(PRESENT(avtx).AND.(t_ea /= NF90_CHAR)) ) THEN CALL ipslerr (3,'fliogeta', & & 'The external type of the attribute :',TRIM(a_n), & & 'is not compatible with the type of the argument') ENDIF !- IF (PRESENT(avr_4_1)) THEN l_ua = SIZE(avr_4_1) ELSE IF (PRESENT(avr_8_1)) THEN l_ua = SIZE(avr_8_1) ELSE IF (PRESENT(avi_4_1)) THEN l_ua = SIZE(avi_4_1) ELSE IF (PRESENT(avtx)) THEN l_ua = LEN(avtx) ELSE l_ua = 1 ENDIF !- IF (l_ua < l_ea) THEN CALL ipslerr (3,'fliogeta', & 'Insufficient size of the argument', & & 'to receive the values of the attribute :',TRIM(a_n)) ENDIF !- IF (PRESENT(avr_4_0)) THEN i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_4_0) ELSE IF (PRESENT(avr_4_1)) THEN i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_4_1(1:l_ea)) ELSE IF (PRESENT(avr_8_0)) THEN i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_8_0) ELSE IF (PRESENT(avr_8_1)) THEN i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_8_1(1:l_ea)) ELSE IF (PRESENT(avi_4_0)) THEN i_rc = NF90_GET_ATT(f_e,i_v,a_n,avi_4_0) ELSE IF (PRESENT(avi_4_1)) THEN i_rc = NF90_GET_ATT(f_e,i_v,a_n,avi_4_1(1:l_ea)) ELSE IF (PRESENT(avtx)) THEN i_rc = NF90_GET_ATT(f_e,i_v,a_n,avtx) ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-fliogeta" ENDIF !---------------------- END SUBROUTINE flio_uga !=== SUBROUTINE fliorenv (f_i,v_o_n,v_n_n) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_o_n,v_n_n !- INTEGER :: f_e,i_v,i_rc !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) & & "->fliorenv ",TRIM(v_o_n),"->",TRIM(v_n_n) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('fliorenv',f_i,f_e) !- i_rc = NF90_INQ_VARID(f_e,v_o_n,i_v) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (2,'fliorenv', & 'Variable :',TRIM(v_o_n),'not found') ELSE CALL flio_hdm (f_i,f_e,.TRUE.) i_rc = NF90_RENAME_VAR(f_e,i_v,v_n_n) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (2,'fliorenv', & 'Variable :',TRIM(v_o_n),'can not be renamed') ENDIF ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-fliorenv" ENDIF !---------------------- END SUBROUTINE fliorenv !=== SUBROUTINE fliorena (f_i,v_n,a_o_n,a_n_n) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_o_n,a_n_n !- INTEGER :: f_e,i_v,i_a,i_rc !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) & & "->fliorena ",TRIM(v_n),"-",TRIM(a_o_n),"->",TRIM(a_n_n) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('fliorena',f_i,f_e) !- IF (TRIM(v_n) == '?') THEN i_v = NF90_GLOBAL ELSE i_rc = NF90_INQ_VARID(f_e,v_n,i_v) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliorena', & 'Variable :',TRIM(v_n),'not found') ENDIF ENDIF !- i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_o_n,attnum=i_a) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (2,'fliorena', & 'Attribute :',TRIM(a_o_n),'not found') ELSE CALL flio_hdm (f_i,f_e,.TRUE.) i_rc = NF90_RENAME_ATT(f_e,i_v,a_o_n,a_n_n) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (2,'fliorena', & 'Attribute :',TRIM(a_o_n),'can not be renamed') ENDIF ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-fliorena" ENDIF !---------------------- END SUBROUTINE fliorena !=== SUBROUTINE fliodela (f_i,v_n,a_n) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n !- INTEGER :: f_e,i_v,i_a,i_rc !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->fliodela ",TRIM(v_n),"-",TRIM(a_n) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('fliodela',f_i,f_e) !- IF (TRIM(v_n) == '?') THEN i_v = NF90_GLOBAL ELSE i_rc = NF90_INQ_VARID(f_e,v_n,i_v) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliodela', & & 'Variable :',TRIM(v_n),'not found') ENDIF ENDIF !- i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,attnum=i_a) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (2,'fliodela', & & 'Attribute :',TRIM(a_n),'not found') ELSE IF (i_v == NF90_GLOBAL) THEN nw_na(f_i) = nw_na(f_i)-1 ENDIF CALL flio_hdm (f_i,f_e,.TRUE.) i_rc = NF90_DEL_ATT(f_e,i_v,a_n) ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-fliodela" ENDIF !---------------------- END SUBROUTINE fliodela !=== SUBROUTINE fliocpya (f_i_i,v_n_i,a_n,f_i_o,v_n_o) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i_i,f_i_o CHARACTER(LEN=*),INTENT(IN) :: v_n_i,a_n,v_n_o !- INTEGER :: f_e_i,f_e_o,i_v_i,i_v_o,i_a,i_rc !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->fliocpya - file",f_i_i,"-",TRIM(v_n_i),"-",TRIM(a_n) WRITE(*,*) " copied to file ",f_i_o,"-",TRIM(v_n_o) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('fliocpya',f_i_i,f_e_i) CALL flio_qvid ('fliocpya',f_i_o,f_e_o) !- IF (TRIM(v_n_i) == '?') THEN i_v_i = NF90_GLOBAL ELSE i_rc = NF90_INQ_VARID(f_e_i,v_n_i,i_v_i) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliocpya', & & 'Variable :',TRIM(v_n_i),'not found') ENDIF ENDIF !- IF (TRIM(v_n_o) == '?') THEN i_v_o = NF90_GLOBAL ELSE i_rc = NF90_INQ_VARID(f_e_o,v_n_o,i_v_o) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliocpya', & & 'Variable :',TRIM(v_n_o),'not found') ENDIF ENDIF !- i_rc = NF90_INQUIRE_ATTRIBUTE(f_e_i,i_v_i,a_n,attnum=i_a) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliocpya', & 'Attribute :',TRIM(a_n),'not found') ELSE i_rc = NF90_INQUIRE_ATTRIBUTE(f_e_o,i_v_o,a_n,attnum=i_a) IF ( (i_v_o == NF90_GLOBAL).AND.(i_rc /= NF90_NOERR) ) THEN nw_na(f_i_o) = nw_na(f_i_o)+1 ENDIF CALL flio_hdm (f_i_o,f_e_o,.TRUE.) i_rc = NF90_COPY_ATT(f_e_i,i_v_i,a_n,f_e_o,i_v_o) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliocpya', & & 'Attribute '//TRIM(a_n)//' not copied','Error :', & & TRIM(NF90_STRERROR(i_rc))) ENDIF ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-fliocpya" ENDIF !---------------------- END SUBROUTINE fliocpya !=== SUBROUTINE flioqstc (f_i,c_type,l_ex,c_name) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i CHARACTER(LEN=*),INTENT(IN) :: c_type LOGICAL,INTENT(OUT) :: l_ex CHARACTER(LEN=*),INTENT(OUT) :: c_name !- CHARACTER(LEN=1) :: c_ax INTEGER :: f_e,idc,ndc,i_rc !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->flioqstc ",TRIM(c_type) ENDIF !- ! Retrieve the external file index CALL flio_qvid ('flioqstc',f_i,f_e) !- c_ax = TRIM(c_type) IF ( (LEN_TRIM(c_type) == 1) & & .AND.( (c_ax == 'x').OR.(c_ax == 'y') & & .OR.(c_ax == 'z').OR.(c_ax == 't')) ) THEN CALL flio_qax (f_i,c_ax,idc,ndc) l_ex = (idc > 0) IF (l_ex) THEN i_rc = NF90_INQUIRE_VARIABLE(f_e,idc,name=c_name) ENDIF ELSE l_ex = .FALSE. CALL ipslerr (2,'flioqstc', & & 'The name of the coordinate,',TRIM(c_type),'is not valid') ENDIF !- IF (l_dbg) THEN WRITE(*,*) "<-flioqstc" ENDIF !---------------------- END SUBROUTINE flioqstc !=== SUBROUTINE fliosync (f_i) !--------------------------------------------------------------------- INTEGER,INTENT(in),OPTIONAL :: f_i !- INTEGER :: i_f,f_e,i_rc,i_s,i_e !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->fliosync" ENDIF !- IF (PRESENT(f_i)) THEN IF ( (f_i >= 1).AND.(f_i <= nb_fi_mx) ) THEN i_s = f_i i_e = f_i ELSE i_s = 1 i_e = 0 CALL ipslerr (2,'fliosync', & & 'Invalid file identifier',' ',' ') ENDIF ELSE i_s = 1 i_e = nb_fi_mx ENDIF !- ! Ensuring data mode !- CALL flio_hdm (f_i,f_e,.FALSE.) !- DO i_f=i_s,i_e f_e = nw_id(i_f) IF (f_e > 0) THEN IF (l_dbg) THEN WRITE(*,*) ' fliosync - synchronising file number ',i_f ENDIF i_rc = NF90_SYNC(f_e) ELSE IF (PRESENT(f_i)) THEN CALL ipslerr (2,'fliosync', & & 'Unable to synchronise the file :','probably','not opened') ENDIF ENDDO !- IF (l_dbg) THEN WRITE(*,*) "<-fliosync" ENDIF !---------------------- END SUBROUTINE fliosync !=== SUBROUTINE flioclo (f_i) !--------------------------------------------------------------------- INTEGER,INTENT(in),OPTIONAL :: f_i !- INTEGER :: i_f,f_e,i_rc,i_s,i_e !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->flioclo" ENDIF !- IF (PRESENT(f_i)) THEN IF ( (f_i >= 1).AND.(f_i <= nb_fi_mx) ) THEN i_s = f_i i_e = f_i ELSE i_s = 1 i_e = 0 CALL ipslerr (2,'flioclo', & & 'Invalid file identifier',' ',' ') ENDIF ELSE i_s = 1 i_e = nb_fi_mx ENDIF !- DO i_f=i_s,i_e f_e = nw_id(i_f) IF (f_e > 0) THEN IF (l_dbg) THEN WRITE(*,*) ' flioclo - closing file number ',i_f ENDIF i_rc = NF90_CLOSE(f_e) nw_id(i_f) = -1 ELSE IF (PRESENT(f_i)) THEN CALL ipslerr (2,'flioclo', & & 'Unable to close the file :','probably','not opened') ENDIF ENDDO !- IF (l_dbg) THEN WRITE(*,*) "<-flioclo" ENDIF !--------------------- END SUBROUTINE flioclo !=== SUBROUTINE fliodmpf (f_n) !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*),INTENT(IN) :: f_n !- INTEGER :: f_e,n_dims,n_vars,n_atts,i_unlm INTEGER :: i_rc,i_n,k_n,t_ea,l_ea INTEGER :: tmp_i REAL :: tmp_r INTEGER,DIMENSION(:),ALLOCATABLE :: tma_i REAL,DIMENSION(:),ALLOCATABLE :: tma_r CHARACTER(LEN=256) :: tmp_c INTEGER,DIMENSION(nb_fd_mx) :: n_idim,n_ldim INTEGER,DIMENSION(nb_ax_mx) :: n_ai CHARACTER(LEN=NF90_MAX_NAME),DIMENSION(nb_fd_mx) :: c_ndim INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: idimid CHARACTER(LEN=NF90_MAX_NAME) :: c_name !--------------------------------------------------------------------- i_rc = NF90_OPEN(TRIM(f_n),NF90_NOWRITE,f_e) IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'fliodmpf', & & 'Could not open file :',TRIM(f_n), & & TRIM(NF90_STRERROR(i_rc))//' (Netcdf)') ENDIF !- WRITE (*,*) "---" WRITE (*,*) "--- File '",TRIM(f_n),"'" WRITE (*,*) "---" !- CALL flio_inf & & (f_e,nb_dims=n_dims,nb_vars=n_vars, & & nb_atts=n_atts,id_unlm=i_unlm, & & nn_idm=n_idim,nn_ldm=n_ldim,cc_ndm=c_ndim,nn_aid=n_ai) !- WRITE (*,*) 'External model identifier : ',f_e WRITE (*,*) 'Number of dimensions : ',n_dims WRITE (*,*) 'Number of variables : ',n_vars WRITE (*,*) 'ID unlimited : ',i_unlm !- WRITE (*,*) "---" WRITE (*,*) 'Presumed axis dimensions identifiers :' IF (n_ai(k_lon) > 0) THEN WRITE (*,*) 'x axis : ',n_ai(k_lon) ELSE WRITE (*,*) 'x axis : NONE' ENDIF IF (n_ai(k_lat) > 0) THEN WRITE (*,*) 'y axis : ',n_ai(k_lat) ELSE WRITE (*,*) 'y axis : NONE' ENDIF IF (n_ai(k_lev) > 0) THEN WRITE (*,*) 'z axis : ',n_ai(k_lev) ELSE WRITE (*,*) 'z axis : NONE' ENDIF IF (n_ai(k_tim) > 0) THEN WRITE (*,*) 't axis : ',n_ai(k_tim) ELSE WRITE (*,*) 't axis : NONE' ENDIF !- WRITE (*,*) "---" WRITE (*,*) 'Number of global attributes : ',n_atts DO k_n=1,n_atts i_rc = NF90_INQ_ATTNAME(f_e,NF90_GLOBAL,k_n,c_name) i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,NF90_GLOBAL,c_name, & & xtype=t_ea,len=l_ea) IF ( (t_ea == NF90_INT4).OR.(t_ea == NF90_INT2) & .OR.(t_ea == NF90_INT1) ) THEN IF (l_ea > 1) THEN ALLOCATE(tma_i(l_ea)) i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tma_i) WRITE (*,'(" ",A," :",/,(5(1X,I10),:))') & & TRIM(c_name),tma_i(1:l_ea) DEALLOCATE(tma_i) ELSE i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_i) WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_i ENDIF ELSE IF ( (t_ea == NF90_REAL4).OR.(t_ea == NF90_REAL8) ) THEN IF (l_ea > 1) THEN ALLOCATE(tma_r(l_ea)) i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tma_r) WRITE (*,'(" ",A," :",/,(5(1X,1PE11.3),:))') & & TRIM(c_name),tma_r(1:l_ea) DEALLOCATE(tma_r) ELSE i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_r) WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_r ENDIF ELSE tmp_c = '' i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_c) WRITE(*,*) ' ',TRIM(c_name),' : "',TRIM(tmp_c),'"' ENDIF ENDDO !- DO i_n=1,nb_fd_mx IF (n_idim(i_n) > 0) THEN WRITE (*,*) "---" WRITE (*,*) 'Dimension id : ',n_idim(i_n) WRITE (*,*) 'Dimension name : ',TRIM(c_ndim(i_n)) WRITE (*,*) 'Dimension size : ',n_ldim(i_n) ENDIF ENDDO !- DO i_n=1,n_vars i_rc = NF90_INQUIRE_VARIABLE(f_e,i_n, & & name=c_name,ndims=n_dims,dimids=idimid,nAtts=n_atts) WRITE (*,*) "---" WRITE (*,*) "Variable name : ",TRIM(c_name) WRITE (*,*) "Variable identifier : ",i_n WRITE (*,*) "Number of dimensions : ",n_dims IF (n_dims > 0) THEN WRITE (*,*) "Dimensions ID's : ",idimid(1:n_dims) ENDIF WRITE (*,*) "Number of attributes : ",n_atts DO k_n=1,n_atts i_rc = NF90_INQ_ATTNAME(f_e,i_n,k_n,c_name) i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_n,c_name, & & xtype=t_ea,len=l_ea) IF ( (t_ea == NF90_INT4).OR.(t_ea == NF90_INT2) & & .OR.(t_ea == NF90_INT1) ) THEN IF (l_ea > 1) THEN ALLOCATE(tma_i(l_ea)) i_rc = NF90_GET_ATT(f_e,i_n,c_name,tma_i) WRITE (*,'(" ",A," :",/,(5(1X,I10),:))') & & TRIM(c_name),tma_i(1:l_ea) DEALLOCATE(tma_i) ELSE i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_i) WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_i ENDIF ELSE IF ( (t_ea == NF90_REAL4).OR.(t_ea == NF90_REAL8) ) THEN IF (l_ea > 1) THEN ALLOCATE(tma_r(l_ea)) i_rc = NF90_GET_ATT(f_e,i_n,c_name,tma_r) WRITE (*,'(" ",A," :",/,(5(1X,1PE11.3),:))') & & TRIM(c_name),tma_r(1:l_ea) DEALLOCATE(tma_r) ELSE i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_r) WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_r ENDIF ELSE tmp_c = '' i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_c) WRITE(*,*) ' ',TRIM(c_name),' : "',TRIM(tmp_c),'"' ENDIF ENDDO ENDDO WRITE (*,*) "---" !- i_rc = NF90_CLOSE(f_e) !---------------------- END SUBROUTINE fliodmpf !=== SUBROUTINE flio_dom_set & & (dtnb,dnb,did,dsg,dsl,dpf,dpl,dhs,dhe,cdnm,id_dom) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: dtnb,dnb INTEGER,DIMENSION(:),INTENT(IN) :: did,dsg,dsl,dpf,dpl,dhs,dhe CHARACTER(LEN=*),INTENT(IN) :: cdnm INTEGER,INTENT(OUT) :: id_dom !- INTEGER :: k_w,i_w,i_s CHARACTER(LEN=l_dns) :: cd_p,cd_w !--------------------------------------------------------------------- k_w = flio_dom_rid() IF (k_w < 0) THEN CALL ipslerr (3,'flio_dom_set', & & 'too many domains simultaneously defined', & & 'please unset useless domains', & & 'by calling flio_dom_unset') ENDIF id_dom = k_w !- d_n_t(k_w) = dtnb d_n_c(k_w) = dnb !- i_s = SIZE(did) IF (i_s > dom_max_dims) THEN CALL ipslerr (3,'flio_dom_set', & & 'too many distributed dimensions', & & 'simultaneously defined',' ') ENDIF d_d_n(k_w) = i_s d_d_i(1:i_s,k_w) = did(1:i_s) !- i_w = SIZE(dsg) IF (i_w /= i_s) THEN CALL ipslerr (3,'flio_dom_set', & & 'the size of the DOMAIN_size_global array', & & 'is not equal to the size', & & 'of the distributed dimensions array') ENDIF d_s_g(1:i_w,k_w) = dsg(1:i_w) !- i_w = SIZE(dsl) IF (i_w /= i_s) THEN CALL ipslerr (3,'flio_dom_set', & & 'the size of the DOMAIN_size_local array', & & 'is not equal to the size', & & 'of the distributed dimensions array') ENDIF d_s_l(1:i_w,k_w) = dsl(1:i_w) !- i_w = SIZE(dpf) IF (i_w /= i_s) THEN CALL ipslerr (3,'flio_dom_set', & & 'the size of the DOMAIN_position_first array', & & 'is not equal to the size', & & 'of the distributed dimensions array') ENDIF d_p_f(1:i_w,k_w) = dpf(1:i_w) !- i_w = SIZE(dpl) IF (i_w /= i_s) THEN CALL ipslerr (3,'flio_dom_set', & & 'the size of the DOMAIN_position_last array', & & 'is not equal to the size', & & 'of the distributed dimensions array') ENDIF d_p_l(1:i_w,k_w) = dpl(1:i_w) !- i_w = SIZE(dhs) IF (i_w /= i_s) THEN CALL ipslerr (3,'flio_dom_set', & & 'the size of the DOMAIN_halo_size_start array', & & 'is not equal to the size', & & 'of the distributed dimensions array') ENDIF d_h_s(1:i_w,k_w) = dhs(1:i_w) !- i_w = SIZE(dhe) IF (i_w /= i_s) THEN CALL ipslerr (3,'flio_dom_set', & & 'the size of the DOMAIN_halo_size_end array', & & 'is not equal to the size', & & 'of the distributed dimensions array') ENDIF d_h_e(1:i_w,k_w) = dhe(1:i_w) !- cd_p = "unknown" cd_w = cdnm; CALL strlowercase (cd_w) DO i_w=1,n_dns IF (TRIM(cd_w) == TRIM(c_dns(i_w))) THEN cd_p = cd_w; EXIT; ENDIF ENDDO IF (TRIM(cd_p) == "unknown") THEN CALL ipslerr (3,'flio_dom_set', & & 'DOMAIN_type "'//TRIM(cdnm)//'"', & & 'is actually not supported', & & 'please use one of the supported names') ENDIF c_d_t(k_w) = cd_p !-------------------------- END SUBROUTINE flio_dom_set !=== SUBROUTINE flio_dom_unset (id_dom) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN),OPTIONAL :: id_dom !- INTEGER :: i_w !--------------------------------------------------------------------- IF (PRESENT(id_dom)) THEN IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN IF (d_d_n(id_dom) > 0) THEN d_d_n(id_dom) = -1 ELSE CALL ipslerr (2,'flio_dom_unset', & & 'The domain is not set',' ',' ') ENDIF ELSE CALL ipslerr (2,'flio_dom_unset', & & 'Invalid file identifier',' ',' ') ENDIF ELSE DO i_w=1,dom_max_nb d_d_n(id_dom) = -1 ENDDO ENDIF !---------------------------- END SUBROUTINE flio_dom_unset !=== SUBROUTINE flio_dom_defset (id_dom) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: id_dom !--------------------------------------------------------------------- IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN id_def_dom = id_dom ELSE CALL ipslerr (3,'flio_dom_defset', & & 'Invalid domain identifier',' ',' ') ENDIF !----------------------------- END SUBROUTINE flio_dom_defset !=== SUBROUTINE flio_dom_defunset () !--------------------------------------------------------------------- IMPLICIT NONE !--------------------------------------------------------------------- id_def_dom = FLIO_DOM_NONE !------------------------------- END SUBROUTINE flio_dom_defunset !=== SUBROUTINE flio_dom_definq (id_dom) !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(OUT) :: id_dom !--------------------------------------------------------------------- id_dom = id_def_dom !----------------------------- END SUBROUTINE flio_dom_definq !=== !- !--------------------------------------------------------------------- !- Semi-public procedures !--------------------------------------------------------------------- !- !=== SUBROUTINE flio_dom_file (f_n,id_dom) !--------------------------------------------------------------------- !- Update the model file name to include the ".nc" suffix and !- the DOMAIN number on which this copy of IOIPSL runs, if needed. !- This routine is called by IOIPSL and not by user anyway. !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*),INTENT(INOUT) :: f_n INTEGER,OPTIONAL,INTENT(IN) :: id_dom !- INTEGER :: il,iw CHARACTER(LEN=4) :: str !--------------------------------------------------------------------- !- ! Add the ".nc" suffix if needed il = LEN_TRIM(f_n) IF (f_n(il-2:il) /= '.nc') THEN f_n = f_n(1:il)//'.nc' ENDIF !- ! Add the DOMAIN identifier if needed IF (PRESENT(id_dom)) THEN IF (id_dom == FLIO_DOM_DEFAULT) THEN CALL flio_dom_definq (iw) ELSE iw = id_dom ENDIF IF (iw /= FLIO_DOM_NONE) THEN IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN IF (d_d_n(iw) > 0) THEN WRITE(str,'(I4.4)') d_n_c(iw) il = INDEX(f_n,'.nc') f_n = f_n(1:il-1)//'_'//str//'.nc' ELSE CALL ipslerr (3,'flio_dom_file', & & 'The domain has not been defined', & & 'please call flio_dom_set', & & 'before calling flio_dom_file') ENDIF ELSE CALL ipslerr (3,'flio_dom_file', & & 'Invalid domain identifier',' ',' ') ENDIF ENDIF ENDIF !--------------------------- END SUBROUTINE flio_dom_file !=== SUBROUTINE flio_dom_att (f_e,id_dom) !--------------------------------------------------------------------- !- Add the DOMAIN attributes to the NETCDF file. !- This routine is called by IOIPSL and not by user anyway. !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(in) :: f_e INTEGER,OPTIONAL,INTENT(IN) :: id_dom !- INTEGER :: iw,i_rc,i_n CHARACTER(LEN=15) :: c_ddim INTEGER :: n_idim CHARACTER(LEN=NF90_MAX_NAME) :: c_ndim !--------------------------------------------------------------------- IF (PRESENT(id_dom)) THEN IF (id_dom == FLIO_DOM_DEFAULT) THEN CALL flio_dom_definq (iw) ELSE iw = id_dom ENDIF IF (iw /= FLIO_DOM_NONE) THEN IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN IF (d_d_n(iw) > 0) THEN i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & & 'DOMAIN_number_total',d_n_t(iw)) i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & & 'DOMAIN_number',d_n_c(iw)) i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & & 'DOMAIN_dimensions_ids',d_d_i(1:d_d_n(iw),iw)) i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & & 'DOMAIN_size_global',d_s_g(1:d_d_n(iw),iw)) i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & & 'DOMAIN_size_local',d_s_l(1:d_d_n(iw),iw)) i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & & 'DOMAIN_position_first',d_p_f(1:d_d_n(iw),iw)) i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & & 'DOMAIN_position_last',d_p_l(1:d_d_n(iw),iw)) i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & & 'DOMAIN_halo_size_start',d_h_s(1:d_d_n(iw),iw)) i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & & 'DOMAIN_halo_size_end',d_h_e(1:d_d_n(iw),iw)) i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & & 'DOMAIN_type',TRIM(c_d_t(iw))) i_rc = NF90_INQUIRE (f_e,nDimensions=n_idim) DO i_n=1,n_idim i_rc = NF90_INQUIRE_DIMENSION (f_e,i_n,name=c_ndim) WRITE (UNIT=c_ddim,FMT='("DOMAIN_DIM_N",I3.3)') i_n i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL,c_ddim,TRIM(c_ndim)) ENDDO ELSE CALL ipslerr (3,'flio_dom_att', & & 'The domain has not been defined', & & 'please call flio_dom_set', & & 'before calling flio_dom_att') ENDIF ELSE CALL ipslerr (3,'flio_dom_att', & & 'Invalid domain identifier',' ',' ') ENDIF ENDIF ENDIF !-------------------------- END SUBROUTINE flio_dom_att !=== !- !--------------------------------------------------------------------- !- Local procedures !--------------------------------------------------------------------- !- !=== INTEGER FUNCTION flio_rid() !--------------------------------------------------------------------- !- returns a free index in nw_id(:) !--------------------------------------------------------------------- INTEGER,DIMENSION(1:1) :: nfi !- IF (ANY(nw_id < 0)) THEN nfi = MINLOC(nw_id,MASK=nw_id < 0) flio_rid = nfi(1) ELSE flio_rid = -1 ENDIF !-------------------- END FUNCTION flio_rid !=== INTEGER FUNCTION flio_dom_rid() !--------------------------------------------------------------------- !- returns a free index in d_d_n(:) !--------------------------------------------------------------------- INTEGER,DIMENSION(1:1) :: nd !--------------------------------------------------------------------- IF (ANY(d_d_n < 0)) THEN nd = MINLOC(d_d_n,MASK=d_d_n < 0) flio_dom_rid = nd(1) ELSE flio_dom_rid = -1 ENDIF !------------------------ END FUNCTION flio_dom_rid !=== INTEGER FUNCTION flio_qid(iid) !--------------------------------------------------------------------- !- returns the external index associated with the internal index "iid" !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: iid !--------------------------------------------------------------------- IF ( (iid >= 1).AND.(iid <= nb_fi_mx) ) THEN flio_qid = nw_id(iid) ELSE flio_qid = -1 ENDIF !-------------------- END FUNCTION flio_qid !=== SUBROUTINE flio_qvid (cpg,iid,ixd) !--------------------------------------------------------------------- !- This subroutine, called by the procedure "cpg", !- validates and returns the external file index "ixd" !- associated with the internal file index "iid" !--------------------------------------------------------------------- IMPLICIT NONE !- CHARACTER(LEN=*),INTENT(IN) :: cpg INTEGER,INTENT(IN) :: iid INTEGER,INTENT(OUT) :: ixd !- CHARACTER(LEN=20) :: c_t !--------------------------------------------------------------------- ixd = flio_qid(iid) IF (ixd < 0) THEN WRITE (UNIT=c_t,FMT='(I15)') iid CALL ipslerr (3,TRIM(cpg), & & 'Invalid internal file index :',TRIM(ADJUSTL(c_t)),' ') ENDIF !----------------------- END SUBROUTINE flio_qvid !=== SUBROUTINE flio_hdm (f_i,f_e,lk_hm) !--------------------------------------------------------------------- !- This subroutine handles the "define/data mode" of NETCDF. !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_i,f_e LOGICAL,INTENT(IN) :: lk_hm !- INTEGER :: i_rc !--------------------------------------------------------------------- i_rc = NF90_NOERR !- IF ( (.NOT.lw_hm(f_i)).AND.(lk_hm) ) THEN i_rc = NF90_REDEF(f_e) lw_hm(f_i) = .TRUE. ELSE IF ( (lw_hm(f_i)).AND.(.NOT.lk_hm) ) THEN i_rc = NF90_ENDDEF(f_e) lw_hm(f_i) = .FALSE. ENDIF !- IF (i_rc /= NF90_NOERR) THEN CALL ipslerr (3,'flio_hdm', & & 'Internal error ','in define/data mode :', & & TRIM(NF90_STRERROR(i_rc))) ENDIF !---------------------- END SUBROUTINE flio_hdm !=== SUBROUTINE flio_inf (f_e, & & nb_dims,nb_vars,nb_atts,id_unlm,nn_idm,nn_ldm,nn_aid,cc_ndm) !--------------------------------------------------------------------- !- This subroutine allows to get some information concerning !- the model file whose the external identifier is "f_e". !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER,INTENT(IN) :: f_e INTEGER,OPTIONAL,INTENT(OUT) :: nb_dims,nb_vars,nb_atts,id_unlm INTEGER,DIMENSION(:),OPTIONAL,INTENT(OUT) :: nn_idm,nn_ldm,nn_aid CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: cc_ndm !- INTEGER :: nm_dims,nm_vars,nm_atts,nm_unlm,ml INTEGER :: i_rc,kv CHARACTER(LEN=NF90_MAX_NAME) :: f_d_n !- LOGICAL :: l_dbg !--------------------------------------------------------------------- CALL ipsldbg (old_status=l_dbg) !- IF (l_dbg) THEN WRITE(*,*) "->flio_inf" ENDIF !- i_rc = NF90_INQUIRE(f_e,nDimensions=nm_dims,nVariables=nm_vars, & & nAttributes=nm_atts,unlimitedDimId=nm_unlm) !- IF (PRESENT(nb_dims)) nb_dims = nm_dims; IF (PRESENT(nb_vars)) nb_vars = nm_vars; IF (PRESENT(nb_atts)) nb_atts = nm_atts; IF (PRESENT(id_unlm)) id_unlm = nm_unlm; !- IF (PRESENT(nn_idm)) nn_idm(:) = -1; IF (PRESENT(nn_ldm)) nn_ldm(:) = 0; IF (PRESENT(cc_ndm)) cc_ndm(:) = ' '; IF (PRESENT(nn_aid)) nn_aid(:) = -1; !- DO kv=1,nm_dims !--- i_rc = NF90_INQUIRE_DIMENSION(f_e,kv,name=f_d_n,len=ml) CALL strlowercase (f_d_n) f_d_n = ADJUSTL(f_d_n) !--- IF (l_dbg) THEN WRITE(*,*) " flio_inf ",kv,ml," ",TRIM(f_d_n) ENDIF !--- IF (PRESENT(nn_idm)) nn_idm(kv)=kv; IF (PRESENT(nn_ldm)) nn_ldm(kv)=ml; IF (PRESENT(cc_ndm)) cc_ndm(kv)=TRIM(f_d_n); !--- IF ( (INDEX(f_d_n,'x') == 1) & & .OR.(INDEX(f_d_n,'lon') == 1) ) THEN IF (PRESENT(nn_aid)) THEN IF (nn_aid(k_lon) < 0) THEN nn_aid(k_lon)=kv; ENDIF ENDIF ELSE IF ( (INDEX(f_d_n,'y') == 1) & & .OR.(INDEX(f_d_n,'lat') == 1) ) THEN IF (PRESENT(nn_aid)) THEN IF (nn_aid(k_lat) < 0) THEN nn_aid(k_lat)=kv; ENDIF ENDIF ELSE IF ( (INDEX(f_d_n,'z') == 1) & & .OR.(INDEX(f_d_n,'lev') == 1) & & .OR.(INDEX(f_d_n,'plev') == 1) & & .OR.(INDEX(f_d_n,'depth') == 1) ) THEN IF (PRESENT(nn_aid)) THEN IF (nn_aid(k_lev) < 0) THEN nn_aid(k_lev)=kv; ENDIF ENDIF ELSE IF ( (TRIM(f_d_n) == 't') & & .OR.(TRIM(f_d_n) == 'time') & & .OR.(INDEX(f_d_n,'tstep') == 1) & & .OR.(INDEX(f_d_n,'time_counter') == 1) ) THEN !---- For the time we certainly need to allow for other names IF (PRESENT(nn_aid)) THEN IF (nn_aid(k_tim) < 0) THEN nn_aid(k_tim)=kv; ENDIF ENDIF ENDIF !--- ENDDO !- IF (l_dbg) THEN WRITE(*,*) "<-flio_inf" ENDIF !---------------------- END SUBROUTINE flio_inf !=== SUBROUTINE flio_qax (f_i,axtype,i_v,nbd) !--------------------------------------------------------------------- !- This subroutine explores the file in order to find !- an axis (x/y/z/t) according to a number of rules !--------------------------------------------------------------------- IMPLICIT NONE !- INTEGER :: f_i,i_v,nbd CHARACTER(LEN=*) :: axtype !- INTEGER :: kv,k,n_r,l_d,n_d,i_rc,dimnb CHARACTER(LEN=1) :: c_ax CHARACTER(LEN=18) :: c_sn CHARACTER(LEN=15),DIMENSION(10) :: c_r CHARACTER(LEN=40) :: c_t1,c_t2 !--------------------------------------------------------------------- i_v = -1; nbd = -1; !--- !- Keep the name of the axis !--- c_ax = TRIM(axtype) !- ! Validate axis type !- IF ( (LEN_TRIM(axtype) == 1) & & .AND.( (c_ax == 'x').OR.(c_ax == 'y') & & .OR.(c_ax == 'z').OR.(c_ax == 't')) ) THEN !--- !-- Define the maximum number of dimensions for the coordinate !--- SELECT CASE (c_ax) CASE('x') l_d = 2 c_sn = 'longitude' CASE('y') l_d = 2 c_sn = 'latitude' CASE('z') l_d = 1 c_sn = 'model_level_number' CASE('t') l_d = 1 c_sn = 'time' END SELECT !--- !-- Rule 1 : we look for a variable with one dimension !-- and which has the same name as its dimension (NUG) !--- IF (i_v < 0) THEN SELECT CASE (c_ax) CASE('x') k = nw_ai(k_lon,f_i) CASE('y') k = nw_ai(k_lat,f_i) CASE('z') k = nw_ai(k_lev,f_i) CASE('t') k = nw_ai(k_tim,f_i) END SELECT IF ( (k >= 1).AND.(k <= nb_ax_mx) ) THEN dimnb = nw_di(k,f_i) ELSE dimnb = -1 ENDIF !----- i_rc = NF90_INQUIRE_DIMENSION(nw_id(f_i),dimnb,name=c_t1) IF (i_rc == NF90_NOERR) THEN CALL strlowercase (c_t1) L_R1: DO kv=1,nw_nv(f_i) i_rc = NF90_INQUIRE_VARIABLE & & (nw_id(f_i),kv,name=c_t2,ndims=n_d) IF (n_d == 1) THEN CALL strlowercase (c_t2) IF (TRIM(c_t1) == TRIM(c_t2)) THEN i_v = kv; nbd = n_d; EXIT L_R1 ENDIF ENDIF ENDDO L_R1 ENDIF ENDIF !--- !-- Rule 2 : we look for a correct "axis" attribute (CF) !--- IF (i_v < 0) THEN L_R2: DO kv=1,nw_nv(f_i) i_rc = NF90_GET_ATT(nw_id(f_i),kv,'axis',c_t1) IF (i_rc == NF90_NOERR) THEN CALL strlowercase (c_t1) IF (TRIM(c_t1) == c_ax) THEN i_rc = NF90_INQUIRE_VARIABLE(nw_id(f_i),kv,ndims=n_d) IF (n_d <= l_d) THEN i_v = kv; nbd = n_d; EXIT L_R2 ENDIF ENDIF ENDIF ENDDO L_R2 ENDIF !--- !-- Rule 3 : we look for a correct "standard_name" attribute (CF) !--- IF (i_v < 0) THEN L_R3: DO kv=1,nw_nv(f_i) i_rc = NF90_GET_ATT(nw_id(f_i),kv,'standard_name',c_t1) IF (i_rc == NF90_NOERR) THEN CALL strlowercase (c_t1) IF (TRIM(c_t1) == TRIM(c_sn)) THEN i_rc = NF90_INQUIRE_VARIABLE(nw_id(f_i),kv,ndims=n_d) IF (n_d <= l_d) THEN i_v = kv; nbd = n_d; EXIT L_R3 ENDIF ENDIF ENDIF ENDDO L_R3 ENDIF !--- !-- Rule 4 : we look for a specific name (IOIPSL) !--- IF (i_v < 0) THEN SELECT CASE (c_ax) CASE('x') n_r = 3 c_r(1)='nav_lon'; c_r(2)='lon'; c_r(3)='longitude'; CASE('y') n_r = 3 c_r(1)='nav_lat'; c_r(2)='lat'; c_r(3)='latitude'; CASE('z') n_r = 8 c_r(1)='depth'; c_r(2)='deptht'; c_r(3)='height'; c_r(4)='level'; c_r(5)='lev'; c_r(6)='plev'; c_r(7)='sigma_level'; c_r(8)='layer'; CASE('t') n_r = 3 c_r(1)='time'; c_r(2)='tstep'; c_r(3)='timesteps'; END SELECT !----- L_R4: DO kv=1,nw_nv(f_i) i_rc = NF90_INQUIRE_VARIABLE & & (nw_id(f_i),kv,name=c_t1,ndims=n_d) IF (i_rc == NF90_NOERR) THEN CALL strlowercase (c_t1) IF (n_d <= l_d) THEN DO k=1,n_r IF (TRIM(c_t1) == TRIM(c_r(k))) THEN i_v = kv; nbd = n_d; EXIT L_R4 ENDIF ENDDO ENDIF ENDIF ENDDO L_R4 ENDIF !--- ENDIF !---------------------- END SUBROUTINE flio_qax !- !=== !- END MODULE fliocom