source: utils/tools/SIREN/src/create_restart.f90 @ 12080

Last change on this file since 12080 was 12080, checked in by jpaul, 10 months ago

update nemo trunk

File size: 52.0 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5! DESCRIPTION:
6!> @file
7!> @brief
8!> this program creates restart file or initial state.
9!>
10!> @details
11!> @section sec1 method
12!> variables could be
13!>  - extracted from fine grid file
14!>  - interpolated from coarse grid file
15!>  - interpolated from restart file
16!>  - handwritten
17!>
18!> then they are split over new layout.
19!> @note
20!>    interpolation and/or extrapolation method could be different for each variable.
21!>
22!> @section sec2 how to
23!> USAGE: create_restart create_restart.nam [-v] [-h]<br/>
24!>    - positional arguments:<br/>
25!>       - create_restart.nam<br/>
26!>          namelist of create_restart
27!>          @note
28!>             a template of the namelist could be created running (in templates directory):
29!>             @code{.sh}
30!>                python create_templates.py create_restart
31!>             @endcode
32!>
33!>    - optional arguments:<br/>
34!>       - -h, --help<br/>
35!>          show this help message (and exit)<br/>
36!>       - -v, --version<br/>
37!>          show Siren's version   (and exit)
38!>
39!> @section sec_restart create_restart.nam
40!>    create_restart.nam contains 9 namelists:<br/>
41!>       - **namlog** to set logger parameters
42!>       - **namcfg** to set configuration file parameters
43!>       - **namsrc** to set source/coarse grid parameters
44!>       - **namtgt** to set target/fine grid parameters
45!>       - **namzgr** to set vertical grid parameters
46!>       - **namzps** to set partial step parameters
47!>       - **namvar** to set variable parameters
48!>       - **namnst** to set sub domain and nesting paramters
49!>       - **namout** to set output parameters
50!>
51!>    here after, each sub-namelist parameters is detailed.
52!>    @note
53!>       default values are specified between brackets
54!>
55!> @subsection sublog namlog
56!>    the logger sub-namelist parameters are :
57!>
58!>    - **cn_logfile** [@a create_restart.log]<br/>
59!>       logger filename
60!>
61!>    - **cn_verbosity** [@a warning]<br/>
62!>       verbosity level, choose between :
63!>          - trace
64!>          - debug
65!>          - info
66!>          - warning
67!>          - error
68!>          - fatal
69!>          - none
70!>
71!>    - **in_maxerror** [@a 5]<br/>
72!>       maximum number of error allowed
73!>
74!> @subsection subcfg namcfg
75!>    the configuration sub-namelist parameters are :
76!>
77!>    - **cn_varcfg** [@a ./cfg/variable.cfg]<br/>
78!>       path to the variable configuration file.<br/>
79!>       the variable configuration file defines standard name,
80!>       default interpolation method, axis,...
81!>       to be used for some known variables.<br/>
82!>
83!>    - **cn_dimcfg** [@a ./cfg/dimension.cfg]<br/>
84!>       path to the dimension configuration file.<br/>
85!>       the dimension configuration file defines dimensions allowed.<br/>
86!>
87!>    - **cn_dumcfg** [@a ./cfg/dummy.cfg]<br/>
88!>       path to the useless (dummy) configuration file.<br/>
89!>       the dummy configuration file defines useless
90!>       dimension or variable. these dimension(s) or variable(s) will not be
91!>       processed.<br/>
92!>
93!> @subsection subsrc namsrc
94!>    the coarse grid sub-namelist parameters are :
95!>
96!>    - **cn_coord0** [@a ]<br/>
97!>       path to the coordinate file
98!>
99!>    - **in_perio0** [@a ]<br/>
100!>       NEMO periodicity index<br/>
101!>       the NEMO periodicity could be choose between 0 to 6:
102!>       <dl>
103!>          <dt>in_perio=0</dt>
104!>          <dd>standard regional model</dd>
105!>          <dt>in_perio=1</dt>
106!>          <dd>east-west cyclic model</dd>
107!>          <dt>in_perio=2</dt>
108!>          <dd>model with symmetric boundary condition across the equator</dd>
109!>          <dt>in_perio=3</dt>
110!>          <dd>regional model with North fold boundary and T-point pivot</dd>
111!>          <dt>in_perio=4</dt>
112!>          <dd>global model with a T-point pivot.<br/>
113!>          example: ORCA2, ORCA025, ORCA12</dd>
114!>          <dt>in_perio=5</dt>
115!>          <dd>regional model with North fold boundary and F-point pivot</dd>
116!>          <dt>in_perio=6</dt>
117!>          <dd>global model with a F-point pivot<br/>
118!>          example: ORCA05</dd>
119!>          </dd>
120!>       </dl>
121!>       @sa For more information see @ref md_src_docsrc_6_perio
122!>       and Model Boundary Condition paragraph in the
123!>       [NEMO documentation](https://forge.ipsl.jussieu.fr/nemo/chrome/site/doc/NEMO/manual/pdf/NEMO_manual.pdf)
124!>
125!> @subsection subtgt namtgt
126!>    the fine grid sub-namelist parameters are :
127!>
128!>    - **cn_coord1** [@a ]<br/>
129!>       path to coordinate file
130!>
131!>    - **cn_bathy1** [@a ]<br/>
132!>       path to bathymetry file
133!>
134!>    - **in_perio1** [@a ]<br/>
135!>       NEMO periodicity index (see above)
136!>    @note if the fine/target coordinates file (cn_coord1) was created by SIREN, you do
137!>    not need to fill this parameter. SIREN will read it on the global attributes of
138!>    the coordinates file.
139!>
140!> @subsection subzgr namzgr
141!>    the vertical grid sub-namelist parameters are :
142!>
143!>    - **dn_pp_to_be_computed** [@a 0]<br/>
144!>
145!>    - **dn_ppsur** [@a -3958.951371276829]<br/>
146!>       coefficient to compute vertical grid
147!>
148!>    - **dn_ppa0** [@a 103.953009600000]<br/>
149!>       coefficient to compute vertical grid
150!>
151!>    - **dn_ppa1** [@a 2.415951269000]<br/>
152!>       coefficient to compute vertical grid
153!>
154!>    - **dn_ppa2** [@a 100.760928500000]<br/>
155!>       double tanh function parameter
156!>
157!>    - **dn_ppkth** [@a 15.351013700000]<br/>
158!>       coefficient to compute vertical grid
159!>
160!>    - **dn_ppkth2** [@a 48.029893720000]<br/>
161!>       double tanh function parameter
162!>
163!>    - **dn_ppacr** [@a 7.000000000000]<br/>
164!>       coefficient to compute vertical grid
165!>
166!>    - **dn_ppacr2** [@a 13.000000000000]<br/>
167!>       double tanh function parameter
168!>
169!>    - **dn_ppdzmin** [@a 6.]<br/>
170!>       minimum vertical spacing
171!>
172!>    - **dn_pphmax** [@a 5750.]<br/>
173!>       maximum depth
174!>
175!>    - **in_nlevel** [@a 75]<br/>
176!>       number of vertical level
177!>
178!>     @note
179!>       If *dn_ppa1*, *dn_ppa0* and *dn_ppsur* are undefined,
180!>       NEMO will compute them from *dn_ppdzmin, dn_pphmax, dn_ppkth, dn_ppacr*
181!>
182!> @subsection subzps namzps
183!>    the partial step sub-namelist parameters are :
184!>
185!>    - **dn_e3zps_min** [@a 25.]<br/>
186!>       minimum thickness of partial step level (meters)
187!>    - **dn_e3zps_rat** [@a 0.2]<br/>
188!>       minimum thickness ratio of partial step level
189!>
190!> @subsection subvar namvar
191!>    the variable sub-namelist parameters are :
192!>
193!>    - **cn_varfile** [@a ]<br/>
194!>       list of variable, and associated file
195!>
196!>       *cn_varfile* is the path and filename of the file where find
197!>       variable.
198!>       @note
199!>          *cn_varfile* could be a matrix of value, if you want to handwrite
200!>          variable value.<br/>
201!>          the variable array of value is split into equal subdomain.<br/>
202!>          each subdomain is filled with the corresponding value
203!>          of the matrix.<br/>         
204!>          separators used to defined matrix are:
205!>             - ',' for line
206!>             - '/' for row
207!>             Example:<br/>
208!>                3,2,3/1,4,5  =>  @f$ \left( \begin{array}{ccc}
209!>                                      3 & 2 & 3 \\
210!>                                      1 & 4 & 5 \end{array} \right) @f$
211!>
212!>       Examples:
213!>          - 'votemper:gridT.nc', 'vozocrtx:gridU.nc'
214!>          - 'votemper:10\25', 'vozocrtx:gridU.nc'<br/>
215!>
216!>       @note
217!>          to get all variables from one file:
218!>
219!>       Example:
220!>          - 'all:restart.dimg'
221!>
222!>       @note
223!>          Optionnaly, NEMO periodicity could be added following the filename.
224!>          the periodicity must be separated by ';'
225!>
226!>       Example:
227!>          - 'votemper:gridT.nc ; perio=4'
228!>
229!>    - **cn_varinfo** [@a ]<br/>
230!>       list of variable and extra information about request(s) to be used<br/>
231!>
232!>       each elements of *cn_varinfo* is a string character (separated by ',').<br/>
233!>       it is composed of the variable name follow by ':',
234!>       then request(s) to be used on this variable.<br/>
235!>       request could be:
236!>          - int = interpolation method
237!>          - ext = extrapolation method
238!>          - flt = filter method
239!>          - min = minimum value
240!>          - max = maximum value
241!>          - unt = new units
242!>          - unf = unit scale factor (linked to new units)
243!>
244!>             requests must be separated by ';'.<br/>
245!>             order of requests does not matter.<br/>
246!>
247!>       informations about available method could be find in @ref interp,
248!>       @ref extrap and @ref filter modules.<br/>
249!>       Example:
250!>          - 'votemper: int=linear; flt=hann; ext=dist_weight',
251!>            'vosaline: int=cubic'
252!>
253!>       @note
254!>          If you do not specify a method which is required,
255!>          default one is apply.
256!>
257!> @subsection subnst namnst
258!>    the nesting sub-namelist parameters are :
259!>
260!>    - **in_rhoi**  [@a 1]<br/>
261!>       refinement factor in i-direction
262!>
263!>    - **in_rhoj**  [@a 1]<br/>
264!>       refinement factor in j-direction
265!>
266!>    @note
267!>       coarse grid indices will be deduced from fine grid
268!>       coordinate file.
269!>
270!> @subsection subout namout
271!>    the output sub-namelist parameter is :
272!>
273!>    - **cn_fileout** [@a restart.nc]<br/>
274!>       output bathymetry filename
275!>
276!>    - **ln_extrap** [@a .FALSE.]<br/>
277!>       logical to extrapolate land point or not
278!>
279!>    - **in_niproc** [@a 1]<br/>
280!>       number of processor in i-direction
281!>
282!>    - **in_njproc** [@a 1]<br/>
283!>       number of processor in j-direction
284!>
285!>    - **in_nproc** [@a 1]<br/>
286!>       total number of processor to be used
287!>
288!>    - **cn_type** [@a ]<br/>
289!>       output format ('dimg', 'cdf')
290!>
291!>    @note
292!>       - if *in_niproc*, and *in_njproc* are provided : the program only look for land
293!>         processor to be removed
294!>       - if *in_nproc* is provided : the program compute each possible domain layout,
295!>         and save the one with the most land processor to be removed
296!>       - with no information about number of processors, the program
297!>         assume to use only one processor
298!>
299!> <hr>
300!> @author J.Paul
301!>
302!> @date November, 2013 - Initial Version
303!> @date September, 2014
304!> - add header for user
305!> - offset computed considering grid point
306!> - add attributes in output variable
307!> @date June, 2015
308!> - extrapolate all land points, and add ln_extrap in namelist.
309!> - allow to change unit.
310!> @date September, 2015
311!> - manage useless (dummy) variable, attributes, and dimension
312!> @date October, 2016
313!> - dimension to be used select from configuration file
314!> @date January, 2019
315!> - add url path to global attributes of output file(s)
316!> - check name and standard name for longitude and latitude
317!> @date February, 2019
318!> - rename sub namelist namcrs to namsrc
319!> - rename sub namelist namfin to namtgt
320!> @date May, 2019
321!> - create and clean file structure to avoid memory leaks
322!> @date August, 2019
323!> - use periodicity read from namelist, and store in multi structure
324!> @date Ocober, 2019
325!> - add help and version optional arguments
326!>
327!> @todo
328!> - rewrite using meshmask instead of bathymetry and coordinates files
329!>
330!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
331!----------------------------------------------------------------------
332PROGRAM create_restart
333
334   USE global                          ! global variable
335   USE kind                            ! F90 kind parameter
336   USE logger                          ! log file manager
337   USE fct                             ! basic useful function
338   USE date                            ! date manager
339   USE att                             ! attribute manager
340   USE dim                             ! dimension manager
341   USE var                             ! variable manager
342   USE file                            ! file manager
343   USE multi                           ! multi file manager
344   USE iom                             ! I/O manager
345   USE grid                            ! grid manager
346   USE vgrid                           ! vertical grid manager
347   USE extrap                          ! extrapolation manager
348   USE interp                          ! interpolation manager
349   USE filter                          ! filter manager
350   USE mpp                             ! MPP manager
351   USE dom                             ! domain manager
352   USE iom_mpp                         ! MPP I/O manager
353   USE iom_dom                         ! DOM I/O manager
354
355   IMPLICIT NONE
356
357   ! parameters
358   CHARACTER(LEN=lc), PARAMETER  :: cp_myname = "create_restart"
359
360   ! local variable
361   CHARACTER(LEN=lc)                                  :: cl_arg
362   CHARACTER(LEN=lc)                                  :: cl_namelist
363   CHARACTER(LEN=lc)                                  :: cl_date
364   CHARACTER(LEN=lc)                                  :: cl_name
365   CHARACTER(LEN=lc)                                  :: cl_data
366   CHARACTER(LEN=lc)                                  :: cl_fileout 
367   CHARACTER(LEN=lc)                                  :: cl_url
368   CHARACTER(LEN=lc)                                  :: cl_errormsg
369
370   INTEGER(i4)                                        :: il_narg
371   INTEGER(i4)                                        :: il_status
372   INTEGER(i4)                                        :: il_fileid
373   INTEGER(i4)                                        :: il_varid
374   INTEGER(i4)                                        :: il_attid
375   INTEGER(i4)                                        :: il_nvar
376   INTEGER(i4)                                        :: il_imin1
377   INTEGER(i4)                                        :: il_imax1
378   INTEGER(i4)                                        :: il_jmin1
379   INTEGER(i4)                                        :: il_jmax1
380   INTEGER(i4)                                        :: il_imin0
381   INTEGER(i4)                                        :: il_imax0
382   INTEGER(i4)                                        :: il_jmin0
383   INTEGER(i4)                                        :: il_jmax0
384   INTEGER(i4)                                        :: il_index
385   INTEGER(i4)      , DIMENSION(ip_maxdim)            :: il_rho
386   INTEGER(i4)      , DIMENSION(2,2)                  :: il_xghost
387   INTEGER(i4)      , DIMENSION(2,2)                  :: il_offset
388   INTEGER(i4)      , DIMENSION(2,2)                  :: il_ind
389
390   LOGICAL                                            :: ll_exist
391   LOGICAL                                            :: ll_sameGrid
392
393   TYPE(TDOM)                                         :: tl_dom1
394   TYPE(TDOM)                                         :: tl_dom0
395
396   TYPE(TATT)                                         :: tl_att
397   
398   TYPE(TVAR)                                         :: tl_depth
399   TYPE(TVAR)                                         :: tl_time
400   TYPE(TVAR)                                         :: tl_lon
401   TYPE(TVAR)                                         :: tl_lat
402   TYPE(TVAR)       , DIMENSION(:)      , ALLOCATABLE :: tl_var
403   TYPE(TVAR)       , DIMENSION(:)      , ALLOCATABLE :: tl_level
404   
405   TYPE(TDIM)       , DIMENSION(ip_maxdim)            :: tl_dim
406
407   TYPE(TFILE)                                        :: tl_file
408
409   TYPE(TMPP)                                         :: tl_coord0
410   TYPE(TMPP)                                         :: tl_coord1
411   TYPE(TMPP)                                         :: tl_bathy1
412   TYPE(TMPP)                                         :: tl_mpp
413   TYPE(TMPP)                                         :: tl_mppout
414
415   TYPE(TMULTI)                                       :: tl_multi
416
417   ! loop indices
418   INTEGER(i4) :: ji
419   INTEGER(i4) :: jj
420   INTEGER(i4) :: jvar
421
422   ! namelist variable
423   ! namlog
424   CHARACTER(LEN=lc)                       :: cn_logfile = 'create_restart.log' 
425   CHARACTER(LEN=lc)                       :: cn_verbosity = 'warning' 
426   INTEGER(i4)                             :: in_maxerror = 5
427
428   ! namcfg
429   CHARACTER(LEN=lc)                       :: cn_varcfg = './cfg/variable.cfg' 
430   CHARACTER(LEN=lc)                       :: cn_dimcfg = './cfg/dimension.cfg'
431   CHARACTER(LEN=lc)                       :: cn_dumcfg = './cfg/dummy.cfg'
432
433   ! namsrc
434   CHARACTER(LEN=lc)                       :: cn_coord0 = '' 
435   INTEGER(i4)                             :: in_perio0 = -1
436
437   ! namtgt
438   CHARACTER(LEN=lc)                       :: cn_coord1 = ''
439   CHARACTER(LEN=lc)                       :: cn_bathy1 = ''
440   INTEGER(i4)                             :: in_perio1 = -1
441
442   !namzgr
443   REAL(dp)                                :: dn_pp_to_be_computed = 0._dp
444   REAL(dp)                                :: dn_ppsur   = -3958.951371276829_dp
445   REAL(dp)                                :: dn_ppa0    =   103.953009600000_dp
446   REAL(dp)                                :: dn_ppa1    =     2.415951269000_dp
447   REAL(dp)                                :: dn_ppa2    =   100.760928500000_dp
448   REAL(dp)                                :: dn_ppkth   =    15.351013700000_dp
449   REAL(dp)                                :: dn_ppkth2  =    48.029893720000_dp
450   REAL(dp)                                :: dn_ppacr   =     7.000000000000_dp
451   REAL(dp)                                :: dn_ppacr2  =    13.000000000000_dp
452   REAL(dp)                                :: dn_ppdzmin = 6._dp
453   REAL(dp)                                :: dn_pphmax  = 5750._dp
454   INTEGER(i4)                             :: in_nlevel  = 75
455
456   !namzps
457   REAL(dp)                                :: dn_e3zps_min = 25._dp
458   REAL(dp)                                :: dn_e3zps_rat = 0.2_dp
459
460   ! namvar
461   CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''
462   CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''
463
464   ! namnst
465   INTEGER(i4)                             :: in_rhoi = 1
466   INTEGER(i4)                             :: in_rhoj = 1
467
468   ! namout
469   CHARACTER(LEN=lc)                       :: cn_fileout = 'restart.nc' 
470   LOGICAL                                 :: ln_extrap  = .FALSE.
471   INTEGER(i4)                             :: in_nproc   = 0
472   INTEGER(i4)                             :: in_niproc  = 0
473   INTEGER(i4)                             :: in_njproc  = 0
474   CHARACTER(LEN=lc)                       :: cn_type    = ''
475
476   !-------------------------------------------------------------------
477
478   NAMELIST /namlog/ &  !< logger namelist
479   &  cn_logfile,    &  !< log file
480   &  cn_verbosity,  &  !< log verbosity
481   &  in_maxerror       !< logger maximum error
482
483   NAMELIST /namcfg/ &  !< configuration namelist
484   &  cn_varcfg,     &  !< variable configuration file
485   &  cn_dimcfg,     &  !< dimension configuration file
486   &  cn_dumcfg         !< dummy configuration file
487
488   NAMELIST /namsrc/ &  !< source/coarse grid namelist
489   &  cn_coord0,     &  !< coordinate file
490   &  in_perio0         !< periodicity index
491
492   NAMELIST /namtgt/ &  !< target/fine grid namelist
493   &  cn_coord1,     &  !< coordinate file
494   &  cn_bathy1,     &  !< bathymetry file
495   &  in_perio1         !< periodicity index
496 
497   NAMELIST /namzgr/ &
498   &  dn_pp_to_be_computed, &
499   &  dn_ppsur,      &
500   &  dn_ppa0,       &
501   &  dn_ppa1,       &
502   &  dn_ppa2,       &
503   &  dn_ppkth,      &
504   &  dn_ppkth2,     &
505   &  dn_ppacr,      &
506   &  dn_ppacr2,     &
507   &  dn_ppdzmin,    &
508   &  dn_pphmax,     &
509   &  in_nlevel         !< number of vertical level
510
511   NAMELIST /namzps/ &
512   &  dn_e3zps_min,  &
513   &  dn_e3zps_rat
514
515   NAMELIST /namvar/ &  !< variable namelist
516   &  cn_varfile,    &  !< list of variable file
517   &  cn_varinfo        !< list of variable and interpolation method to be used.
518
519   NAMELIST /namnst/ &  !< nesting namelist
520   &  in_rhoi,       &  !< refinement factor in i-direction
521   &  in_rhoj           !< refinement factor in j-direction
522
523   NAMELIST /namout/ &  !< output namelist
524   &  cn_fileout,    &  !< fine grid bathymetry file
525   &  ln_extrap,     &  !< extrapolate or not
526   &  in_niproc,     &  !< i-direction number of processor
527   &  in_njproc,     &  !< j-direction numebr of processor
528   &  in_nproc,      &  !< number of processor to be used
529   &  cn_type           !< output type format (dimg, cdf)
530   !-------------------------------------------------------------------
531
532   !
533   ! Initialisation
534   ! --------------
535   !
536   il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
537
538   ! Traitement des arguments fournis
539   ! --------------------------------
540   IF( il_narg /= 1 )THEN
541      WRITE(cl_errormsg,*) ' ERROR : one argument is needed '
542      CALL fct_help(cp_myname,cl_errormsg) 
543      CALL EXIT(1)
544   ELSE
545
546      CALL GET_COMMAND_ARGUMENT(1,cl_arg) !f03 intrinsec
547      SELECT CASE (cl_arg)
548         CASE ('-v', '--version')
549
550            CALL fct_version(cp_myname)
551            CALL EXIT(0)
552
553         CASE ('-h', '--help')
554
555            CALL fct_help(cp_myname)
556            CALL EXIT(0)
557
558         CASE DEFAULT
559
560            cl_namelist=cl_arg
561
562            ! read namelist
563            INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist)
564            IF( ll_exist )THEN
565
566               il_fileid=fct_getunit()
567
568               OPEN( il_fileid, FILE=TRIM(cl_namelist),  &
569               &                FORM='FORMATTED',        &
570               &                ACCESS='SEQUENTIAL',     &
571               &                STATUS='OLD',            &
572               &                ACTION='READ',           &
573               &                IOSTAT=il_status)
574               CALL fct_err(il_status)
575               IF( il_status /= 0 )THEN
576                  WRITE(cl_errormsg,*) " ERROR : error opening "//TRIM(cl_namelist)
577                  CALL fct_help(cp_myname,cl_errormsg) 
578                  CALL EXIT(1)
579               ENDIF
580
581               READ( il_fileid, NML = namlog )
582 
583               ! define logger file
584               CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror)
585               CALL logger_header()
586
587               READ( il_fileid, NML = namcfg )
588               ! get variable extra information
589               CALL var_def_extra(TRIM(cn_varcfg))
590
591               ! get dimension allowed
592               CALL dim_def_extra(TRIM(cn_dimcfg))
593
594               ! get dummy variable
595               CALL var_get_dummy(TRIM(cn_dumcfg))
596               ! get dummy dimension
597               CALL dim_get_dummy(TRIM(cn_dumcfg))
598               ! get dummy attribute
599               CALL att_get_dummy(TRIM(cn_dumcfg))
600
601               READ( il_fileid, NML = namsrc )
602               READ( il_fileid, NML = namtgt )
603               READ( il_fileid, NML = namzgr )
604               READ( il_fileid, NML = namvar )
605               ! add user change in extra information
606               CALL var_chg_extra(cn_varinfo)
607               ! match variable with file
608               tl_multi=multi_init(cn_varfile)
609
610               READ( il_fileid, NML = namnst )
611               READ( il_fileid, NML = namout )
612
613               CLOSE( il_fileid, IOSTAT=il_status )
614               CALL fct_err(il_status)
615               IF( il_status /= 0 )THEN
616                  CALL logger_error("CREATE RESTART: closing "//TRIM(cl_namelist))
617               ENDIF
618
619            ELSE
620
621               WRITE(cl_errormsg,*) " ERROR : can't find "//TRIM(cl_namelist)
622               CALL fct_help(cp_myname,cl_errormsg) 
623               CALL EXIT(1)
624
625            ENDIF
626
627      END SELECT
628   ENDIF
629
630   CALL multi_print(tl_multi)
631
632   IF( tl_multi%i_nvar <= 0 )THEN
633      CALL logger_fatal("CREATE RESTART: no variable to be used."//&
634      &  " check namelist.")
635   ENDIF
636
637   ! open files
638   IF( cn_coord0 /= '' )THEN
639      tl_file=file_init(TRIM(cn_coord0))
640      tl_coord0=mpp_init( tl_file, id_perio=in_perio0)
641      ! clean
642      CALL file_clean(tl_file)
643      CALL grid_get_info(tl_coord0)
644   ELSE
645      CALL logger_fatal("CREATE RESTART: no coarse grid coordinate found. "//&
646      &     "check namelist")     
647   ENDIF
648
649   IF( TRIM(cn_coord1) /= '' )THEN
650      tl_file=file_init(TRIM(cn_coord1))
651      tl_coord1=mpp_init( tl_file, id_perio=in_perio1)
652      ! clean
653      CALL file_clean(tl_file)
654      CALL grid_get_info(tl_coord1)
655   ELSE
656      CALL logger_fatal("CREATE RESTART: no fine grid coordinate found. "//&
657      &     "check namelist")
658   ENDIF
659
660   IF( TRIM(cn_bathy1) /= '' )THEN
661      tl_file=file_init(TRIM(cn_bathy1))
662      tl_bathy1=mpp_init( tl_file, id_perio=in_perio1)
663      ! clean
664      CALL file_clean(tl_file)
665      CALL grid_get_info(tl_bathy1)
666   ELSE
667      CALL logger_fatal("CREATE RESTART: no fine grid bathymetry found. "//&
668      &     "check namelist")
669   ENDIF
670
671   ! check
672   ! check output file do not already exist
673   IF( in_nproc > 0 )THEN
674      cl_fileout=file_rename(cn_fileout,1)
675   ELSE
676      cl_fileout=file_rename(cn_fileout)
677   ENDIF
678   INQUIRE(FILE=TRIM(cl_fileout), EXIST=ll_exist)
679   IF( ll_exist )THEN
680      CALL logger_fatal("CREATE RESTART: output file "//TRIM(cl_fileout)//&
681      &  " already exist.")
682   ENDIF
683
684   ! check refinement factor
685   il_rho(:)=1
686   IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN
687      CALL logger_error("CREATE RESTART: invalid refinement factor."//&
688      &  " check namelist "//TRIM(cl_namelist))
689   ELSE
690      il_rho(jp_I)=in_rhoi
691      il_rho(jp_J)=in_rhoj
692   ENDIF
693
694   ! check domain indices
695   ! compute coarse grid indices around fine grid
696   il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1, &
697   &                                 id_rho=il_rho(:))
698
699   il_imin0=il_ind(1,1) ; il_imax0=il_ind(1,2)
700   il_jmin0=il_ind(2,1) ; il_jmax0=il_ind(2,2)
701
702   ! check domain validity
703   CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0)
704
705   !3-2-4 check coincidence between coarse and fine grid
706   CALL grid_check_coincidence( tl_coord0, tl_coord1, &
707   &                            il_imin0, il_imax0, &
708   &                            il_jmin0, il_jmax0, &
709   &                            il_rho(:) )
710
711   ! fine grid ghost cell
712   il_xghost(:,:)=grid_get_ghost(tl_bathy1)
713
714   ! work on variables
715   IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN
716      CALL logger_error("CREATE RESTART: no file to work on. "//&
717      &                 "check cn_varfile in namelist.")
718   ELSE
719      ALLOCATE( tl_var( tl_multi%i_nvar ) )
720
721      jvar=0
722      ! for each file
723      DO ji=1,tl_multi%i_nmpp
724
725         WRITE(cl_data,'(a,i2.2)') 'data-',jvar+1
726         IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
727
728            CALL logger_error("CREATE RESTART: no variable to work on for "//&
729            &                 "mpp "//TRIM(tl_multi%t_mpp(ji)%c_name)//&
730            &                 ". check cn_varfile in namelist.")
731
732         ELSEIF( TRIM(tl_multi%t_mpp(ji)%c_name) == TRIM(cl_data) )THEN
733         !- use input matrix to fill variable
734
735            WRITE(*,'(a)') "work on data"
736            ! for each variable initialise from matrix
737            DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
738
739               jvar=jvar+1
740
741               WRITE(*,'(2x,a,a)') "work on variable "//&
742               &  TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
743
744               ! fill value with matrix data
745               tl_var(jvar) = create_restart_matrix( &
746               &  tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj), tl_coord1, &
747               &  in_nlevel, il_xghost(:,:) )
748
749               ! add ghost cell
750               CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:))
751
752            ENDDO
753         !- end of use input matrix to fill variable
754         ELSE
755         !- use mpp file to fill variable
756
757            WRITE(*,'(a)') "work on file "//TRIM(tl_multi%t_mpp(ji)%c_name)
758            !
759            tl_file=file_init(TRIM(tl_multi%t_mpp(ji)%t_proc(1)%c_name), &
760               &              id_perio=tl_multi%t_mpp(ji)%i_perio)
761            tl_mpp=mpp_init( tl_file )
762            ! clean
763            CALL file_clean(tl_file)
764            CALL grid_get_info(tl_mpp)
765
766            ! check vertical dimension
767            IF( tl_mpp%t_dim(jp_K)%l_use .AND. &
768            &   tl_mpp%t_dim(jp_K)%i_len /= in_nlevel  )THEN
769               CALL logger_error("CREATE RESTART: dimension in file "//&
770               &  TRIM(tl_mpp%c_name)//" not agree with namelist in_nlevel ")
771            ENDIF
772
773            ! open mpp file
774            CALL iom_mpp_open(tl_mpp)
775
776            ! get or check depth value
777            CALL create_restart_check_depth( tl_mpp, tl_depth )
778
779            ! get or check time value
780            CALL create_restart_check_time( tl_mpp, tl_time )
781
782            ! close mpp file
783            CALL iom_mpp_close(tl_mpp)
784
785            IF( ANY(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) .OR.&
786            &   ALL(il_rho(:)==1) )THEN
787            !!! extract value from fine grid
788
789               IF( ANY( tl_mpp%t_dim(1:2)%i_len < &
790               &        tl_coord1%t_dim(1:2)%i_len) )THEN
791                  CALL logger_fatal("CREATE RESTART: dimensions in file "//&
792                  &  TRIM(tl_mpp%c_name)//" smaller than those in fine"//&
793                  &  " grid coordinates.")
794               ENDIF
795
796               ! use coord0 instead of mpp for restart file case
797               !  (without lon,lat)
798               ll_sameGrid=.FALSE.
799               IF( ALL(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) &
800               &   )THEN
801                  ll_sameGrid=.TRUE. 
802               ENDIF
803
804               ! compute domain on fine grid
805               IF( ll_sameGrid )THEN
806                  il_ind(:,:)=grid_get_coarse_index(tl_mpp, tl_coord1 )
807               ELSE
808                  il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1 )
809               ENDIF
810
811               il_imin1=il_ind(1,1) ; il_imax1=il_ind(1,2)
812               il_jmin1=il_ind(2,1) ; il_jmax1=il_ind(2,2)
813
814               !- check grid coincidence
815               IF( ll_sameGrid )THEN
816                  il_rho(:)=1
817                  CALL grid_check_coincidence( tl_mpp, tl_coord1, &
818                  &                            il_imin1, il_imax1, &
819                  &                            il_jmin1, il_jmax1, &
820                  &                            il_rho(:) )
821               ELSE
822                  CALL grid_check_coincidence( tl_coord0, tl_coord1, &
823                  &                            il_imin1, il_imax1, &
824                  &                            il_jmin1, il_jmax1, &
825                  &                            il_rho(:) )
826               ENDIF
827
828               ! compute domain
829               tl_dom1=dom_init(tl_mpp,         &
830               &                il_imin1, il_imax1, &
831               &                il_jmin1, il_jmax1)
832               
833               ! open mpp files
834               CALL iom_dom_open(tl_mpp, tl_dom1)
835
836               ! for each variable of this file
837               DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
838
839                  WRITE(*,'(2x,a,a)') "work on (extract) variable "//&
840                  &  TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
841
842                  jvar=jvar+1
843                  cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name
844                  ! read variable over domain
845                  tl_var(jvar)=iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom1)
846
847                  ! add attribute to variable
848                  tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
849                  CALL var_move_att(tl_var(jvar), tl_att)
850
851                  tl_att=att_init('src_i_indices',(/il_imin0, il_imax0/))
852                  CALL var_move_att(tl_var(jvar), tl_att)
853
854                  tl_att=att_init('src_j_indices',(/il_jmin0, il_jmax0/))
855                  CALL var_move_att(tl_var(jvar), tl_att)
856
857                  ! clean structure
858                  CALL att_clean(tl_att)
859
860                  ! add ghost cell
861                  CALL grid_add_ghost(tl_var(jvar), tl_dom1%i_ghost(:,:))
862
863               ENDDO
864
865               ! close mpp file
866               CALL iom_dom_close(tl_mpp)
867
868               ! clean structure
869               CALL mpp_clean(tl_mpp)
870               CALL dom_clean(tl_dom1)
871
872            ELSE
873            !!! get value from coarse grid
874
875               ! compute domain on coarse grid
876               tl_dom0=dom_init(tl_mpp,             &
877               &                il_imin0, il_imax0, &
878               &                il_jmin0, il_jmax0 )
879
880               ! add extra band (if possible) to compute interpolation
881               CALL dom_add_extra(tl_dom0)
882
883               ! open mpp files
884               CALL iom_dom_open(tl_mpp, tl_dom0)
885               ! for each variable of this file
886               DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
887
888                  WRITE(*,'(2x,a,a)') "work on (interp) variable "//&
889                  &  TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
890
891                  jvar=jvar+1
892                  cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name
893
894                  ! read variable over domain
895                  tl_var(jvar)=iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom0)
896
897                  il_offset(:,:)=grid_get_fine_offset(tl_coord0, &
898                     &                                il_imin0, il_jmin0, &
899                     &                                il_imax0, il_jmax0, &
900                     &                                tl_coord1, &
901                     &                                id_rho=il_rho(:), &
902                     &                                cd_point=TRIM(tl_var(jvar)%c_point))
903
904                  ! interpolate variable
905                  CALL create_restart_interp(tl_var(jvar), & 
906                     &                       il_rho(:), &
907                     &                       id_offset=il_offset(:,:))
908
909                  ! remove extraband added to domain
910                  CALL dom_del_extra( tl_var(jvar), tl_dom0, il_rho(:) )
911
912                  ! add attribute to variable
913                  tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
914                  CALL var_move_att(tl_var(jvar), tl_att)
915
916                  tl_att=att_init('src_i-indices',(/il_imin0, il_imax0/))
917                  CALL var_move_att(tl_var(jvar), tl_att)
918
919                  tl_att=att_init('src_j-indices',(/il_jmin0, il_jmax0/))
920                  CALL var_move_att(tl_var(jvar), tl_att)
921
922                  IF( ANY(il_rho(:)/=1) )THEN
923                     tl_att=att_init("refinment_factor", &
924                     &               (/il_rho(jp_I),il_rho(jp_J)/))
925                     CALL var_move_att(tl_var(jvar), tl_att)
926                  ENDIF
927
928                  ! clean structure
929                  CALL att_clean(tl_att)
930
931                  ! add ghost cell
932                  CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:))
933               ENDDO
934
935               ! close mpp file
936               CALL iom_dom_close(tl_mpp)
937
938               ! clean structure
939               CALL mpp_clean(tl_mpp)
940               CALL dom_clean(tl_dom0)
941
942            ENDIF
943
944            ! clean structure
945            CALL mpp_clean(tl_mpp)
946         ENDIF
947      ENDDO
948   ENDIF
949
950   il_nvar=tl_multi%i_nvar
951
952   ! clean
953   CALL multi_clean(tl_multi)
954   CALL mpp_clean(tl_coord0)
955
956   IF( .NOT. ln_extrap )THEN
957      ! compute level
958      ALLOCATE(tl_level(ip_npoint))
959      tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist )
960   ENDIF
961
962   ! clean
963   CALL mpp_clean(tl_bathy1)
964
965   ! use additional request
966   DO jvar=1,il_nvar
967
968      ! change unit and apply factor
969      CALL var_chg_unit(tl_var(jvar))
970
971      ! forced min and max value
972      CALL var_limit_value(tl_var(jvar))
973
974      ! filter
975      CALL filter_fill_value(tl_var(jvar))
976
977      IF( .NOT. ln_extrap )THEN
978         ! use mask
979         CALL create_restart_mask(tl_var(jvar), tl_level(:))
980      ENDIF
981
982   ENDDO
983
984   ! create file
985   IF( in_niproc == 0 .AND. &
986   &   in_njproc == 0 .AND. &
987   &   in_nproc == 0 )THEN
988      in_niproc = 1
989      in_njproc = 1
990      in_nproc = 1
991   ENDIF
992
993   ! add dimension
994   tl_dim(:)=var_max_dim(tl_var(:))
995
996   DO ji=1,il_nvar
997
998      IF( ALL(tl_var(ji)%t_dim(:)%i_len == tl_dim(:)%i_len) )THEN
999         tl_mppout=mpp_init( TRIM(cn_fileout), tl_var(ji), &
1000         &                   in_niproc, in_njproc, in_nproc, &
1001         &                   cd_type=cn_type)
1002         EXIT
1003      ENDIF
1004
1005   ENDDO
1006
1007   DO ji=1,ip_maxdim
1008
1009      IF( tl_dim(ji)%l_use )THEN
1010         CALL mpp_move_dim(tl_mppout, tl_dim(ji))
1011         SELECT CASE(TRIM(tl_dim(ji)%c_sname))
1012         CASE('z','t')
1013            DO jj=1,tl_mppout%i_nproc
1014               CALL file_add_dim(tl_mppout%t_proc(jj), tl_dim(ji))
1015            ENDDO
1016         END SELECT
1017      ENDIF
1018
1019   ENDDO
1020
1021   ! add variables
1022   IF( ALL( tl_dim(1:2)%l_use ) )THEN
1023
1024      ! open mpp files
1025      CALL iom_mpp_open(tl_coord1)
1026
1027      ! add longitude
1028      il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'longitude')
1029      IF( il_varid == 0 )THEN
1030         il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'longitude_T')
1031      ENDIF
1032      tl_lon=iom_mpp_read_var(tl_coord1, il_varid)
1033      CALL mpp_add_var(tl_mppout, tl_lon)
1034      CALL var_clean(tl_lon)
1035
1036      ! add latitude
1037      il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'latitude')
1038      IF( il_varid == 0 )THEN
1039         il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'latitude_T')
1040      ENDIF
1041      tl_lat=iom_mpp_read_var(tl_coord1, il_varid)
1042      CALL mpp_add_var(tl_mppout, tl_lat)
1043      CALL var_clean(tl_lat)
1044
1045      ! close mpp files
1046      CALL iom_mpp_close(tl_coord1)
1047
1048   ENDIF
1049
1050   IF( tl_dim(3)%l_use )THEN
1051      IF( ASSOCIATED(tl_depth%d_value) )THEN
1052         ! add depth
1053         CALL mpp_add_var(tl_mppout, tl_depth)
1054      ELSE
1055         CALL logger_warn("CREATE RESTART: no value for depth variable.")
1056      ENDIF
1057   ENDIF
1058   IF( ASSOCIATED(tl_depth%d_value) ) CALL var_clean(tl_depth)
1059
1060   IF( tl_dim(4)%l_use )THEN
1061      IF( ASSOCIATED(tl_time%d_value) )THEN
1062         ! add time
1063         CALL mpp_add_var(tl_mppout, tl_time)
1064      ELSE
1065         CALL logger_warn("CREATE RESTART: no value for time variable.")
1066      ENDIF
1067   ENDIF
1068   IF( ASSOCIATED(tl_time%d_value) ) CALL var_clean(tl_time)
1069
1070   ! add other variable
1071   DO jvar=il_nvar,1,-1
1072      ! check if variable already add
1073      il_index=var_get_index(tl_mppout%t_proc(1)%t_var(:), tl_var(jvar)%c_name)
1074      IF( il_index == 0 )THEN
1075         CALL mpp_add_var(tl_mppout, tl_var(jvar))
1076         CALL var_clean(tl_var(jvar))
1077      ENDIF
1078   ENDDO
1079
1080   ! add some attribute
1081   tl_att=att_init("Created_by","SIREN create_restart")
1082   CALL mpp_add_att(tl_mppout, tl_att)
1083
1084   !add source url
1085   cl_url=fct_split(fct_split(cp_url,2,'$'),2,'URL:')
1086   tl_att=att_init("SIREN_url",cl_url)
1087   CALL mpp_add_att(tl_mppout, tl_att)
1088
1089   ! add date of creation
1090   cl_date=date_print(date_now())
1091   tl_att=att_init("Creation_date",TRIM(cl_date))
1092   CALL mpp_add_att(tl_mppout, tl_att)
1093
1094   ! add attribute periodicity
1095   il_attid=0
1096   IF( ASSOCIATED(tl_mppout%t_proc(1)%t_att) )THEN
1097      il_attid=att_get_id(tl_mppout%t_proc(1)%t_att(:),'periodicity')
1098   ENDIF
1099   IF( tl_coord1%i_perio >= 0 .AND. il_attid == 0 )THEN
1100      tl_att=att_init('periodicity',tl_coord1%i_perio)
1101      CALL mpp_add_att(tl_mppout,tl_att)
1102   ENDIF
1103
1104   il_attid=0
1105   IF( ASSOCIATED(tl_mppout%t_proc(1)%t_att) )THEN
1106      il_attid=att_get_id(tl_mppout%t_proc(1)%t_att(:),'ew_overlap')
1107   ENDIF
1108   IF( tl_coord1%i_ew >= 0 .AND. il_attid == 0 )THEN
1109      tl_att=att_init('ew_overlap',tl_coord1%i_ew)
1110      CALL mpp_add_att(tl_mppout,tl_att)
1111   ENDIF
1112
1113   ! print
1114   CALL mpp_print(tl_mppout)
1115
1116   ! create file
1117   CALL iom_mpp_create(tl_mppout)
1118
1119   ! write file
1120   CALL iom_mpp_write_file(tl_mppout)
1121   ! close file
1122   CALL iom_mpp_close(tl_mppout)
1123
1124   ! clean
1125   CALL att_clean(tl_att)
1126   CALL var_clean(tl_var(:))
1127   DEALLOCATE(tl_var)
1128   IF( .NOT. ln_extrap )THEN
1129      CALL var_clean(tl_level(:))
1130      DEALLOCATE(tl_level)
1131   ENDIF
1132
1133   CALL mpp_clean(tl_mppout)
1134   CALL mpp_clean(tl_coord1)
1135   CALL var_clean_extra()
1136
1137   ! close log file
1138   CALL logger_footer()
1139   CALL logger_close()
1140
1141CONTAINS
1142   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1143   FUNCTION create_restart_matrix(td_var, td_coord, id_nlevel, id_xghost) &
1144         & RESULT (tf_var)
1145   !-------------------------------------------------------------------
1146   !> @brief
1147   !> This function create variable, filled with matrix value
1148   !>
1149   !> @details
1150   !> A variable is create with the same name that the input variable,
1151   !> and with dimension of the coordinate file.<br/>
1152   !> Then the variable array of value is split into equal subdomain.
1153   !> Each subdomain is filled with the associated value of the matrix.
1154   !>
1155   !> @author J.Paul
1156   !> @date November, 2013 - Initial Version
1157   !> @date June, 2015
1158   !> - do not use level anymore
1159   !>
1160   !> @param[in] td_var    variable structure
1161   !> @param[in] td_coord  coordinate file structure
1162   !> @param[in] id_nlevel number of vertical level 
1163   !> @param[in] id_xghost ghost cell array
1164   !> @return variable structure
1165   !-------------------------------------------------------------------
1166
1167      IMPLICIT NONE
1168
1169      ! Argument
1170      TYPE(TVAR)                 , INTENT(IN) :: td_var
1171      TYPE(TMPP)                 , INTENT(IN) :: td_coord
1172      INTEGER(i4)                , INTENT(IN) :: id_nlevel
1173      INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_xghost
1174
1175      ! function
1176      TYPE(TVAR)                              :: tf_var
1177
1178      ! local variable
1179      INTEGER(i4)      , DIMENSION(3)                    :: il_dim
1180      INTEGER(i4)      , DIMENSION(3)                    :: il_size
1181      INTEGER(i4)      , DIMENSION(3)                    :: il_rest
1182
1183      INTEGER(i4)      , DIMENSION(:)      , ALLOCATABLE :: il_ishape
1184      INTEGER(i4)      , DIMENSION(:)      , ALLOCATABLE :: il_jshape
1185      INTEGER(i4)      , DIMENSION(:)      , ALLOCATABLE :: il_kshape
1186
1187      REAL(dp)         , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
1188
1189      TYPE(TDIM)       , DIMENSION(ip_maxdim)            :: tl_dim
1190
1191      ! loop indices
1192      INTEGER(i4) :: ji
1193      INTEGER(i4) :: jj
1194      INTEGER(i4) :: jk
1195      !----------------------------------------------------------------
1196
1197      ! write value on grid
1198      ! get matrix dimension
1199      il_dim(:)=td_var%t_dim(1:3)%i_len
1200
1201      ! output dimension
1202      tl_dim(jp_I:jp_J)=dim_copy(td_coord%t_dim(jp_I:jp_J))
1203      IF( id_nlevel >= 1 )THEN
1204         tl_dim(jp_K)=dim_init('Z',id_nlevel)
1205      ENDIF
1206
1207      ! remove ghost cell
1208      tl_dim(jp_I)%i_len=tl_dim(jp_I)%i_len - SUM(id_xghost(jp_I,:))*ip_ghost
1209      tl_dim(jp_J)%i_len=tl_dim(jp_J)%i_len - SUM(id_xghost(jp_J,:))*ip_ghost
1210
1211      ! split output domain in N subdomain depending of matrix dimension
1212      il_size(:) = tl_dim(1:3)%i_len / il_dim(:)
1213      il_rest(:) = MOD(tl_dim(1:3)%i_len, il_dim(:))
1214
1215      ALLOCATE( il_ishape(il_dim(1)+1) )
1216      il_ishape(:)=0
1217      DO ji=2,il_dim(1)+1
1218         il_ishape(ji)=il_ishape(ji-1)+il_size(1)
1219      ENDDO
1220      ! add rest to last cell
1221      il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1)
1222
1223      ALLOCATE( il_jshape(il_dim(2)+1) )
1224      il_jshape(:)=0
1225      DO jj=2,il_dim(2)+1
1226         il_jshape(jj)=il_jshape(jj-1)+il_size(2)
1227      ENDDO
1228      ! add rest to last cell
1229      il_jshape(il_dim(2)+1)=il_jshape(il_dim(2)+1)+il_rest(2)
1230
1231      ALLOCATE( il_kshape(il_dim(3)+1) )
1232      il_kshape(:)=0
1233      DO jk=2,il_dim(3)+1
1234         il_kshape(jk)=il_kshape(jk-1)+il_size(3)
1235      ENDDO
1236      ! add rest to last cell
1237      il_kshape(il_dim(3)+1)=il_kshape(il_dim(3)+1)+il_rest(3)
1238
1239      ! write ouput array of value
1240      ALLOCATE(dl_value( tl_dim(1)%i_len, &
1241      &                  tl_dim(2)%i_len, &
1242      &                  tl_dim(3)%i_len, &
1243      &                  tl_dim(4)%i_len) )
1244
1245      dl_value(:,:,:,:)=0
1246
1247      DO jk=2,il_dim(3)+1
1248         DO jj=2,il_dim(2)+1
1249            DO ji=2,il_dim(1)+1
1250               
1251               dl_value( 1+il_ishape(ji-1):il_ishape(ji), &
1252               &         1+il_jshape(jj-1):il_jshape(jj), &
1253               &         1+il_kshape(jk-1):il_kshape(jk), &
1254               &         1 ) = td_var%d_value(ji-1,jj-1,jk-1,1)
1255
1256            ENDDO
1257         ENDDO
1258      ENDDO
1259
1260      ! keep attribute and type
1261      tf_var=var_copy(td_var)
1262      DEALLOCATE( tf_var%d_value )
1263      ! save new dimension
1264      tf_var%t_dim(:)=dim_copy(tl_dim(:))
1265      ! add variable value
1266      CALL var_add_value( tf_var, dl_value(:,:,:,:), &
1267      &                   id_type=td_var%i_type)
1268
1269      DEALLOCATE(dl_value)
1270
1271      ! clean
1272      DEALLOCATE(il_ishape)
1273      DEALLOCATE(il_jshape)
1274      DEALLOCATE(il_kshape)
1275
1276   END FUNCTION create_restart_matrix
1277   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1278   SUBROUTINE create_restart_mask(td_var, td_mask)
1279   !-------------------------------------------------------------------
1280   !> @brief
1281   !> This subroutine use mask to filled land point with _FillValue
1282   !>
1283   !> @author J.Paul
1284   !> @date November, 2013 - Initial Version
1285   !>
1286   !> @param[inout] td_var variable structure
1287   !> @param[in] td_mask   mask variable structure
1288   !-------------------------------------------------------------------
1289
1290      IMPLICIT NONE
1291
1292      ! Argument
1293      TYPE(TVAR)              , INTENT(INOUT) :: td_var
1294      TYPE(TVAR), DIMENSION(:), INTENT(IN   ) :: td_mask
1295
1296      ! local variable
1297      INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask
1298
1299      ! loop indices
1300      INTEGER(i4) :: jl
1301      INTEGER(i4) :: jk
1302      !----------------------------------------------------------------
1303
1304      IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
1305         IF( ANY(td_var%t_dim(1:2)%i_len /= td_mask(1)%t_dim(1:2)%i_len) )THEN
1306            CALL logger_error("CREATE RESTART MASK: dimension differ between"//&
1307            &                 " variable "//TRIM(td_var%c_name)//" ("//&
1308            &                 TRIM(fct_str(td_var%t_dim(1)%i_len))//","//&
1309            &                 TRIM(fct_str(td_var%t_dim(2)%i_len))//&
1310            &                 ") and level ("//&
1311            &                 TRIM(fct_str(td_mask(1)%t_dim(1)%i_len))//","//&
1312            &                 TRIM(fct_str(td_mask(1)%t_dim(2)%i_len))//")")
1313         ELSE
1314            ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
1315            &                 td_var%t_dim(2)%i_len) )
1316
1317            SELECT CASE(TRIM(td_var%c_point))
1318            CASE('T')
1319               il_mask(:,:)=INT(td_mask(jp_T)%d_value(:,:,1,1))
1320            CASE('U')
1321               il_mask(:,:)=INT(td_mask(jp_U)%d_value(:,:,1,1))
1322            CASE('V')
1323               il_mask(:,:)=INT(td_mask(jp_V)%d_value(:,:,1,1))
1324            CASE('F')
1325               il_mask(:,:)=INT(td_mask(jp_F)%d_value(:,:,1,1))
1326            END SELECT
1327
1328            DO jl=1,td_var%t_dim(4)%i_len
1329               DO jk=1,td_var%t_dim(3)%i_len
1330                  WHERE( il_mask(:,:) < jk )
1331                     td_var%d_value(:,:,jk,jl)=td_var%d_fill
1332                  END WHERE
1333               ENDDO
1334            ENDDO
1335
1336            DEALLOCATE( il_mask )
1337         ENDIF
1338      ENDIF
1339   END SUBROUTINE create_restart_mask
1340   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1341   SUBROUTINE create_restart_interp(td_var, id_rho, id_offset, &
1342         &                          id_iext, id_jext)
1343   !-------------------------------------------------------------------
1344   !> @brief
1345   !> This subroutine interpolate variable
1346   !>
1347   !> @author J.Paul
1348   !> @date November, 2013 - Initial Version
1349   !> @date June, 2015
1350   !> - do not use level anymore (for extrapolation)
1351   !>
1352   !> @param[inout] td_var    variable structure
1353   !> @param[in] id_rho       array of refinment factor
1354   !> @param[in] id_offset    array of offset between fine and coarse grid
1355   !> @param[in] id_iext      i-direction size of extra bands (default=im_minext)
1356   !> @param[in] id_jext      j-direction size of extra bands (default=im_minext)
1357   !-------------------------------------------------------------------
1358
1359      IMPLICIT NONE
1360
1361      ! Argument
1362      TYPE(TVAR) ,                 INTENT(INOUT) :: td_var
1363      INTEGER(i4), DIMENSION(:)  , INTENT(IN   ) :: id_rho
1364      INTEGER(i4), DIMENSION(:,:), INTENT(IN   ) :: id_offset
1365      INTEGER(i4),                 INTENT(IN   ), OPTIONAL :: id_iext
1366      INTEGER(i4),                 INTENT(IN   ), OPTIONAL :: id_jext
1367
1368      ! local variable
1369      INTEGER(i4) :: il_iext
1370      INTEGER(i4) :: il_jext
1371
1372      ! loop indices
1373      !----------------------------------------------------------------
1374
1375      il_iext=3
1376      IF( PRESENT(id_iext) ) il_iext=id_iext
1377
1378      il_jext=3
1379      IF( PRESENT(id_jext) ) il_jext=id_jext
1380
1381      IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
1382         CALL logger_warn("CREATE RESTART INTERP: at least extrapolation "//&
1383         &  "on two points are required with cubic interpolation ")
1384         il_iext=2
1385      ENDIF
1386
1387      IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
1388         CALL logger_warn("CREATE RESTART INTERP: at least extrapolation "//&
1389         &  "on two points are required with cubic interpolation ")
1390         il_jext=2
1391      ENDIF
1392      ! work on variable
1393      ! add extraband
1394      CALL extrap_add_extrabands(td_var, il_iext, il_jext)
1395
1396      ! extrapolate variable
1397      CALL extrap_fill_value( td_var )
1398
1399      ! interpolate variable
1400      CALL interp_fill_value( td_var, id_rho(:), &
1401      &                       id_offset=id_offset(:,:) )
1402
1403      ! remove extraband
1404      CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
1405
1406   END SUBROUTINE create_restart_interp
1407   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1408   SUBROUTINE create_restart_check_depth(td_mpp, td_depth)
1409   !-------------------------------------------------------------------
1410   !> @brief
1411   !> This subroutine get depth variable value in an open mpp structure
1412   !> and check if agree with already input depth variable.
1413   !>
1414   !> @details
1415   !>
1416   !> @author J.Paul
1417   !> @date November, 2014 - Initial Version
1418   !>
1419   !> @param[in] td_mpp       mpp structure
1420   !> @param[inout] td_depth  depth variable structure
1421   !-------------------------------------------------------------------
1422
1423      IMPLICIT NONE
1424
1425      ! Argument
1426      TYPE(TMPP), INTENT(IN   ) :: td_mpp
1427      TYPE(TVAR), INTENT(INOUT) :: td_depth
1428
1429      ! local variable
1430      INTEGER(i4) :: il_varid
1431      TYPE(TVAR)  :: tl_depth
1432      ! loop indices
1433      !----------------------------------------------------------------
1434
1435      ! get or check depth value
1436      IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN
1437
1438         il_varid=td_mpp%t_proc(1)%i_depthid
1439         IF( ASSOCIATED(td_depth%d_value) )THEN
1440
1441            tl_depth=iom_mpp_read_var(td_mpp, il_varid)
1442            IF( ANY( td_depth%d_value(:,:,:,:) /= &
1443            &        tl_depth%d_value(:,:,:,:) ) )THEN
1444
1445               CALL logger_warn("CREATE RESTART: depth value from "//&
1446               &  TRIM(td_mpp%c_name)//" not conform "//&
1447               &  " to those from former file(s).")
1448
1449            ENDIF
1450            CALL var_clean(tl_depth)
1451
1452         ELSE
1453            td_depth=iom_mpp_read_var(td_mpp,il_varid)
1454         ENDIF
1455
1456      ENDIF
1457     
1458   END SUBROUTINE create_restart_check_depth
1459   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1460   SUBROUTINE create_restart_check_time(td_mpp, td_time)
1461   !-------------------------------------------------------------------
1462   !> @brief
1463   !> This subroutine get date and time in an open mpp structure
1464   !> and check if agree with date and time already read.
1465   !>
1466   !> @details
1467   !>
1468   !> @author J.Paul
1469   !> @date November, 2014 - Initial Version
1470   !>
1471   !> @param[in] td_mpp      mpp structure
1472   !> @param[inout] td_time  time variable structure
1473   !-------------------------------------------------------------------
1474
1475      IMPLICIT NONE
1476
1477      ! Argument
1478      TYPE(TMPP), INTENT(IN   ) :: td_mpp
1479      TYPE(TVAR), INTENT(INOUT) :: td_time
1480
1481      ! local variable
1482      INTEGER(i4) :: il_varid
1483      TYPE(TVAR)  :: tl_time
1484
1485      TYPE(TDATE) :: tl_date1
1486      TYPE(TDATE) :: tl_date2
1487      ! loop indices
1488      !----------------------------------------------------------------
1489
1490      ! get or check depth value
1491
1492      IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN
1493
1494         il_varid=td_mpp%t_proc(1)%i_timeid
1495         IF( ASSOCIATED(td_time%d_value) )THEN
1496
1497            tl_time=iom_mpp_read_var(td_mpp, il_varid)
1498
1499            tl_date1=var_to_date(td_time)
1500            tl_date2=var_to_date(tl_time)
1501            IF( tl_date1 - tl_date2 /= 0 )THEN
1502
1503               CALL logger_warn("CREATE BOUNDARY: date from "//&
1504               &  TRIM(td_mpp%c_name)//" not conform "//&
1505               &  " to those from former file(s).")
1506
1507            ENDIF
1508            CALL var_clean(tl_time)
1509
1510         ELSE
1511            td_time=iom_mpp_read_var(td_mpp,il_varid)
1512         ENDIF
1513
1514      ENDIF
1515     
1516   END SUBROUTINE create_restart_check_time
1517   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1518END PROGRAM create_restart
Note: See TracBrowser for help on using the repository browser.