New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

create_restart.f90 in utils/tools/SIREN/src – NEMO

Context Navigation

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

Last change on this file since 12080 was 12080, checked in by jpaul, 4 years 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	!----------------------------------------------------------------------
332	PROGRAM 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
1141	CONTAINS
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_iextid_rho(jp_I), il_jextid_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	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1518	END PROGRAM create_restart

Note: See TracBrowser for help on using the repository browser.

Download in other formats: