Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

create_restart.f90

Last change on this file was 13369, checked in by jpaul, 4 years ago
update: cf changelog inside documentation
File size: 52.2 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	!> @date July, 2020
327	!> - do not check domain validity, if source and target coordinates are the same
328	!>
329	!> @todo
330	!> - rewrite using meshmask instead of bathymetry and coordinates files
331	!>
332	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
333	!----------------------------------------------------------------------
334	PROGRAM create_restart
335
336	USE global ! global variable
337	USE kind ! F90 kind parameter
338	USE logger ! log file manager
339	USE fct ! basic useful function
340	USE date ! date manager
341	USE att ! attribute manager
342	USE dim ! dimension manager
343	USE var ! variable manager
344	USE file ! file manager
345	USE multi ! multi file manager
346	USE iom ! I/O manager
347	USE grid ! grid manager
348	USE vgrid ! vertical grid manager
349	USE extrap ! extrapolation manager
350	USE interp ! interpolation manager
351	USE filter ! filter manager
352	USE mpp ! MPP manager
353	USE dom ! domain manager
354	USE iom_mpp ! MPP I/O manager
355	USE iom_dom ! DOM I/O manager
356
357	IMPLICIT NONE
358
359	! parameters
360	CHARACTER(LEN=lc), PARAMETER :: cp_myname = "create_restart"
361
362	! local variable
363	CHARACTER(LEN=lc) :: cl_arg
364	CHARACTER(LEN=lc) :: cl_namelist
365	CHARACTER(LEN=lc) :: cl_date
366	CHARACTER(LEN=lc) :: cl_name
367	CHARACTER(LEN=lc) :: cl_data
368	CHARACTER(LEN=lc) :: cl_fileout
369	CHARACTER(LEN=lc) :: cl_url
370	CHARACTER(LEN=lc) :: cl_errormsg
371
372	INTEGER(i4) :: il_narg
373	INTEGER(i4) :: il_status
374	INTEGER(i4) :: il_fileid
375	INTEGER(i4) :: il_varid
376	INTEGER(i4) :: il_attid
377	INTEGER(i4) :: il_nvar
378	INTEGER(i4) :: il_imin1
379	INTEGER(i4) :: il_imax1
380	INTEGER(i4) :: il_jmin1
381	INTEGER(i4) :: il_jmax1
382	INTEGER(i4) :: il_imin0
383	INTEGER(i4) :: il_imax0
384	INTEGER(i4) :: il_jmin0
385	INTEGER(i4) :: il_jmax0
386	INTEGER(i4) :: il_index
387	INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho
388	INTEGER(i4) , DIMENSION(2,2) :: il_xghost
389	INTEGER(i4) , DIMENSION(2,2) :: il_offset
390	INTEGER(i4) , DIMENSION(2,2) :: il_ind
391
392	LOGICAL :: ll_exist
393	LOGICAL :: ll_sameGrid
394
395	TYPE(TDOM) :: tl_dom1
396	TYPE(TDOM) :: tl_dom0
397
398	TYPE(TATT) :: tl_att
399
400	TYPE(TVAR) :: tl_depth
401	TYPE(TVAR) :: tl_time
402	TYPE(TVAR) :: tl_lon
403	TYPE(TVAR) :: tl_lat
404	TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_var
405	TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_level
406
407	TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
408
409	TYPE(TFILE) :: tl_file
410
411	TYPE(TMPP) :: tl_coord0
412	TYPE(TMPP) :: tl_coord1
413	TYPE(TMPP) :: tl_bathy1
414	TYPE(TMPP) :: tl_mpp
415	TYPE(TMPP) :: tl_mppout
416
417	TYPE(TMULTI) :: tl_multi
418
419	! loop indices
420	INTEGER(i4) :: ji
421	INTEGER(i4) :: jj
422	INTEGER(i4) :: jvar
423
424	! namelist variable
425	! namlog
426	CHARACTER(LEN=lc) :: cn_logfile = 'create_restart.log'
427	CHARACTER(LEN=lc) :: cn_verbosity = 'warning'
428	INTEGER(i4) :: in_maxerror = 5
429
430	! namcfg
431	CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg'
432	CHARACTER(LEN=lc) :: cn_dimcfg = './cfg/dimension.cfg'
433	CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg'
434
435	! namsrc
436	CHARACTER(LEN=lc) :: cn_coord0 = ''
437	INTEGER(i4) :: in_perio0 = -1
438
439	! namtgt
440	CHARACTER(LEN=lc) :: cn_coord1 = ''
441	CHARACTER(LEN=lc) :: cn_bathy1 = ''
442	INTEGER(i4) :: in_perio1 = -1
443
444	!namzgr
445	REAL(dp) :: dn_pp_to_be_computed = 0._dp
446	REAL(dp) :: dn_ppsur = -3958.951371276829_dp
447	REAL(dp) :: dn_ppa0 = 103.953009600000_dp
448	REAL(dp) :: dn_ppa1 = 2.415951269000_dp
449	REAL(dp) :: dn_ppa2 = 100.760928500000_dp
450	REAL(dp) :: dn_ppkth = 15.351013700000_dp
451	REAL(dp) :: dn_ppkth2 = 48.029893720000_dp
452	REAL(dp) :: dn_ppacr = 7.000000000000_dp
453	REAL(dp) :: dn_ppacr2 = 13.000000000000_dp
454	REAL(dp) :: dn_ppdzmin = 6._dp
455	REAL(dp) :: dn_pphmax = 5750._dp
456	INTEGER(i4) :: in_nlevel = 75
457
458	!namzps
459	REAL(dp) :: dn_e3zps_min = 25._dp
460	REAL(dp) :: dn_e3zps_rat = 0.2_dp
461
462	! namvar
463	CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''
464	CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''
465
466	! namnst
467	INTEGER(i4) :: in_rhoi = 1
468	INTEGER(i4) :: in_rhoj = 1
469
470	! namout
471	CHARACTER(LEN=lc) :: cn_fileout = 'restart.nc'
472	LOGICAL :: ln_extrap = .FALSE.
473	INTEGER(i4) :: in_nproc = 0
474	INTEGER(i4) :: in_niproc = 0
475	INTEGER(i4) :: in_njproc = 0
476	CHARACTER(LEN=lc) :: cn_type = ''
477
478	!-------------------------------------------------------------------
479
480	NAMELIST /namlog/ & !< logger namelist
481	& cn_logfile, & !< log file
482	& cn_verbosity, & !< log verbosity
483	& in_maxerror !< logger maximum error
484
485	NAMELIST /namcfg/ & !< configuration namelist
486	& cn_varcfg, & !< variable configuration file
487	& cn_dimcfg, & !< dimension configuration file
488	& cn_dumcfg !< dummy configuration file
489
490	NAMELIST /namsrc/ & !< source/coarse grid namelist
491	& cn_coord0, & !< coordinate file
492	& in_perio0 !< periodicity index
493
494	NAMELIST /namtgt/ & !< target/fine grid namelist
495	& cn_coord1, & !< coordinate file
496	& cn_bathy1, & !< bathymetry file
497	& in_perio1 !< periodicity index
498
499	NAMELIST /namzgr/ &
500	& dn_pp_to_be_computed, &
501	& dn_ppsur, &
502	& dn_ppa0, &
503	& dn_ppa1, &
504	& dn_ppa2, &
505	& dn_ppkth, &
506	& dn_ppkth2, &
507	& dn_ppacr, &
508	& dn_ppacr2, &
509	& dn_ppdzmin, &
510	& dn_pphmax, &
511	& in_nlevel !< number of vertical level
512
513	NAMELIST /namzps/ &
514	& dn_e3zps_min, &
515	& dn_e3zps_rat
516
517	NAMELIST /namvar/ & !< variable namelist
518	& cn_varfile, & !< list of variable file
519	& cn_varinfo !< list of variable and interpolation method to be used.
520
521	NAMELIST /namnst/ & !< nesting namelist
522	& in_rhoi, & !< refinement factor in i-direction
523	& in_rhoj !< refinement factor in j-direction
524
525	NAMELIST /namout/ & !< output namelist
526	& cn_fileout, & !< fine grid bathymetry file
527	& ln_extrap, & !< extrapolate or not
528	& in_niproc, & !< i-direction number of processor
529	& in_njproc, & !< j-direction numebr of processor
530	& in_nproc, & !< number of processor to be used
531	& cn_type !< output type format (dimg, cdf)
532	!-------------------------------------------------------------------
533
534	!
535	! Initialisation
536	! --------------
537	!
538	il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
539
540	! Traitement des arguments fournis
541	! --------------------------------
542	IF( il_narg /= 1 )THEN
543	WRITE(cl_errormsg,*) ' ERROR : one argument is needed '
544	CALL fct_help(cp_myname,cl_errormsg)
545	CALL EXIT(1)
546	ELSE
547
548	CALL GET_COMMAND_ARGUMENT(1,cl_arg) !f03 intrinsec
549	SELECT CASE (cl_arg)
550	CASE ('-v', '--version')
551
552	CALL fct_version(cp_myname)
553	CALL EXIT(0)
554
555	CASE ('-h', '--help')
556
557	CALL fct_help(cp_myname)
558	CALL EXIT(0)
559
560	CASE DEFAULT
561
562	cl_namelist=cl_arg
563
564	! read namelist
565	INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist)
566	IF( ll_exist )THEN
567
568	il_fileid=fct_getunit()
569
570	OPEN( il_fileid, FILE=TRIM(cl_namelist), &
571	& FORM='FORMATTED', &
572	& ACCESS='SEQUENTIAL', &
573	& STATUS='OLD', &
574	& ACTION='READ', &
575	& IOSTAT=il_status)
576	CALL fct_err(il_status)
577	IF( il_status /= 0 )THEN
578	WRITE(cl_errormsg,*) " ERROR : error opening "//TRIM(cl_namelist)
579	CALL fct_help(cp_myname,cl_errormsg)
580	CALL EXIT(1)
581	ENDIF
582
583	READ( il_fileid, NML = namlog )
584
585	! define logger file
586	CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror)
587	CALL logger_header()
588
589	READ( il_fileid, NML = namcfg )
590	! get variable extra information
591	CALL var_def_extra(TRIM(cn_varcfg))
592
593	! get dimension allowed
594	CALL dim_def_extra(TRIM(cn_dimcfg))
595
596	! get dummy variable
597	CALL var_get_dummy(TRIM(cn_dumcfg))
598	! get dummy dimension
599	CALL dim_get_dummy(TRIM(cn_dumcfg))
600	! get dummy attribute
601	CALL att_get_dummy(TRIM(cn_dumcfg))
602
603	READ( il_fileid, NML = namsrc )
604	READ( il_fileid, NML = namtgt )
605	READ( il_fileid, NML = namzgr )
606	READ( il_fileid, NML = namvar )
607	! add user change in extra information
608	CALL var_chg_extra(cn_varinfo)
609	! match variable with file
610	tl_multi=multi_init(cn_varfile)
611
612	READ( il_fileid, NML = namnst )
613	READ( il_fileid, NML = namout )
614
615	CLOSE( il_fileid, IOSTAT=il_status )
616	CALL fct_err(il_status)
617	IF( il_status /= 0 )THEN
618	CALL logger_error("CREATE RESTART: closing "//TRIM(cl_namelist))
619	ENDIF
620
621	ELSE
622
623	WRITE(cl_errormsg,*) " ERROR : can't find "//TRIM(cl_namelist)
624	CALL fct_help(cp_myname,cl_errormsg)
625	CALL EXIT(1)
626
627	ENDIF
628
629	END SELECT
630	ENDIF
631
632	CALL multi_print(tl_multi)
633
634	IF( tl_multi%i_nvar <= 0 )THEN
635	CALL logger_fatal("CREATE RESTART: no variable to be used."//&
636	& " check namelist.")
637	ENDIF
638
639	! open files
640	IF( cn_coord0 /= '' )THEN
641	tl_file=file_init(TRIM(cn_coord0))
642	tl_coord0=mpp_init( tl_file, id_perio=in_perio0)
643	! clean
644	CALL file_clean(tl_file)
645	CALL grid_get_info(tl_coord0)
646	ELSE
647	CALL logger_fatal("CREATE RESTART: no coarse grid coordinate found. "//&
648	& "check namelist")
649	ENDIF
650
651	IF( TRIM(cn_coord1) /= '' )THEN
652	tl_file=file_init(TRIM(cn_coord1))
653	tl_coord1=mpp_init( tl_file, id_perio=in_perio1)
654	! clean
655	CALL file_clean(tl_file)
656	CALL grid_get_info(tl_coord1)
657	ELSE
658	CALL logger_fatal("CREATE RESTART: no fine grid coordinate found. "//&
659	& "check namelist")
660	ENDIF
661
662	IF( TRIM(cn_bathy1) /= '' )THEN
663	tl_file=file_init(TRIM(cn_bathy1))
664	tl_bathy1=mpp_init( tl_file, id_perio=in_perio1)
665	! clean
666	CALL file_clean(tl_file)
667	CALL grid_get_info(tl_bathy1)
668	ELSE
669	CALL logger_fatal("CREATE RESTART: no fine grid bathymetry found. "//&
670	& "check namelist")
671	ENDIF
672
673	! check
674	! check output file do not already exist
675	IF( in_nproc > 0 )THEN
676	cl_fileout=file_rename(cn_fileout,1)
677	ELSE
678	cl_fileout=file_rename(cn_fileout)
679	ENDIF
680	INQUIRE(FILE=TRIM(cl_fileout), EXIST=ll_exist)
681	IF( ll_exist )THEN
682	CALL logger_fatal("CREATE RESTART: output file "//TRIM(cl_fileout)//&
683	& " already exist.")
684	ENDIF
685
686	! check refinement factor
687	il_rho(:)=1
688	IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN
689	CALL logger_error("CREATE RESTART: invalid refinement factor."//&
690	& " check namelist "//TRIM(cl_namelist))
691	ELSE
692	il_rho(jp_I)=in_rhoi
693	il_rho(jp_J)=in_rhoj
694	ENDIF
695
696	! check domain indices
697	! compute coarse grid indices around fine grid
698	il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1, &
699	& id_rho=il_rho(:))
700
701	il_imin0=il_ind(1,1) ; il_imax0=il_ind(1,2)
702	il_jmin0=il_ind(2,1) ; il_jmax0=il_ind(2,2)
703
704	IF( TRIM(cn_coord1) /= TRIM(cn_coord0) )THEN
705	! check domain validity
706	CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0)
707	ELSE
708	CALL logger_warn("CREATE RESTART: source and target coordinate are the "//&
709	& "same. we assume you want to split it")
710	ENDIF
711
712	! check coincidence between coarse and fine grid
713	CALL grid_check_coincidence( tl_coord0, tl_coord1, &
714	& il_imin0, il_imax0, &
715	& il_jmin0, il_jmax0, &
716	& il_rho(:) )
717
718	! fine grid ghost cell
719	il_xghost(:,:)=grid_get_ghost(tl_bathy1)
720
721	! work on variables
722	IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN
723	CALL logger_error("CREATE RESTART: no file to work on. "//&
724	& "check cn_varfile in namelist.")
725	ELSE
726	ALLOCATE( tl_var( tl_multi%i_nvar ) )
727
728	jvar=0
729	! for each file
730	DO ji=1,tl_multi%i_nmpp
731
732	WRITE(cl_data,'(a,i2.2)') 'data-',jvar+1
733	IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
734
735	CALL logger_error("CREATE RESTART: no variable to work on for "//&
736	& "mpp "//TRIM(tl_multi%t_mpp(ji)%c_name)//&
737	& ". check cn_varfile in namelist.")
738
739	ELSEIF( TRIM(tl_multi%t_mpp(ji)%c_name) == TRIM(cl_data) )THEN
740	!- use input matrix to fill variable
741
742	WRITE(*,'(a)') "work on data"
743	! for each variable initialise from matrix
744	DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
745
746	jvar=jvar+1
747
748	WRITE(*,'(2x,a,a)') "work on variable "//&
749	& TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
750
751	! fill value with matrix data
752	tl_var(jvar) = create_restart_matrix( &
753	& tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj), tl_coord1, &
754	& in_nlevel, il_xghost(:,:) )
755
756	! add ghost cell
757	CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:))
758
759	ENDDO
760	!- end of use input matrix to fill variable
761	ELSE
762	!- use mpp file to fill variable
763
764	WRITE(*,'(a)') "work on file "//TRIM(tl_multi%t_mpp(ji)%c_name)
765	!
766	tl_file=file_init(TRIM(tl_multi%t_mpp(ji)%t_proc(1)%c_name), &
767	& id_perio=tl_multi%t_mpp(ji)%i_perio)
768	tl_mpp=mpp_init( tl_file, id_perio=tl_multi%t_mpp(ji)%i_perio )
769	! clean
770	CALL file_clean(tl_file)
771	CALL grid_get_info(tl_mpp)
772
773	! check vertical dimension
774	IF( tl_mpp%t_dim(jp_K)%l_use .AND. &
775	& tl_mpp%t_dim(jp_K)%i_len /= in_nlevel )THEN
776	CALL logger_error("CREATE RESTART: dimension in file "//&
777	& TRIM(tl_mpp%c_name)//" not agree with namelist in_nlevel ")
778	ENDIF
779
780	! open mpp file
781	CALL iom_mpp_open(tl_mpp)
782
783	! get or check depth value
784	CALL create_restart_check_depth( tl_mpp, tl_depth )
785
786	! get or check time value
787	CALL create_restart_check_time( tl_mpp, tl_time )
788
789	! close mpp file
790	CALL iom_mpp_close(tl_mpp)
791
792	IF( ANY(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) .OR.&
793	& ALL(il_rho(:)==1) )THEN
794	!!! extract value from fine grid
795
796	IF( ANY( tl_mpp%t_dim(1:2)%i_len < &
797	& tl_coord1%t_dim(1:2)%i_len) )THEN
798	CALL logger_fatal("CREATE RESTART: dimensions in file "//&
799	& TRIM(tl_mpp%c_name)//" smaller than those in fine"//&
800	& " grid coordinates.")
801	ENDIF
802
803	! use coord0 instead of mpp for restart file case
804	! (without lon,lat)
805	ll_sameGrid=.FALSE.
806	IF( ALL(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) &
807	& )THEN
808	ll_sameGrid=.TRUE.
809	ENDIF
810
811	! compute domain on fine grid
812	IF( ll_sameGrid )THEN
813	il_ind(:,:)=grid_get_coarse_index(tl_mpp, tl_coord1 )
814	ELSE
815	il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1 )
816	ENDIF
817
818	il_imin1=il_ind(1,1) ; il_imax1=il_ind(1,2)
819	il_jmin1=il_ind(2,1) ; il_jmax1=il_ind(2,2)
820
821	!- check grid coincidence
822	IF( ll_sameGrid )THEN
823	il_rho(:)=1
824	CALL grid_check_coincidence( tl_mpp, tl_coord1, &
825	& il_imin1, il_imax1, &
826	& il_jmin1, il_jmax1, &
827	& il_rho(:) )
828	ELSE
829	CALL grid_check_coincidence( tl_coord0, tl_coord1, &
830	& il_imin1, il_imax1, &
831	& il_jmin1, il_jmax1, &
832	& il_rho(:) )
833	ENDIF
834
835	! compute domain
836	tl_dom1=dom_init(tl_mpp, &
837	& il_imin1, il_imax1, &
838	& il_jmin1, il_jmax1)
839
840	! open mpp files
841	CALL iom_dom_open(tl_mpp, tl_dom1)
842
843	! for each variable of this file
844	DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
845
846	WRITE(*,'(2x,a,a)') "work on (extract) variable "//&
847	& TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
848
849	jvar=jvar+1
850	cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name
851	! read variable over domain
852	tl_var(jvar)=iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom1)
853
854	! add attribute to variable
855	tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
856	CALL var_move_att(tl_var(jvar), tl_att)
857
858	tl_att=att_init('src_i_indices',(/il_imin0, il_imax0/))
859	CALL var_move_att(tl_var(jvar), tl_att)
860
861	tl_att=att_init('src_j_indices',(/il_jmin0, il_jmax0/))
862	CALL var_move_att(tl_var(jvar), tl_att)
863
864	! clean structure
865	CALL att_clean(tl_att)
866
867	! add ghost cell
868	CALL grid_add_ghost(tl_var(jvar), tl_dom1%i_ghost(:,:))
869
870	ENDDO
871
872	! close mpp file
873	CALL iom_dom_close(tl_mpp)
874
875	! clean structure
876	CALL mpp_clean(tl_mpp)
877	CALL dom_clean(tl_dom1)
878
879	ELSE
880	!!! get value from coarse grid
881
882	! compute domain on coarse grid
883	tl_dom0=dom_init(tl_mpp, &
884	& il_imin0, il_imax0, &
885	& il_jmin0, il_jmax0 )
886
887	! add extra band (if possible) to compute interpolation
888	CALL dom_add_extra(tl_dom0)
889
890	! open mpp files
891	CALL iom_dom_open(tl_mpp, tl_dom0)
892	! for each variable of this file
893	DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
894
895	WRITE(*,'(2x,a,a)') "work on (interp) variable "//&
896	& TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
897
898	jvar=jvar+1
899	cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name
900
901	! read variable over domain
902	tl_var(jvar)=iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom0)
903
904	il_offset(:,:)=grid_get_fine_offset(tl_coord0, &
905	& il_imin0, il_jmin0, &
906	& il_imax0, il_jmax0, &
907	& tl_coord1, &
908	& id_rho=il_rho(:), &
909	& cd_point=TRIM(tl_var(jvar)%c_point))
910
911	! interpolate variable
912	CALL create_restart_interp(tl_var(jvar), &
913	& il_rho(:), &
914	& id_offset=il_offset(:,:))
915
916	! remove extraband added to domain
917	CALL dom_del_extra( tl_var(jvar), tl_dom0, il_rho(:) )
918
919	! add attribute to variable
920	tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
921	CALL var_move_att(tl_var(jvar), tl_att)
922
923	tl_att=att_init('src_i-indices',(/il_imin0, il_imax0/))
924	CALL var_move_att(tl_var(jvar), tl_att)
925
926	tl_att=att_init('src_j-indices',(/il_jmin0, il_jmax0/))
927	CALL var_move_att(tl_var(jvar), tl_att)
928
929	IF( ANY(il_rho(:)/=1) )THEN
930	tl_att=att_init("refinment_factor", &
931	& (/il_rho(jp_I),il_rho(jp_J)/))
932	CALL var_move_att(tl_var(jvar), tl_att)
933	ENDIF
934
935	! clean structure
936	CALL att_clean(tl_att)
937
938	! add ghost cell
939	CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:))
940	ENDDO
941
942	! close mpp file
943	CALL iom_dom_close(tl_mpp)
944
945	! clean structure
946	CALL mpp_clean(tl_mpp)
947	CALL dom_clean(tl_dom0)
948
949	ENDIF
950
951	! clean structure
952	CALL mpp_clean(tl_mpp)
953	ENDIF
954	ENDDO
955	ENDIF
956
957	il_nvar=tl_multi%i_nvar
958
959	! clean
960	CALL multi_clean(tl_multi)
961	CALL mpp_clean(tl_coord0)
962
963	IF( .NOT. ln_extrap )THEN
964	! compute level
965	ALLOCATE(tl_level(ip_npoint))
966	tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist )
967	ENDIF
968
969	! clean
970	CALL mpp_clean(tl_bathy1)
971
972	! use additional request
973	DO jvar=1,il_nvar
974
975	! change unit and apply factor
976	CALL var_chg_unit(tl_var(jvar))
977
978	! forced min and max value
979	CALL var_limit_value(tl_var(jvar))
980
981	! filter
982	CALL filter_fill_value(tl_var(jvar))
983
984	IF( .NOT. ln_extrap )THEN
985	! use mask
986	CALL create_restart_mask(tl_var(jvar), tl_level(:))
987	ENDIF
988
989	ENDDO
990
991	! create file
992	IF( in_niproc == 0 .AND. &
993	& in_njproc == 0 .AND. &
994	& in_nproc == 0 )THEN
995	in_niproc = 1
996	in_njproc = 1
997	in_nproc = 1
998	ENDIF
999
1000	! add dimension
1001	tl_dim(:)=var_max_dim(tl_var(:))
1002
1003	DO ji=1,il_nvar
1004
1005	IF( ALL(tl_var(ji)%t_dim(:)%i_len == tl_dim(:)%i_len) )THEN
1006	tl_mppout=mpp_init( TRIM(cn_fileout), tl_var(ji), &
1007	& in_niproc, in_njproc, in_nproc, &
1008	& cd_type=cn_type)
1009	EXIT
1010	ENDIF
1011
1012	ENDDO
1013
1014	DO ji=1,ip_maxdim
1015
1016	IF( tl_dim(ji)%l_use .AND. .NOT. tl_mppout%t_dim(ji)%l_use )THEN
1017	CALL mpp_move_dim(tl_mppout, tl_dim(ji))
1018	SELECT CASE(TRIM(tl_dim(ji)%c_sname))
1019	CASE('z','t')
1020	DO jj=1,tl_mppout%i_nproc
1021	CALL file_add_dim(tl_mppout%t_proc(jj), tl_dim(ji))
1022	ENDDO
1023	END SELECT
1024	ENDIF
1025
1026	ENDDO
1027
1028	! add variables
1029	IF( ALL( tl_dim(1:2)%l_use ) )THEN
1030
1031	! open mpp files
1032	CALL iom_mpp_open(tl_coord1)
1033
1034	! add longitude
1035	il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'longitude')
1036	IF( il_varid == 0 )THEN
1037	il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'longitude_T')
1038	ENDIF
1039	tl_lon=iom_mpp_read_var(tl_coord1, il_varid)
1040	CALL mpp_add_var(tl_mppout, tl_lon)
1041	CALL var_clean(tl_lon)
1042
1043	! add latitude
1044	il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'latitude')
1045	IF( il_varid == 0 )THEN
1046	il_varid=var_get_id(tl_coord1%t_proc(1)%t_var(:),'latitude_T')
1047	ENDIF
1048	tl_lat=iom_mpp_read_var(tl_coord1, il_varid)
1049	CALL mpp_add_var(tl_mppout, tl_lat)
1050	CALL var_clean(tl_lat)
1051
1052	! close mpp files
1053	CALL iom_mpp_close(tl_coord1)
1054
1055	ENDIF
1056
1057	IF( tl_dim(3)%l_use )THEN
1058	IF( ASSOCIATED(tl_depth%d_value) )THEN
1059	! add depth
1060	CALL mpp_add_var(tl_mppout, tl_depth)
1061	ELSE
1062	CALL logger_warn("CREATE RESTART: no value for depth variable.")
1063	ENDIF
1064	ENDIF
1065	IF( ASSOCIATED(tl_depth%d_value) ) CALL var_clean(tl_depth)
1066
1067	IF( tl_dim(4)%l_use )THEN
1068	IF( ASSOCIATED(tl_time%d_value) )THEN
1069	! add time
1070	CALL mpp_add_var(tl_mppout, tl_time)
1071	ELSE
1072	CALL logger_warn("CREATE RESTART: no value for time variable.")
1073	ENDIF
1074	ENDIF
1075	IF( ASSOCIATED(tl_time%d_value) ) CALL var_clean(tl_time)
1076
1077	! add other variable
1078	DO jvar=il_nvar,1,-1
1079	! check if variable already add
1080	il_index=var_get_index(tl_mppout%t_proc(1)%t_var(:), tl_var(jvar)%c_name)
1081	IF( il_index == 0 )THEN
1082	CALL mpp_add_var(tl_mppout, tl_var(jvar))
1083	CALL var_clean(tl_var(jvar))
1084	ENDIF
1085	ENDDO
1086
1087	! add some attribute
1088	tl_att=att_init("Created_by","SIREN create_restart")
1089	CALL mpp_add_att(tl_mppout, tl_att)
1090
1091	!add source url
1092	cl_url=fct_split(fct_split(cp_url,2,'$'),2,'URL:')
1093	tl_att=att_init("SIREN_url",cl_url)
1094	CALL mpp_add_att(tl_mppout, tl_att)
1095
1096	! add date of creation
1097	cl_date=date_print(date_now())
1098	tl_att=att_init("Creation_date",TRIM(cl_date))
1099	CALL mpp_add_att(tl_mppout, tl_att)
1100
1101	! add attribute periodicity
1102	il_attid=0
1103	IF( ASSOCIATED(tl_mppout%t_proc(1)%t_att) )THEN
1104	il_attid=att_get_id(tl_mppout%t_proc(1)%t_att(:),'periodicity')
1105	ENDIF
1106	IF( tl_coord1%i_perio >= 0 .AND. il_attid == 0 )THEN
1107	tl_att=att_init('periodicity',tl_coord1%i_perio)
1108	CALL mpp_add_att(tl_mppout,tl_att)
1109	ENDIF
1110
1111	il_attid=0
1112	IF( ASSOCIATED(tl_mppout%t_proc(1)%t_att) )THEN
1113	il_attid=att_get_id(tl_mppout%t_proc(1)%t_att(:),'ew_overlap')
1114	ENDIF
1115	IF( tl_coord1%i_ew >= 0 .AND. il_attid == 0 )THEN
1116	tl_att=att_init('ew_overlap',tl_coord1%i_ew)
1117	CALL mpp_add_att(tl_mppout,tl_att)
1118	ENDIF
1119
1120	! print
1121	CALL mpp_print(tl_mppout)
1122
1123	! create file
1124	CALL iom_mpp_create(tl_mppout)
1125
1126	! write file
1127	CALL iom_mpp_write_file(tl_mppout)
1128	! close file
1129	CALL iom_mpp_close(tl_mppout)
1130
1131	! clean
1132	CALL att_clean(tl_att)
1133	CALL var_clean(tl_var(:))
1134	DEALLOCATE(tl_var)
1135	IF( .NOT. ln_extrap )THEN
1136	CALL var_clean(tl_level(:))
1137	DEALLOCATE(tl_level)
1138	ENDIF
1139
1140	CALL mpp_clean(tl_mppout)
1141	CALL mpp_clean(tl_coord1)
1142	CALL var_clean_extra()
1143
1144	! close log file
1145	CALL logger_footer()
1146	CALL logger_close()
1147
1148	CONTAINS
1149	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1150	FUNCTION create_restart_matrix(td_var, td_coord, id_nlevel, id_xghost) &
1151	& RESULT (tf_var)
1152	!-------------------------------------------------------------------
1153	!> @brief
1154	!> This function create variable, filled with matrix value
1155	!>
1156	!> @details
1157	!> A variable is create with the same name that the input variable,
1158	!> and with dimension of the coordinate file.<br/>
1159	!> Then the variable array of value is split into equal subdomain.
1160	!> Each subdomain is filled with the associated value of the matrix.
1161	!>
1162	!> @author J.Paul
1163	!> @date November, 2013 - Initial Version
1164	!> @date June, 2015
1165	!> - do not use level anymore
1166	!>
1167	!> @param[in] td_var variable structure
1168	!> @param[in] td_coord coordinate file structure
1169	!> @param[in] id_nlevel number of vertical level
1170	!> @param[in] id_xghost ghost cell array
1171	!> @return variable structure
1172	!-------------------------------------------------------------------
1173
1174	IMPLICIT NONE
1175
1176	! Argument
1177	TYPE(TVAR) , INTENT(IN) :: td_var
1178	TYPE(TMPP) , INTENT(IN) :: td_coord
1179	INTEGER(i4) , INTENT(IN) :: id_nlevel
1180	INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_xghost
1181
1182	! function
1183	TYPE(TVAR) :: tf_var
1184
1185	! local variable
1186	INTEGER(i4) , DIMENSION(3) :: il_dim
1187	INTEGER(i4) , DIMENSION(3) :: il_size
1188	INTEGER(i4) , DIMENSION(3) :: il_rest
1189
1190	INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ishape
1191	INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_jshape
1192	INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_kshape
1193
1194	REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
1195
1196	TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
1197
1198	! loop indices
1199	INTEGER(i4) :: ji
1200	INTEGER(i4) :: jj
1201	INTEGER(i4) :: jk
1202	!----------------------------------------------------------------
1203
1204	! write value on grid
1205	! get matrix dimension
1206	il_dim(:)=td_var%t_dim(1:3)%i_len
1207
1208	! output dimension
1209	tl_dim(jp_I:jp_J)=dim_copy(td_coord%t_dim(jp_I:jp_J))
1210	IF( id_nlevel >= 1 )THEN
1211	tl_dim(jp_K)=dim_init('Z',id_nlevel)
1212	ENDIF
1213
1214	! remove ghost cell
1215	tl_dim(jp_I)%i_len=tl_dim(jp_I)%i_len - SUM(id_xghost(jp_I,:))*ip_ghost
1216	tl_dim(jp_J)%i_len=tl_dim(jp_J)%i_len - SUM(id_xghost(jp_J,:))*ip_ghost
1217
1218	! split output domain in N subdomain depending of matrix dimension
1219	il_size(:) = tl_dim(1:3)%i_len / il_dim(:)
1220	il_rest(:) = MOD(tl_dim(1:3)%i_len, il_dim(:))
1221
1222	ALLOCATE( il_ishape(il_dim(1)+1) )
1223	il_ishape(:)=0
1224	DO ji=2,il_dim(1)+1
1225	il_ishape(ji)=il_ishape(ji-1)+il_size(1)
1226	ENDDO
1227	! add rest to last cell
1228	il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1)
1229
1230	ALLOCATE( il_jshape(il_dim(2)+1) )
1231	il_jshape(:)=0
1232	DO jj=2,il_dim(2)+1
1233	il_jshape(jj)=il_jshape(jj-1)+il_size(2)
1234	ENDDO
1235	! add rest to last cell
1236	il_jshape(il_dim(2)+1)=il_jshape(il_dim(2)+1)+il_rest(2)
1237
1238	ALLOCATE( il_kshape(il_dim(3)+1) )
1239	il_kshape(:)=0
1240	DO jk=2,il_dim(3)+1
1241	il_kshape(jk)=il_kshape(jk-1)+il_size(3)
1242	ENDDO
1243	! add rest to last cell
1244	il_kshape(il_dim(3)+1)=il_kshape(il_dim(3)+1)+il_rest(3)
1245
1246	! write ouput array of value
1247	ALLOCATE(dl_value( tl_dim(1)%i_len, &
1248	& tl_dim(2)%i_len, &
1249	& tl_dim(3)%i_len, &
1250	& tl_dim(4)%i_len) )
1251
1252	dl_value(:,:,:,:)=0
1253
1254	DO jk=2,il_dim(3)+1
1255	DO jj=2,il_dim(2)+1
1256	DO ji=2,il_dim(1)+1
1257
1258	dl_value( 1+il_ishape(ji-1):il_ishape(ji), &
1259	& 1+il_jshape(jj-1):il_jshape(jj), &
1260	& 1+il_kshape(jk-1):il_kshape(jk), &
1261	& 1 ) = td_var%d_value(ji-1,jj-1,jk-1,1)
1262
1263	ENDDO
1264	ENDDO
1265	ENDDO
1266
1267	! keep attribute and type
1268	tf_var=var_copy(td_var)
1269	DEALLOCATE( tf_var%d_value )
1270	! save new dimension
1271	tf_var%t_dim(:)=dim_copy(tl_dim(:))
1272	! add variable value
1273	CALL var_add_value( tf_var, dl_value(:,:,:,:), &
1274	& id_type=td_var%i_type)
1275
1276	DEALLOCATE(dl_value)
1277
1278	! clean
1279	DEALLOCATE(il_ishape)
1280	DEALLOCATE(il_jshape)
1281	DEALLOCATE(il_kshape)
1282
1283	END FUNCTION create_restart_matrix
1284	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1285	SUBROUTINE create_restart_mask(td_var, td_mask)
1286	!-------------------------------------------------------------------
1287	!> @brief
1288	!> This subroutine use mask to filled land point with _FillValue
1289	!>
1290	!> @author J.Paul
1291	!> @date November, 2013 - Initial Version
1292	!>
1293	!> @param[inout] td_var variable structure
1294	!> @param[in] td_mask mask variable structure
1295	!-------------------------------------------------------------------
1296
1297	IMPLICIT NONE
1298
1299	! Argument
1300	TYPE(TVAR) , INTENT(INOUT) :: td_var
1301	TYPE(TVAR), DIMENSION(:), INTENT(IN ) :: td_mask
1302
1303	! local variable
1304	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask
1305
1306	! loop indices
1307	INTEGER(i4) :: jl
1308	INTEGER(i4) :: jk
1309	!----------------------------------------------------------------
1310
1311	IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
1312	IF( ANY(td_var%t_dim(1:2)%i_len /= td_mask(1)%t_dim(1:2)%i_len) )THEN
1313	CALL logger_error("CREATE RESTART MASK: dimension differ between"//&
1314	& " variable "//TRIM(td_var%c_name)//" ("//&
1315	& TRIM(fct_str(td_var%t_dim(1)%i_len))//","//&
1316	& TRIM(fct_str(td_var%t_dim(2)%i_len))//&
1317	& ") and level ("//&
1318	& TRIM(fct_str(td_mask(1)%t_dim(1)%i_len))//","//&
1319	& TRIM(fct_str(td_mask(1)%t_dim(2)%i_len))//")")
1320	ELSE
1321	ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
1322	& td_var%t_dim(2)%i_len) )
1323
1324	SELECT CASE(TRIM(td_var%c_point))
1325	CASE('T')
1326	il_mask(:,:)=INT(td_mask(jp_T)%d_value(:,:,1,1))
1327	CASE('U')
1328	il_mask(:,:)=INT(td_mask(jp_U)%d_value(:,:,1,1))
1329	CASE('V')
1330	il_mask(:,:)=INT(td_mask(jp_V)%d_value(:,:,1,1))
1331	CASE('F')
1332	il_mask(:,:)=INT(td_mask(jp_F)%d_value(:,:,1,1))
1333	END SELECT
1334
1335	DO jl=1,td_var%t_dim(4)%i_len
1336	DO jk=1,td_var%t_dim(3)%i_len
1337	WHERE( il_mask(:,:) < jk )
1338	td_var%d_value(:,:,jk,jl)=td_var%d_fill
1339	END WHERE
1340	ENDDO
1341	ENDDO
1342
1343	DEALLOCATE( il_mask )
1344	ENDIF
1345	ENDIF
1346	END SUBROUTINE create_restart_mask
1347	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1348	SUBROUTINE create_restart_interp(td_var, id_rho, id_offset, &
1349	& id_iext, id_jext)
1350	!-------------------------------------------------------------------
1351	!> @brief
1352	!> This subroutine interpolate variable
1353	!>
1354	!> @author J.Paul
1355	!> @date November, 2013 - Initial Version
1356	!> @date June, 2015
1357	!> - do not use level anymore (for extrapolation)
1358	!>
1359	!> @param[inout] td_var variable structure
1360	!> @param[in] id_rho array of refinment factor
1361	!> @param[in] id_offset array of offset between fine and coarse grid
1362	!> @param[in] id_iext i-direction size of extra bands (default=im_minext)
1363	!> @param[in] id_jext j-direction size of extra bands (default=im_minext)
1364	!-------------------------------------------------------------------
1365
1366	IMPLICIT NONE
1367
1368	! Argument
1369	TYPE(TVAR) , INTENT(INOUT) :: td_var
1370	INTEGER(i4), DIMENSION(:) , INTENT(IN ) :: id_rho
1371	INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_offset
1372	INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext
1373	INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext
1374
1375	! local variable
1376	INTEGER(i4) :: il_iext
1377	INTEGER(i4) :: il_jext
1378
1379	! loop indices
1380	!----------------------------------------------------------------
1381
1382	il_iext=3
1383	IF( PRESENT(id_iext) ) il_iext=id_iext
1384
1385	il_jext=3
1386	IF( PRESENT(id_jext) ) il_jext=id_jext
1387
1388	IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
1389	CALL logger_warn("CREATE RESTART INTERP: at least extrapolation "//&
1390	& "on two points are required with cubic interpolation ")
1391	il_iext=2
1392	ENDIF
1393
1394	IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
1395	CALL logger_warn("CREATE RESTART INTERP: at least extrapolation "//&
1396	& "on two points are required with cubic interpolation ")
1397	il_jext=2
1398	ENDIF
1399	! work on variable
1400	! add extraband
1401	CALL extrap_add_extrabands(td_var, il_iext, il_jext)
1402
1403	! extrapolate variable
1404	CALL extrap_fill_value( td_var )
1405
1406	! interpolate variable
1407	CALL interp_fill_value( td_var, id_rho(:), &
1408	& id_offset=id_offset(:,:) )
1409
1410	! remove extraband
1411	CALL extrap_del_extrabands(td_var, il_iextid_rho(jp_I), il_jextid_rho(jp_J))
1412
1413	END SUBROUTINE create_restart_interp
1414	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1415	SUBROUTINE create_restart_check_depth(td_mpp, td_depth)
1416	!-------------------------------------------------------------------
1417	!> @brief
1418	!> This subroutine get depth variable value in an open mpp structure
1419	!> and check if agree with already input depth variable.
1420	!>
1421	!> @details
1422	!>
1423	!> @author J.Paul
1424	!> @date November, 2014 - Initial Version
1425	!>
1426	!> @param[in] td_mpp mpp structure
1427	!> @param[inout] td_depth depth variable structure
1428	!-------------------------------------------------------------------
1429
1430	IMPLICIT NONE
1431
1432	! Argument
1433	TYPE(TMPP), INTENT(IN ) :: td_mpp
1434	TYPE(TVAR), INTENT(INOUT) :: td_depth
1435
1436	! local variable
1437	INTEGER(i4) :: il_varid
1438	TYPE(TVAR) :: tl_depth
1439	! loop indices
1440	!----------------------------------------------------------------
1441
1442	! get or check depth value
1443	IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN
1444
1445	il_varid=td_mpp%t_proc(1)%i_depthid
1446	IF( ASSOCIATED(td_depth%d_value) )THEN
1447
1448	tl_depth=iom_mpp_read_var(td_mpp, il_varid)
1449	IF( ANY( td_depth%d_value(:,:,:,:) /= &
1450	& tl_depth%d_value(:,:,:,:) ) )THEN
1451
1452	CALL logger_warn("CREATE RESTART: depth value from "//&
1453	& TRIM(td_mpp%c_name)//" not conform "//&
1454	& " to those from former file(s).")
1455
1456	ENDIF
1457	CALL var_clean(tl_depth)
1458
1459	ELSE
1460	td_depth=iom_mpp_read_var(td_mpp,il_varid)
1461	ENDIF
1462
1463	ENDIF
1464
1465	END SUBROUTINE create_restart_check_depth
1466	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1467	SUBROUTINE create_restart_check_time(td_mpp, td_time)
1468	!-------------------------------------------------------------------
1469	!> @brief
1470	!> This subroutine get date and time in an open mpp structure
1471	!> and check if agree with date and time already read.
1472	!>
1473	!> @details
1474	!>
1475	!> @author J.Paul
1476	!> @date November, 2014 - Initial Version
1477	!>
1478	!> @param[in] td_mpp mpp structure
1479	!> @param[inout] td_time time variable structure
1480	!-------------------------------------------------------------------
1481
1482	IMPLICIT NONE
1483
1484	! Argument
1485	TYPE(TMPP), INTENT(IN ) :: td_mpp
1486	TYPE(TVAR), INTENT(INOUT) :: td_time
1487
1488	! local variable
1489	INTEGER(i4) :: il_varid
1490	TYPE(TVAR) :: tl_time
1491
1492	TYPE(TDATE) :: tl_date1
1493	TYPE(TDATE) :: tl_date2
1494	! loop indices
1495	!----------------------------------------------------------------
1496
1497	! get or check depth value
1498
1499	IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN
1500
1501	il_varid=td_mpp%t_proc(1)%i_timeid
1502	IF( ASSOCIATED(td_time%d_value) )THEN
1503
1504	tl_time=iom_mpp_read_var(td_mpp, il_varid)
1505
1506	tl_date1=var_to_date(td_time)
1507	tl_date2=var_to_date(tl_time)
1508	IF( tl_date1 - tl_date2 /= 0 )THEN
1509
1510	CALL logger_warn("CREATE BOUNDARY: date from "//&
1511	& TRIM(td_mpp%c_name)//" not conform "//&
1512	& " to those from former file(s).")
1513
1514	ENDIF
1515	CALL var_clean(tl_time)
1516
1517	ELSE
1518	td_time=iom_mpp_read_var(td_mpp,il_varid)
1519	ENDIF
1520
1521	ENDIF
1522
1523	END SUBROUTINE create_restart_check_time
1524	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1525	END PROGRAM create_restart

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

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

Context Navigation

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

Download in other formats: