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_boundary.F90 in branches/2016/dev_r6999_CONFIGMAN_1/NEMOGCM/TOOLS/SIREN/src – NEMO

Context Navigation

source: branches/2016/dev_r6999_CONFIGMAN_1/NEMOGCM/TOOLS/SIREN/src/create_boundary.F90 @ 7025

Last change on this file since 7025 was 7025, checked in by jpaul, 8 years ago
see ticket #1781
File size: 62.2 KB

Line
1	!----------------------------------------------------------------------
2	! NEMO system team, System and Interface for oceanic RElocable Nesting
3	!----------------------------------------------------------------------
4	!
5	!
6	! PROGRAM: create_boundary
7	!
8	! DESCRIPTION:
9	!> @file
10	!> @brief
11	!> This program creates boundary files.
12	!>
13	!> @details
14	!> @section sec1 method
15	!> Variables are read from coarse grid standard output,
16	!> extracted or interpolated on fine grid.
17	!> Variables could also be manually written.<br/>
18	!> @note
19	!> method could be different for each variable.
20	!>
21	!> @section sec2 how to
22	!> to create boundaries files:<br/>
23	!> @code{.sh}
24	!> ./SIREN/bin/create_boundary create_boundary.nam
25	!> @endcode
26	!> <br/>
27	!> \image html boundary_NEATL36_70.png
28	!> <center>\image latex boundary_NEATL36_70.png
29	!> </center>
30	!>
31	!> @note
32	!> you could find a template of the namelist in templates directory.
33	!>
34	!> create_boundary.nam contains 9 namelists:<br/>
35	!> - logger namelist (namlog)
36	!> - config namelist (namcfg)
37	!> - coarse grid namelist (namcrs)
38	!> - fine grid namelist (namfin)
39	!> - variable namelist (namvar)
40	!> - nesting namelist (namnst)
41	!> - boundary namelist (nambdy)
42	!> - vertical grid namelist (namzgr)
43	!> - output namelist (namout)
44	!>
45	!> * _logger namelist (namlog)_:<br/>
46	!> - cn_logfile : log filename
47	!> - cn_verbosity : verbosity ('trace','debug','info',
48	!> 'warning','error','fatal','none')
49	!> - in_maxerror : maximum number of error allowed
50	!>
51	!> * _config namelist (namcfg)_:<br/>
52	!> - cn_varcfg : variable configuration file
53	!> (see ./SIREN/cfg/variable.cfg)
54	!> - cn_dumcfg : useless (dummy) configuration file, for useless
55	!> dimension or variable (see ./SIREN/cfg/dummy.cfg).
56	!>
57	!> * _coarse grid namelist (namcrs)_:<br/>
58	!> - cn_coord0 : coordinate file
59	!> - in_perio0 : NEMO periodicity index (see Model Boundary Condition in
60	!> [NEMO documentation](http://www.nemo-ocean.eu/About-NEMO/Reference-manuals))
61	!>
62	!> * _fine grid namelist (namfin)_:<br/>
63	!> - cn_coord1 : coordinate file
64	!> - cn_bathy1 : bathymetry file
65	!> - in_perio1 : periodicity index
66	!>
67	!> * _vertical grid namelist (namzgr)_:<br/>
68	!> - dn_ppsur :
69	!> - dn_ppa0 :
70	!> - dn_ppa1 :
71	!> - dn_ppa2 :
72	!> - dn_ppkth :
73	!> - dn_ppkth2 :
74	!> - dn_ppacr :
75	!> - dn_ppacr2 :
76	!> - dn_ppdzmin :
77	!> - dn_pphmax :
78	!> - in_nlevel : number of vertical level
79	!>
80	!> * _partial step namelist (namzps)_:<br/>
81	!> - dn_e3zps_min :
82	!> - dn_e3zps_rat :
83	!>
84	!> * _variable namelist (namvar)_:<br/>
85	!> - cn_varfile : list of variable, and associated file<br/>
86	!> cn_varfile is the path and filename of the file where find
87	!> variable.<br/>
88	!> @note
89	!> cn_varfile could be a matrix of value, if you want to filled
90	!> manually variable value.<br/>
91	!> the variable array of value is split into equal subdomain.<br/>
92	!> Each subdomain is filled with the corresponding value
93	!> of the matrix.<br/>
94	!> separators used to defined matrix are:
95	!> - ',' for line
96	!> - '/' for row
97	!> - '\' for level<br/>
98	!> Example:<br/>
99	!> 3,2,3/1,4,5 => @f$ \left( \begin{array}{ccc}
100	!> 3 & 2 & 3 \\\\
101	!> 1 & 4 & 5 \end{array} \right) @f$
102	!> @warning
103	!> the same matrix is used for all boundaries.
104	!>
105	!> Examples:
106	!> - 'votemper:gridT.nc', 'vozocrtx:gridU.nc'
107	!> - 'votemper:10\25', 'vozocrtx:gridU.nc'
108	!>
109	!> - cn_varinfo : list of variable and extra information about request(s)
110	!> to be used (separated by ',').<br/>
111	!> each elements of cn_varinfo is a string character.<br/>
112	!> it is composed of the variable name follow by ':',
113	!> then request(s) to be used on this variable.<br/>
114	!> request could be:
115	!> - int = interpolation method
116	!> - ext = extrapolation method
117	!> - flt = filter method
118	!> - min = minimum value
119	!> - max = maximum value
120	!> - unt = new units
121	!> - unf = unit scale factor (linked to new units)
122	!>
123	!> requests must be separated by ';'.<br/>
124	!> order of requests does not matter.
125	!>
126	!> informations about available method could be find in @ref interp,
127	!> @ref extrap and @ref filter.<br/>
128	!>
129	!> Example: 'votemper:int=linear;flt=hann;ext=dist_weight',
130	!> 'vosaline:int=cubic'
131	!> @note
132	!> If you do not specify a method which is required,
133	!> default one is apply.
134	!>
135	!> * _nesting namelist (namnst)_:<br/>
136	!> - in_rhoi : refinement factor in i-direction
137	!> - in_rhoj : refinement factor in j-direction
138	!>
139	!> * _boundary namelist (nambdy)_:<br/>
140	!> - ln_north : use north boundary
141	!> - ln_south : use south boundary
142	!> - ln_east : use east boundary
143	!> - ln_west : use west boundary
144	!> - cn_north : north boundary indices on fine grid
145	!> cn_north is a string character defining boundary
146	!> segmentation.<br/>
147	!> segments are separated by '\|'.<br/>
148	!> each segments of the boundary is composed of:
149	!> - indice of velocity (orthogonal to boundary .ie.
150	!> for north boundary, J-indice).
151	!> - indice of segment start (I-indice for north boundary)
152	!> - indice of segment end (I-indice for north boundary)<br/>
153	!> indices must be separated by ':' .<br/>
154	!> - optionally, boundary size could be added between '(' and ')'
155	!> in the definition of the first segment.
156	!> @note
157	!> boundary width is the same for all segments of one boundary.
158	!>
159	!> Examples:
160	!> - cn_north='index1,first1:last1(width)'
161	!> - cn_north='index1(width),first1:last1\|index2,first2:last2'
162	!> \image html boundary_50.png
163	!> <center>\image latex boundary_50.png
164	!> </center>
165	!> - cn_south : south boundary indices on fine grid
166	!> - cn_east : east boundary indices on fine grid
167	!> - cn_west : west boundary indices on fine grid
168	!> - ln_oneseg : force to use only one segment for each boundary or not
169	!>
170	!> * _output namelist (namout)_:<br/>
171	!> - cn_fileout : fine grid boundary basename
172	!> (cardinal point and segment number will be automatically added)
173	!> - dn_dayofs : date offset in day (change only ouput file name)
174	!> - ln_extrap : extrapolate land point or not
175	!>
176	!> Examples:
177	!> - cn_fileout='boundary.nc'<br/>
178	!> if time_counter (16/07/2015 00h) is read on input file (see varfile),
179	!> west boundary will be named boundary_west_y2015m07d16
180	!> - dn_dayofs=-2.<br/>
181	!> if you use day offset you get boundary_west_y2015m07d14
182	!>
183	!>
184	!> @author J.Paul
185	! REVISION HISTORY:
186	!> @date November, 2013 - Initial Version
187	!> @date September, 2014
188	!> - add header for user
189	!> - take into account grid point to compue boundaries
190	!> - reorder output dimension for north and south boundaries
191	!> @date June, 2015
192	!> - extrapolate all land points, and add ln_extrap in namelist.
193	!> - allow to change unit.
194	!> @date July, 2015
195	!> - add namelist parameter to shift date of output file name.
196	!> @date September, 2015
197	!> - manage useless (dummy) variable, attributes, and dimension
198	!> - allow to run on multi processors with key_mpp_mpi
199	!> @date January, 2016
200	!> - same process use for variable extracted or interpolated from input file.
201	!>
202	!> @todo
203	!> - rewitre using meshmask instead of bathymetry and coordinates files.
204	!>
205	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
206	!----------------------------------------------------------------------
207	PROGRAM create_boundary
208
209	USE netcdf ! nf90 library
210	USE global ! global variable
211	USE phycst ! physical constant
212	USE kind ! F90 kind parameter
213	USE fct ! basic useful function
214	USE date ! date manager
215	USE att ! attribute manager
216	USE dim ! dimension manager
217	USE var ! variable manager
218	USE file ! file manager
219	USE multi ! multi file manager
220	USE boundary ! boundary manager
221	USE iom ! I/O manager
222	USE dom ! domain manager
223	USE grid ! grid manager
224	USE vgrid ! vertical grid manager
225	USE extrap ! extrapolation manager
226	USE interp ! interpolation manager
227	USE filter ! filter manager
228	USE mpp ! MPP manager
229	USE iom_mpp ! MPP I/O manager
230
231	IMPLICIT NONE
232
233	! local variable
234	INTEGER(i4) :: il_narg
235
236	#if defined key_mpp_mpi
237	! mpp variable
238	CHARACTER(LEN=lc), DIMENSION(:) , ALLOCATABLE :: cl_namelist
239	INTEGER(i4) :: ierror
240	INTEGER(i4) :: iproc
241	INTEGER(i4) :: nproc
242	INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_nprog
243
244	! loop indices
245	INTEGER(i4) :: jm
246	#else
247	CHARACTER(LEN=lc) :: cl_namelist
248	#endif
249	!-------------------------------------------------------------------
250	#if defined key_mpp_mpi
251	INCLUDE 'mpif.h'
252	#endif
253	!-------------------------------------------------------------------
254
255	il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
256	#if ! defined key_mpp_mpi
257
258	IF( il_narg/=1 )THEN
259	PRINT *,"CREATE BOUNDARY: ERROR. need one namelist"
260	STOP
261	ELSE
262	CALL GET_COMMAND_ARGUMENT(1,cl_namelist) !f03 intrinsec
263	ENDIF
264
265	CALL create__boundary(cl_namelist)
266
267	#else
268
269	! Initialize MPI
270	CALL mpi_init(ierror)
271	CALL mpi_comm_rank(mpi_comm_world,iproc,ierror)
272	CALL mpi_comm_size(mpi_comm_world,nproc,ierror)
273
274	IF( il_narg==0 )THEN
275	PRINT *,"CREATE BOUNDARY: ERROR. need at least one namelist"
276	STOP
277	ELSE
278	ALLOCATE(cl_namelist(il_narg))
279	DO jm=1,il_narg
280	CALL GET_COMMAND_ARGUMENT(jm,cl_namelist(jm))
281	ENDDO
282	ENDIF
283
284	ALLOCATE(il_nprog(il_narg))
285	DO jm=1, il_narg
286	il_nprog(jm)= MOD(jm,nproc)
287	ENDDO
288
289	DO jm=1, il_narg
290	IF ( il_nprog(jm) .eq. iproc ) THEN
291	CALL create__boundary(cl_namelist(jm))
292	ENDIF
293	ENDDO
294
295	CALL mpi_finalize(ierror)
296
297	DEALLOCATE(cl_namelist)
298	DEALLOCATE(il_nprog)
299	#endif
300
301	CONTAINS
302	SUBROUTINE create__boundary(cd_namelist)
303	!-------------------------------------------------------------------
304	!> @brief
305	!> This subroutine create boundary files.
306	!>
307	!> @details
308	!>
309	!> @author J.Paul
310	!> @date January, 2016 - Initial Version
311	!>
312	!> @param[in] cd_namelist namelist file
313	!-------------------------------------------------------------------
314
315	USE logger ! log file manager
316
317	IMPLICIT NONE
318	! Argument
319	CHARACTER(LEN=lc), INTENT(IN) :: cd_namelist
320
321	! local variable
322	CHARACTER(LEN=lc) :: cl_date
323	CHARACTER(LEN=lc) :: cl_name
324	CHARACTER(LEN=lc) :: cl_bdyout
325	CHARACTER(LEN=lc) :: cl_data
326	CHARACTER(LEN=lc) :: cl_dimorder
327	CHARACTER(LEN=lc) :: cl_fmt
328
329	INTEGER(i4) :: il_status
330	INTEGER(i4) :: il_fileid
331	INTEGER(i4) :: il_imin0
332	INTEGER(i4) :: il_imax0
333	INTEGER(i4) :: il_jmin0
334	INTEGER(i4) :: il_jmax0
335	INTEGER(i4) :: il_shift
336	INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho
337	INTEGER(i4) , DIMENSION(2,2) :: il_offset
338	INTEGER(i4) , DIMENSION(2,2) :: il_ind
339
340	LOGICAL :: ll_exist
341
342	TYPE(TATT) :: tl_att
343
344	TYPE(TVAR) :: tl_depth
345	TYPE(TVAR) :: tl_time
346	TYPE(TVAR) :: tl_var1
347	TYPE(TVAR) :: tl_var0
348	TYPE(TVAR) :: tl_lon1
349	TYPE(TVAR) :: tl_lat1
350	TYPE(TVAR) :: tl_lvl1
351	TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_level
352	TYPE(TVAR) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_seglvl1
353	TYPE(TVAR) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_segvar1
354
355	TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
356
357	TYPE(TDATE) :: tl_date
358
359	TYPE(TBDY) , DIMENSION(ip_ncard) :: tl_bdy
360
361	TYPE(TDOM) :: tl_dom0
362	TYPE(TDOM) :: tl_dom1
363	TYPE(TDOM) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_segdom1
364
365	TYPE(TFILE) :: tl_fileout
366
367	TYPE(TMPP) :: tl_coord0
368	TYPE(TMPP) :: tl_coord1
369	TYPE(TMPP) :: tl_bathy1
370	TYPE(TMPP) :: tl_mpp
371
372	TYPE(TMULTI) :: tl_multi
373
374	! loop indices
375	INTEGER(i4) :: jvar
376	INTEGER(i4) :: jpoint
377	INTEGER(i4) :: ji
378	INTEGER(i4) :: jj
379	INTEGER(i4) :: jk
380	INTEGER(i4) :: jl
381
382	! namelist variable
383	! namlog
384	CHARACTER(LEN=lc) :: cn_logfile = 'create_boundary.log'
385	CHARACTER(LEN=lc) :: cn_verbosity = 'warning'
386	INTEGER(i4) :: in_maxerror = 5
387
388	! namcfg
389	CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg'
390	CHARACTER(LEN=lc) :: cn_dumcfg = 'dummy.cfg'
391
392	! namcrs
393	CHARACTER(LEN=lc) :: cn_coord0 = ''
394	INTEGER(i4) :: in_perio0 = -1
395
396	! namfin
397	CHARACTER(LEN=lc) :: cn_coord1 = ''
398	CHARACTER(LEN=lc) :: cn_bathy1 = ''
399	INTEGER(i4) :: in_perio1 = -1
400
401	!namzgr
402	REAL(dp) :: dn_ppsur = -3958.951371276829_dp
403	REAL(dp) :: dn_ppa0 = 103.953009600000_dp
404	REAL(dp) :: dn_ppa1 = 2.415951269000_dp
405	REAL(dp) :: dn_ppa2 = 100.760928500000_dp
406	REAL(dp) :: dn_ppkth = 15.351013700000_dp
407	REAL(dp) :: dn_ppkth2 = 48.029893720000_dp
408	REAL(dp) :: dn_ppacr = 7.000000000000_dp
409	REAL(dp) :: dn_ppacr2 = 13.000000000000_dp
410	REAL(dp) :: dn_ppdzmin = 6._dp
411	REAL(dp) :: dn_pphmax = 5750._dp
412	INTEGER(i4) :: in_nlevel = 75
413
414	!namzps
415	REAL(dp) :: dn_e3zps_min = 25._dp
416	REAL(dp) :: dn_e3zps_rat = 0.2_dp
417
418	! namvar
419	CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''
420	CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''
421
422	! namnst
423	INTEGER(i4) :: in_rhoi = 0
424	INTEGER(i4) :: in_rhoj = 0
425
426	! nambdy
427	LOGICAL :: ln_north = .TRUE.
428	LOGICAL :: ln_south = .TRUE.
429	LOGICAL :: ln_east = .TRUE.
430	LOGICAL :: ln_west = .TRUE.
431	LOGICAL :: ln_oneseg = .TRUE.
432	CHARACTER(LEN=lc) :: cn_north = ''
433	CHARACTER(LEN=lc) :: cn_south = ''
434	CHARACTER(LEN=lc) :: cn_east = ''
435	CHARACTER(LEN=lc) :: cn_west = ''
436
437	! namout
438	CHARACTER(LEN=lc) :: cn_fileout = 'boundary.nc'
439	REAL(dp) :: dn_dayofs = 0._dp
440	LOGICAL :: ln_extrap = .FALSE.
441	!-------------------------------------------------------------------
442
443	NAMELIST /namlog/ & !< logger namelist
444	& cn_logfile, & !< log file
445	& cn_verbosity, & !< log verbosity
446	& in_maxerror
447
448	NAMELIST /namcfg/ & !< config namelist
449	& cn_varcfg, & !< variable configuration file
450	& cn_dumcfg !< dummy configuration file
451
452	NAMELIST /namcrs/ & !< coarse grid namelist
453	& cn_coord0, & !< coordinate file
454	& in_perio0 !< periodicity index
455
456	NAMELIST /namfin/ & !< fine grid namelist
457	& cn_coord1, & !< coordinate file
458	& cn_bathy1, & !< bathymetry file
459	& in_perio1 !< periodicity index
460
461	NAMELIST /namzgr/ &
462	& dn_ppsur, &
463	& dn_ppa0, &
464	& dn_ppa1, &
465	& dn_ppa2, &
466	& dn_ppkth, &
467	& dn_ppkth2, &
468	& dn_ppacr, &
469	& dn_ppacr2, &
470	& dn_ppdzmin, &
471	& dn_pphmax, &
472	& in_nlevel !< number of vertical level
473
474	NAMELIST /namzps/ &
475	& dn_e3zps_min, &
476	& dn_e3zps_rat
477
478	NAMELIST /namvar/ & !< variable namelist
479	& cn_varfile, & !< list of variable and file where find it. (ex: 'votemper:GLORYS_gridT.nc' )
480	& cn_varinfo !< list of variable and method to apply on. (ex: 'votemper:linear','vosaline:cubic' )
481
482	NAMELIST /namnst/ & !< nesting namelist
483	& in_rhoi, & !< refinement factor in i-direction
484	& in_rhoj !< refinement factor in j-direction
485
486	NAMELIST /nambdy/ & !< boundary namelist
487	& ln_north, & !< use north boundary
488	& ln_south, & !< use south boundary
489	& ln_east , & !< use east boundary
490	& ln_west , & !< use west boundary
491	& cn_north, & !< north boundary indices on fine grid
492	& cn_south, & !< south boundary indices on fine grid
493	& cn_east , & !< east boundary indices on fine grid
494	& cn_west , & !< west boundary indices on fine grid
495	& ln_oneseg !< use only one segment for each boundary or not
496
497	NAMELIST /namout/ & !< output namelist
498	& cn_fileout, & !< fine grid boundary file basename
499	& dn_dayofs, & !< date offset in day (change only ouput file name)
500	& ln_extrap !< extrapolate or not
501	!-------------------------------------------------------------------
502
503	! read namelist
504	INQUIRE(FILE=TRIM(cd_namelist), EXIST=ll_exist)
505
506	IF( ll_exist )THEN
507
508	il_fileid=fct_getunit()
509
510	OPEN( il_fileid, FILE=TRIM(cd_namelist), &
511	& FORM='FORMATTED', &
512	& ACCESS='SEQUENTIAL', &
513	& STATUS='OLD', &
514	& ACTION='READ', &
515	& IOSTAT=il_status)
516	CALL fct_err(il_status)
517	IF( il_status /= 0 )THEN
518	PRINT *,"CREATE BOUNDARY: ERROR opening "//TRIM(cd_namelist)
519	STOP
520	ENDIF
521
522	READ( il_fileid, NML = namlog )
523	! define log file
524	CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror)
525	CALL logger_header()
526
527	READ( il_fileid, NML = namcfg )
528	! get variable extra information
529	CALL var_def_extra(TRIM(cn_varcfg))
530
531	! get dummy variable
532	CALL var_get_dummy(TRIM(cn_dumcfg))
533	! get dummy dimension
534	CALL dim_get_dummy(TRIM(cn_dumcfg))
535	! get dummy attribute
536	CALL att_get_dummy(TRIM(cn_dumcfg))
537
538	READ( il_fileid, NML = namcrs )
539	READ( il_fileid, NML = namfin )
540	READ( il_fileid, NML = namzgr )
541	READ( il_fileid, NML = namvar )
542	! add user change in extra information
543	CALL var_chg_extra(cn_varinfo)
544	! match variable with file
545	tl_multi=multi_init(cn_varfile)
546
547	READ( il_fileid, NML = namnst )
548	READ( il_fileid, NML = nambdy )
549	READ( il_fileid, NML = namout )
550
551	CLOSE( il_fileid, IOSTAT=il_status )
552	CALL fct_err(il_status)
553	IF( il_status /= 0 )THEN
554	CALL logger_error("CREATE BOUNDARY: ERROR closing "//TRIM(cd_namelist))
555	ENDIF
556
557	ELSE
558
559	PRINT *,"CREATE BOUNDARY: ERROR. can not find "//TRIM(cd_namelist)
560	STOP
561
562	ENDIF
563
564	CALL multi_print(tl_multi)
565	IF( tl_multi%i_nvar <= 0 )THEN
566	CALL logger_fatal("CREATE BOUNDARY: no variable to be used."//&
567	& " check namelist.")
568	ENDIF
569
570	! open files
571	IF( TRIM(cn_coord0) /= '' )THEN
572	tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0)
573	CALL grid_get_info(tl_coord0)
574	ELSE
575	CALL logger_fatal("CREATE BOUNDARY: can not find coarse grid "//&
576	& "coordinate file. check namelist")
577	ENDIF
578
579	IF( TRIM(cn_coord1) /= '' )THEN
580	tl_coord1=mpp_init( file_init(TRIM(cn_coord1)), id_perio=in_perio1)
581	CALL grid_get_info(tl_coord1)
582	ELSE
583	CALL logger_fatal("CREATE BOUNDARY: can not find fine grid coordinate "//&
584	& "file. check namelist")
585	ENDIF
586
587	IF( TRIM(cn_bathy1) /= '' )THEN
588	tl_bathy1=mpp_init( file_init(TRIM(cn_bathy1)), id_perio=in_perio1)
589	CALL grid_get_info(tl_bathy1)
590	ELSE
591	CALL logger_fatal("CREATE BOUNDARY: can not find fine grid bathymetry "//&
592	& "file. check namelist")
593	ENDIF
594
595	! check
596	! check output file do not already exist
597	! WARNING: do not work when use time to create output file name
598	DO jk=1,ip_ncard
599	cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
600	& TRIM(cp_card(jk)), 1 )
601	INQUIRE(FILE=TRIM(cl_bdyout), EXIST=ll_exist)
602	IF( ll_exist )THEN
603	CALL logger_fatal("CREATE BOUNDARY: output file "//TRIM(cl_bdyout)//&
604	& " already exist.")
605	ENDIF
606
607	cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
608	& TRIM(cp_card(jk)) )
609	INQUIRE(FILE=TRIM(cl_bdyout), EXIST=ll_exist)
610	IF( ll_exist )THEN
611	CALL logger_fatal("CREATE BOUNDARY: output file "//TRIM(cl_bdyout)//&
612	& " already exist.")
613	ENDIF
614	ENDDO
615
616	! check namelist
617	! check refinement factor
618	il_rho(:)=1
619	IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN
620	CALL logger_error("CREATE BOUNDARY: invalid refinement factor."//&
621	& " check namelist "//TRIM(cd_namelist))
622	ELSE
623	il_rho(jp_I)=in_rhoi
624	il_rho(jp_J)=in_rhoj
625	ENDIF
626
627	!
628	! compute coarse grid indices around fine grid
629	il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1, &
630	& id_rho=il_rho(:))
631
632	il_imin0=il_ind(1,1) ; il_imax0=il_ind(1,2)
633	il_jmin0=il_ind(2,1) ; il_jmax0=il_ind(2,2)
634
635	! check domain validity
636	CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0)
637
638	! check coordinate file
639	CALL grid_check_coincidence( tl_coord0, tl_coord1, &
640	& il_imin0, il_imax0, &
641	& il_jmin0, il_jmax0, &
642	& il_rho(:) )
643
644	! read or compute boundary
645	CALL mpp_get_contour(tl_bathy1)
646
647	CALL iom_mpp_open(tl_bathy1)
648
649	tl_var1=iom_mpp_read_var(tl_bathy1,'Bathymetry')
650
651	CALL iom_mpp_close(tl_bathy1)
652
653	! get boundaries indices
654	tl_bdy(:)=boundary_init(tl_var1, ln_north, ln_south, ln_east, ln_west, &
655	& cn_north, cn_south, cn_east, cn_west, &
656	& ln_oneseg )
657
658
659	CALL var_clean(tl_var1)
660
661	! compute level
662	ALLOCATE(tl_level(ip_npoint))
663	tl_level(:)=vgrid_get_level(tl_bathy1, cd_namelist )
664
665	! get coordinate for each segment of each boundary
666	ALLOCATE( tl_segdom1(ip_npoint,ip_maxseg,ip_ncard) )
667	ALLOCATE( tl_seglvl1(ip_npoint,ip_maxseg,ip_ncard) )
668
669	DO jl=1,ip_ncard
670	IF( tl_bdy(jl)%l_use )THEN
671	DO jk=1,tl_bdy(jl)%i_nseg
672
673	! get fine grid segment domain
674	tl_segdom1(:,jk,jl)=create_boundary_get_dom( tl_bathy1, &
675	& tl_bdy(jl), jk )
676
677	IF( .NOT. ln_extrap )THEN
678	! get fine grid level
679	tl_seglvl1(:,jk,jl)= &
680	& create_boundary_get_level( tl_level(:), &
681	& tl_segdom1(:,jk,jl))
682	ENDIF
683
684	! add extra band to fine grid domain (if possible)
685	! to avoid dimension of one and so be able to compute offset
686	DO jj=1,ip_npoint
687	CALL dom_add_extra(tl_segdom1(jj,jk,jl), &
688	& il_rho(jp_I), il_rho(jp_J))
689	ENDDO
690
691	ENDDO
692	ENDIF
693	ENDDO
694
695	! clean
696	CALL var_clean(tl_level(:))
697	DEALLOCATE(tl_level)
698
699	! clean bathy
700	CALL mpp_clean(tl_bathy1)
701
702	ALLOCATE( tl_segvar1(tl_multi%i_nvar,ip_maxseg,ip_ncard) )
703	! compute boundary for variable to be used (see namelist)
704	IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN
705	CALL logger_error("CREATE BOUNDARY: no file to work on. "//&
706	& "check cn_varfile in namelist.")
707	ELSE
708
709	jvar=0
710	! for each file
711	DO ji=1,tl_multi%i_nmpp
712
713	WRITE(cl_data,'(a,i2.2)') 'data-',jvar+1
714
715	IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
716
717	CALL logger_error("CREATE BOUNDARY: no variable to work on for "//&
718	& "mpp "//TRIM(tl_multi%t_mpp(ji)%c_name)//&
719	& ". check cn_varfile in namelist.")
720
721	ELSEIF( TRIM(tl_multi%t_mpp(ji)%c_name) == TRIM(cl_data) )THEN
722	!- use input matrix to fill variable
723
724	WRITE(*,'(a)') "work on data"
725	! for each variable initialise from matrix
726	DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
727
728	jvar=jvar+1
729	WRITE(*,'(2x,a,a)') "work on variable "//&
730	& TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
731
732	tl_var1=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj))
733
734	SELECT CASE(TRIM(tl_var1%c_point))
735	CASE DEFAULT !'T'
736	jpoint=jp_T
737	CASE('U')
738	jpoint=jp_U
739	CASE('V')
740	jpoint=jp_V
741	CASE('F')
742	jpoint=jp_F
743	END SELECT
744
745	WRITE(*,'(4x,a,a)') 'work on '//TRIM(tl_var1%c_name)
746	DO jl=1,ip_ncard
747	IF( tl_bdy(jl)%l_use )THEN
748
749	DO jk=1,tl_bdy(jl)%i_nseg
750
751	! fill value with matrix data
752	tl_segvar1(jvar,jk,jl)=create_boundary_matrix( &
753	& tl_var1, &
754	& tl_segdom1(jpoint,jk,jl), &
755	& in_nlevel )
756
757	!del extra
758	CALL dom_del_extra( tl_segvar1(jvar,jk,jl), &
759	& tl_segdom1(jpoint,jk,jl) )
760
761	ENDDO
762
763	ENDIF
764	ENDDO
765
766	! clean
767	CALL var_clean(tl_var1)
768
769	ENDDO
770
771	!- end of use input matrix to fill variable
772	ELSE
773	!- use mpp file to fill variable
774
775	WRITE(*,'(a)') "work on file "//TRIM(tl_multi%t_mpp(ji)%c_name)
776	!
777	tl_mpp=mpp_init(file_init(TRIM(tl_multi%t_mpp(ji)%t_proc(1)%c_name)))
778	CALL grid_get_info(tl_mpp)
779
780	DO jl=1,ip_ncard
781	IF( tl_bdy(jl)%l_use )THEN
782
783	WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//&
784	& ' boundary'
785	DO jk=1,tl_bdy(jl)%i_nseg
786
787	! for each variable of this file
788	DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
789
790	WRITE(*,'(4x,a,a)') "work on variable "//&
791	& TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
792
793	tl_var0=var_copy(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj))
794
795	! open mpp file
796	CALL iom_mpp_open(tl_mpp)
797
798	! get or check depth value
799	CALL create_boundary_check_depth( tl_var0, tl_mpp, &
800	& in_nlevel, tl_depth )
801
802	! get or check time value
803	CALL create_boundary_check_time( tl_var0, tl_mpp, &
804	& tl_time )
805
806	! close mpp file
807	CALL iom_mpp_close(tl_mpp)
808
809	! open mpp file on domain
810	SELECT CASE(TRIM(tl_var0%c_point))
811	CASE DEFAULT !'T'
812	jpoint=jp_T
813	CASE('U')
814	jpoint=jp_U
815	CASE('V')
816	jpoint=jp_V
817	CASE('F')
818	jpoint=jp_F
819	END SELECT
820
821	tl_dom1=dom_copy(tl_segdom1(jpoint,jk,jl))
822
823	CALL create_boundary_get_coord( tl_coord1, tl_dom1, &
824	& tl_var0%c_point, &
825	& tl_lon1, tl_lat1 )
826
827	! get coarse grid indices of this segment
828	il_ind(:,:)=grid_get_coarse_index(tl_coord0, &
829	& tl_lon1, tl_lat1, &
830	& id_rho=il_rho(:) )
831
832	IF( ANY(il_ind(:,:)==0) )THEN
833	CALL logger_error("CREATE BOUNDARY: error "//&
834	& "computing coarse grid indices")
835	ELSE
836	il_imin0=il_ind(1,1)
837	il_imax0=il_ind(1,2)
838
839	il_jmin0=il_ind(2,1)
840	il_jmax0=il_ind(2,2)
841	ENDIF
842
843	il_offset(:,:)= grid_get_fine_offset( &
844	& tl_coord0, &
845	& il_imin0, il_jmin0,&
846	& il_imax0, il_jmax0,&
847	& tl_lon1%d_value(:,:,1,1),&
848	& tl_lat1%d_value(:,:,1,1),&
849	& il_rho(:),&
850	& TRIM(tl_var0%c_point) )
851
852	! compute coarse grid segment domain
853	tl_dom0=dom_init( tl_coord0, &
854	& il_imin0, il_imax0,&
855	& il_jmin0, il_jmax0 )
856
857	! add extra band (if possible) to compute interpolation
858	CALL dom_add_extra(tl_dom0)
859
860	! open mpp files
861	CALL iom_dom_open(tl_mpp, tl_dom0)
862
863	cl_name=tl_var0%c_name
864	! read variable value on domain
865	tl_segvar1(jvar+jj,jk,jl)= &
866	& iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom0)
867
868	IF( ANY(il_rho(:)/=1) )THEN
869	WRITE(*,'(4x,a,a)') "interp variable "//TRIM(cl_name)
870	! work on variable
871	CALL create_boundary_interp( &
872	& tl_segvar1(jvar+jj,jk,jl),&
873	& il_rho(:), il_offset(:,:) )
874	ENDIF
875
876	! remove extraband added to domain
877	CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), &
878	& tl_dom0, il_rho(:) )
879
880	! del extra point on fine grid
881	CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), &
882	& tl_dom1 )
883	! clean extra point information on coarse grid domain
884	CALL dom_clean_extra( tl_dom0 )
885
886	! add attribute to variable
887	tl_att=att_init('src_file',&
888	& TRIM(fct_basename(tl_mpp%c_name)))
889	CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), &
890	& tl_att)
891
892	!
893	tl_att=att_init('src_i_indices',&
894	& (/tl_dom0%i_imin, tl_dom0%i_imax/))
895	CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), &
896	& tl_att)
897
898	tl_att=att_init('src_j_indices', &
899	& (/tl_dom0%i_jmin, tl_dom0%i_jmax/))
900	CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), &
901	& tl_att)
902
903	IF( ANY(il_rho(:)/=1) )THEN
904	tl_att=att_init("refinment_factor", &
905	& (/il_rho(jp_I),il_rho(jp_J)/))
906	CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), &
907	& tl_att)
908	ENDIF
909
910	! clean structure
911	CALL att_clean(tl_att)
912
913	! clean
914	CALL dom_clean(tl_dom0)
915	CALL dom_clean(tl_dom1)
916
917	! close mpp files
918	CALL iom_dom_close(tl_mpp)
919
920	! clean structure
921	CALL var_clean(tl_lon1)
922	CALL var_clean(tl_lat1)
923	CALL var_clean(tl_lvl1)
924
925	ENDDO ! jj
926
927	! clean
928	CALL var_clean(tl_var0)
929
930	ENDDO ! jk
931
932	ENDIF
933	ENDDO ! jl
934
935	jvar=jvar+tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
936
937	! clean
938	CALL mpp_clean(tl_mpp)
939
940	!- end of use file to fill variable
941	ENDIF
942	ENDDO ! ji
943	ENDIF
944
945	IF( jvar /= tl_multi%i_nvar )THEN
946	CALL logger_error("CREATE BOUNDARY: it seems some variable "//&
947	& "can not be read")
948	ENDIF
949
950	! write file for each segment of each boundary
951	DO jl=1,ip_ncard
952	IF( tl_bdy(jl)%l_use )THEN
953
954	DO jk=1,tl_bdy(jl)%i_nseg
955	!-
956	CALL create_boundary_get_coord( tl_coord1, tl_segdom1(jp_T,jk,jl),&
957	& 'T', tl_lon1, tl_lat1 )
958
959	! force to use nav_lon, nav_lat as variable name
960	tl_lon1%c_name='nav_lon'
961	tl_lat1%c_name='nav_lat'
962
963	! del extra point on fine grid
964	CALL dom_del_extra( tl_lon1, tl_segdom1(jp_T,jk,jl) )
965	CALL dom_del_extra( tl_lat1, tl_segdom1(jp_T,jk,jl) )
966
967	! clean
968	DO jpoint=1,ip_npoint
969	CALL dom_clean(tl_segdom1(jpoint,jk,jl))
970	ENDDO
971
972	! swap array
973	CALL boundary_swap(tl_lon1, tl_bdy(jl))
974	CALL boundary_swap(tl_lat1, tl_bdy(jl))
975	DO jvar=1,tl_multi%i_nvar
976
977	! use additional request
978	! change unit and apply factor
979	CALL var_chg_unit(tl_segvar1(jvar,jk,jl))
980
981	! forced min and max value
982	CALL var_limit_value(tl_segvar1(jvar,jk,jl))
983
984	! filter
985	CALL filter_fill_value(tl_segvar1(jvar,jk,jl))
986
987	IF( .NOT. ln_extrap )THEN
988	! use mask
989	SELECT CASE(TRIM(tl_segvar1(jvar,jk,jl)%c_point))
990	CASE DEFAULT !'T'
991	jpoint=jp_T
992	CASE('U')
993	jpoint=jp_U
994	CASE('V')
995	jpoint=jp_V
996	CASE('F')
997	jpoint=jp_F
998	END SELECT
999
1000	CALL create_boundary_use_mask(tl_segvar1(jvar,jk,jl), &
1001	& tl_seglvl1(jpoint,jk,jl))
1002	ENDIF
1003
1004	! swap dimension order
1005	CALL boundary_swap(tl_segvar1(jvar,jk,jl), tl_bdy(jl))
1006
1007	ENDDO
1008
1009	! create file
1010	! create file structure
1011	! set file namearray of level variable structure
1012	IF( tl_bdy(jl)%i_nseg > 1 )THEN
1013	IF( ASSOCIATED(tl_time%d_value) )THEN
1014	cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)"
1015	tl_date=var_to_date(tl_time)
1016	tl_date=tl_date+dn_dayofs
1017	cl_date=date_print( tl_date, cl_fmt )
1018
1019	cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
1020	& TRIM(tl_bdy(jl)%c_card), jk,&
1021	& cd_date=TRIM(cl_date) )
1022	ELSE
1023	cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
1024	& TRIM(tl_bdy(jl)%c_card), jk )
1025	ENDIF
1026	ELSE
1027	IF( ASSOCIATED(tl_time%d_value) )THEN
1028	cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)"
1029	tl_date=var_to_date(tl_time)
1030	tl_date=tl_date+dn_dayofs
1031	cl_date=date_print( tl_date, cl_fmt )
1032
1033	cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
1034	& TRIM(tl_bdy(jl)%c_card), &
1035	& cd_date=TRIM(cl_date) )
1036	ELSE
1037	cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
1038	& TRIM(tl_bdy(jl)%c_card) )
1039	ENDIF
1040	ENDIF
1041	!
1042	tl_fileout=file_init(TRIM(cl_bdyout),id_perio=in_perio1)
1043
1044	! add dimension
1045	tl_dim(:)=var_max_dim(tl_segvar1(:,jk,jl))
1046
1047	SELECT CASE(TRIM(tl_bdy(jl)%c_card))
1048	CASE DEFAULT ! 'north','south'
1049	cl_dimorder='xyzt'
1050	CASE('east','west')
1051	cl_dimorder='yxzt'
1052	END SELECT
1053
1054	DO ji=1,ip_maxdim
1055	IF( tl_dim(ji)%l_use ) CALL file_add_dim(tl_fileout, tl_dim(ji))
1056	ENDDO
1057
1058	! add variables
1059	IF( ALL( tl_dim(1:2)%l_use ) )THEN
1060	! add longitude
1061	CALL file_add_var(tl_fileout, tl_lon1)
1062	CALL var_clean(tl_lon1)
1063
1064	! add latitude
1065	CALL file_add_var(tl_fileout, tl_lat1)
1066	CALL var_clean(tl_lat1)
1067	ENDIF
1068
1069
1070
1071	IF( tl_dim(3)%l_use )THEN
1072	IF( ASSOCIATED(tl_depth%d_value) )THEN
1073	! add depth
1074	CALL file_add_var(tl_fileout, tl_depth)
1075	ENDIF
1076	ENDIF
1077
1078	IF( tl_dim(4)%l_use )THEN
1079	IF( ASSOCIATED(tl_time%d_value) )THEN
1080	! add time
1081	CALL file_add_var(tl_fileout, tl_time)
1082	ENDIF
1083	ENDIF
1084
1085	! add other variable
1086	DO jvar=tl_multi%i_nvar,1,-1
1087	CALL file_add_var(tl_fileout, tl_segvar1(jvar,jk,jl))
1088	CALL var_clean(tl_segvar1(jvar,jk,jl))
1089	ENDDO
1090
1091	! add some attribute
1092	tl_att=att_init("Created_by","SIREN create_boundary")
1093	CALL file_add_att(tl_fileout, tl_att)
1094
1095	cl_date=date_print(date_now())
1096	tl_att=att_init("Creation_date",cl_date)
1097	CALL file_add_att(tl_fileout, tl_att)
1098
1099	! add shift on north and east boundary
1100	! boundary compute on T point but express on U or V point
1101	SELECT CASE(TRIM(tl_bdy(jl)%c_card))
1102	CASE DEFAULT ! 'south','west'
1103	il_shift=0
1104	CASE('north','east')
1105	il_shift=1
1106	END SELECT
1107
1108	! add indice of velocity row or column
1109	tl_att=att_init('bdy_ind',tl_bdy(jl)%t_seg(jk)%i_index-il_shift)
1110	CALL file_move_att(tl_fileout, tl_att)
1111
1112	! add width of the relaxation zone
1113	tl_att=att_init('bdy_width',tl_bdy(jl)%t_seg(jk)%i_width)
1114	CALL file_move_att(tl_fileout, tl_att)
1115
1116	! add indice of segment start
1117	tl_att=att_init('bdy_deb',tl_bdy(jl)%t_seg(jk)%i_first)
1118	CALL file_move_att(tl_fileout, tl_att)
1119
1120	! add indice of segment end
1121	tl_att=att_init('bdy_end',tl_bdy(jl)%t_seg(jk)%i_last)
1122	CALL file_move_att(tl_fileout, tl_att)
1123
1124	! clean
1125	CALL att_clean(tl_att)
1126
1127	! create file
1128	CALL iom_create(tl_fileout)
1129
1130	! write file
1131	CALL iom_write_file(tl_fileout, cl_dimorder)
1132
1133	! close file
1134	CALL iom_close(tl_fileout)
1135	CALL file_clean(tl_fileout)
1136
1137	ENDDO ! jk
1138
1139	ENDIF
1140	! clean
1141	CALL boundary_clean(tl_bdy(jl))
1142	ENDDO !jl
1143
1144	! clean
1145	IF( ASSOCIATED(tl_depth%d_value) ) CALL var_clean(tl_depth)
1146	IF( ASSOCIATED(tl_time%d_value) ) CALL var_clean(tl_time)
1147	DEALLOCATE( tl_segdom1 )
1148	DEALLOCATE( tl_segvar1 )
1149	CALL var_clean(tl_seglvl1(:,:,:))
1150	DEALLOCATE( tl_seglvl1 )
1151
1152
1153	CALL mpp_clean(tl_coord1)
1154	CALL mpp_clean(tl_coord0)
1155
1156	CALL multi_clean(tl_multi)
1157
1158	! close log file
1159	CALL logger_footer()
1160	CALL logger_close()
1161	CALL logger_clean()
1162
1163	END SUBROUTINE create__boundary
1164	!-------------------------------------------------------------------
1165	!> @brief
1166	!> This subroutine compute boundary domain for each grid point (T,U,V,F)
1167	!>
1168	!> @author J.Paul
1169	!> @date November, 2013 - Initial Version
1170	!> @date September, 2014
1171	!> - take into account grid point to compute boundary indices
1172	!>
1173	!> @param[in] td_bathy1 file structure
1174	!> @param[in] td_bdy boundary structure
1175	!> @param[in] id_seg segment indice
1176	!> @return array of domain structure
1177	!-------------------------------------------------------------------
1178	FUNCTION create_boundary_get_dom( td_bathy1, td_bdy, id_seg )
1179
1180	IMPLICIT NONE
1181
1182	! Argument
1183	TYPE(TMPP) , INTENT(IN ) :: td_bathy1
1184	TYPE(TBDY) , INTENT(IN ) :: td_bdy
1185	INTEGER(i4), INTENT(IN ) :: id_seg
1186
1187	! function
1188	TYPE(TDOM), DIMENSION(ip_npoint) :: create_boundary_get_dom
1189
1190	! local variable
1191	INTEGER(i4) :: il_imin1
1192	INTEGER(i4) :: il_imax1
1193	INTEGER(i4) :: il_jmin1
1194	INTEGER(i4) :: il_jmax1
1195
1196	INTEGER(i4) :: il_imin
1197	INTEGER(i4) :: il_imax
1198	INTEGER(i4) :: il_jmin
1199	INTEGER(i4) :: il_jmax
1200
1201	INTEGER(i4), DIMENSION(ip_npoint) :: il_ishift
1202	INTEGER(i4), DIMENSION(ip_npoint) :: il_jshift
1203
1204	! loop indices
1205	INTEGER(i4) :: ji
1206	INTEGER(i4) :: jk
1207	!----------------------------------------------------------------
1208	! init
1209	jk=id_seg
1210
1211	il_ishift(:)=0
1212	il_jshift(:)=0
1213
1214	! get boundary definition
1215	SELECT CASE(TRIM(td_bdy%c_card))
1216	CASE('north')
1217
1218	il_imin1=td_bdy%t_seg(jk)%i_first
1219	il_imax1=td_bdy%t_seg(jk)%i_last
1220	il_jmin1=td_bdy%t_seg(jk)%i_index-(td_bdy%t_seg(jk)%i_width-1)
1221	il_jmax1=td_bdy%t_seg(jk)%i_index
1222
1223	il_jshift(jp_V)=-1
1224	il_jshift(jp_F)=-1
1225
1226	CASE('south')
1227
1228	il_imin1=td_bdy%t_seg(jk)%i_first
1229	il_imax1=td_bdy%t_seg(jk)%i_last
1230	il_jmin1=td_bdy%t_seg(jk)%i_index
1231	il_jmax1=td_bdy%t_seg(jk)%i_index+(td_bdy%t_seg(jk)%i_width-1)
1232
1233	CASE('east')
1234
1235	il_imin1=td_bdy%t_seg(jk)%i_index-(td_bdy%t_seg(jk)%i_width-1)
1236	il_imax1=td_bdy%t_seg(jk)%i_index
1237	il_jmin1=td_bdy%t_seg(jk)%i_first
1238	il_jmax1=td_bdy%t_seg(jk)%i_last
1239
1240	il_ishift(jp_U)=-1
1241	il_ishift(jp_F)=-1
1242
1243	CASE('west')
1244
1245	il_imin1=td_bdy%t_seg(jk)%i_index
1246	il_imax1=td_bdy%t_seg(jk)%i_index+(td_bdy%t_seg(jk)%i_width-1)
1247	il_jmin1=td_bdy%t_seg(jk)%i_first
1248	il_jmax1=td_bdy%t_seg(jk)%i_last
1249
1250	END SELECT
1251
1252	!-read fine grid domain
1253	DO ji=1,ip_npoint
1254
1255	! shift domain
1256	il_imin=il_imin1+il_ishift(ji)
1257	il_imax=il_imax1+il_ishift(ji)
1258
1259	il_jmin=il_jmin1+il_jshift(ji)
1260	il_jmax=il_jmax1+il_jshift(ji)
1261
1262	! compute domain
1263	create_boundary_get_dom(ji)=dom_init( td_bathy1, &
1264	& il_imin, il_imax,&
1265	& il_jmin, il_jmax,&
1266	& TRIM(td_bdy%c_card) )
1267
1268	ENDDO
1269
1270	END FUNCTION create_boundary_get_dom
1271	!-------------------------------------------------------------------
1272	!> @brief
1273	!> This subroutine get coordinates over boundary domain
1274	!>
1275	!> @author J.Paul
1276	!> @date November, 2013 - Initial Version
1277	!> @date September, 2014
1278	!> - take into account grid point
1279	!>
1280	!> @param[in] td_coord1 coordinates file structure
1281	!> @param[in] td_dom1 boundary domain structure
1282	!> @param[in] cd_point grid point
1283	!> @param[out] td_lon1 longitude variable structure
1284	!> @param[out] td_lat1 latitude variable structure
1285	!-------------------------------------------------------------------
1286	SUBROUTINE create_boundary_get_coord( td_coord1, td_dom1, cd_point, &
1287	& td_lon1, td_lat1 )
1288
1289	IMPLICIT NONE
1290	! Argument
1291	TYPE(TMPP) , INTENT(IN ) :: td_coord1
1292	TYPE(TDOM) , INTENT(IN ) :: td_dom1
1293	CHARACTER(LEN=*), INTENT(IN ) :: cd_point
1294	TYPE(TVAR) , INTENT( OUT) :: td_lon1
1295	TYPE(TVAR) , INTENT( OUT) :: td_lat1
1296
1297	! local variable
1298	TYPE(TMPP) :: tl_coord1
1299
1300	CHARACTER(LEN=lc) :: cl_name
1301	! loop indices
1302	!----------------------------------------------------------------
1303	!read variables on domain (ugly way to do it, have to work on it)
1304	! init mpp structure
1305	tl_coord1=mpp_copy(td_coord1)
1306
1307	! open mpp files
1308	CALL iom_dom_open(tl_coord1, td_dom1)
1309
1310	! read variable value on domain
1311	WRITE(cl_name,*) 'longitude_'//TRIM(cd_point)
1312	td_lon1=iom_dom_read_var( tl_coord1, TRIM(cl_name), td_dom1)
1313	WRITE(cl_name,*) 'latitude_'//TRIM(cd_point)
1314	td_lat1=iom_dom_read_var( tl_coord1, TRIM(cl_name), td_dom1)
1315
1316	! close mpp files
1317	CALL iom_dom_close(tl_coord1)
1318
1319	! clean structure
1320	CALL mpp_clean(tl_coord1)
1321
1322	END SUBROUTINE create_boundary_get_coord
1323	!-------------------------------------------------------------------
1324	!> @brief
1325	!> This subroutine interpolate variable on boundary
1326	!>
1327	!> @details
1328	!>
1329	!> @author J.Paul
1330	!> @date November, 2013 - Initial Version
1331	!>
1332	!> @param[inout] td_var variable structure
1333	!> @param[in] id_rho array of refinment factor
1334	!> @param[in] id_offset array of offset between fine and coarse grid
1335	!> @param[in] id_iext i-direction size of extra bands (default=im_minext)
1336	!> @param[in] id_jext j-direction size of extra bands (default=im_minext)
1337	!-------------------------------------------------------------------
1338	SUBROUTINE create_boundary_interp( td_var, &
1339	& id_rho, &
1340	& id_offset, &
1341	& id_iext, id_jext )
1342
1343	IMPLICIT NONE
1344
1345	! Argument
1346	TYPE(TVAR) , INTENT(INOUT) :: td_var
1347	INTEGER(I4), DIMENSION(:) , INTENT(IN ) :: id_rho
1348	INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_offset
1349
1350	INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext
1351	INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext
1352
1353
1354	! local variable
1355	INTEGER(i4) :: il_iext
1356	INTEGER(i4) :: il_jext
1357	! loop indices
1358	!----------------------------------------------------------------
1359
1360	!WARNING: at least two extrabands are required for cubic interpolation
1361	il_iext=2
1362	IF( PRESENT(id_iext) ) il_iext=id_iext
1363
1364	il_jext=2
1365	IF( PRESENT(id_jext) ) il_jext=id_jext
1366
1367	IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
1368	CALL logger_warn("CREATE BOUNDARY INTERP: at least extrapolation "//&
1369	& "on two points are required with cubic interpolation ")
1370	il_iext=2
1371	ENDIF
1372
1373	IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
1374	CALL logger_warn("CREATE BOUNDARY INTERP: at least extrapolation "//&
1375	& "on two points are required with cubic interpolation ")
1376	il_jext=2
1377	ENDIF
1378
1379	! work on variable
1380	! add extraband
1381	CALL extrap_add_extrabands(td_var, il_iext, il_jext)
1382
1383	! extrapolate variable
1384	CALL extrap_fill_value( td_var )
1385
1386	! interpolate Bathymetry
1387	CALL interp_fill_value( td_var, id_rho(:), &
1388	& id_offset=id_offset(:,:) )
1389
1390	! remove extraband
1391	CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), &
1392	& il_jext*id_rho(jp_J))
1393
1394	END SUBROUTINE create_boundary_interp
1395	!-------------------------------------------------------------------
1396	!> @brief
1397	!> This function create variable, filled with matrix value
1398	!>
1399	!> @details
1400	!> A variable is create with the same name that the input variable,
1401	!> and with dimension of the coordinate file.
1402	!> Then the variable array of value is split into equal subdomain.
1403	!> Each subdomain is fill with the associated value of the matrix.
1404	!>
1405	!> @author J.Paul
1406	!> @date November, 2013 - Initial Version
1407	!>
1408	!> @param[in] td_var variable structure
1409	!> @param[in] td_dom domain structure
1410	!> @param[in] id_nlevel number of levels
1411	!> @return variable structure
1412	!-------------------------------------------------------------------
1413	FUNCTION create_boundary_matrix(td_var, td_dom, id_nlevel)
1414	IMPLICIT NONE
1415	! Argument
1416	TYPE(TVAR) , INTENT(IN) :: td_var
1417	TYPE(TDOM) , INTENT(IN) :: td_dom
1418	INTEGER(i4), INTENT(IN) :: id_nlevel
1419
1420	! function
1421	TYPE(TVAR) :: create_boundary_matrix
1422
1423	! local variable
1424	INTEGER(i4) , DIMENSION(3) :: il_dim
1425	INTEGER(i4) , DIMENSION(3) :: il_size
1426	INTEGER(i4) , DIMENSION(3) :: il_rest
1427
1428	INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ishape
1429	INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_jshape
1430	INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_kshape
1431
1432	REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
1433
1434	TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
1435
1436	! loop indices
1437	INTEGER(i4) :: ji
1438	INTEGER(i4) :: jj
1439	INTEGER(i4) :: jk
1440	!----------------------------------------------------------------
1441
1442	! write value on grid
1443	! get matrix dimension
1444	il_dim(:)=td_var%t_dim(1:3)%i_len
1445
1446	tl_dim(jp_I:jp_J)=dim_copy(td_dom%t_dim(jp_I:jp_J))
1447	tl_dim(jp_K)%i_len=id_nlevel
1448
1449	! split output domain in N subdomain depending of matrix dimension
1450	il_size(:) = tl_dim(1:3)%i_len / il_dim(:)
1451	il_rest(:) = MOD(tl_dim(1:3)%i_len, il_dim(:))
1452
1453	ALLOCATE( il_ishape(il_dim(1)+1) )
1454	il_ishape(:)=0
1455	DO ji=2,il_dim(1)+1
1456	il_ishape(ji)=il_ishape(ji-1)+il_size(1)
1457	ENDDO
1458	! add rest to last cell
1459	il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1)
1460
1461	ALLOCATE( il_jshape(il_dim(2)+1) )
1462	il_jshape(:)=0
1463	DO jj=2,il_dim(2)+1
1464	il_jshape(jj)=il_jshape(jj-1)+il_size(2)
1465	ENDDO
1466	! add rest to last cell
1467	il_jshape(il_dim(2)+1)=il_jshape(il_dim(2)+1)+il_rest(2)
1468
1469	ALLOCATE( il_kshape(il_dim(3)+1) )
1470	il_kshape(:)=0
1471	DO jk=2,il_dim(3)+1
1472	il_kshape(jk)=il_kshape(jk-1)+il_size(3)
1473	ENDDO
1474	! add rest to last cell
1475	il_kshape(il_dim(3)+1)=il_kshape(il_dim(3)+1)+il_rest(3)
1476
1477	! write ouput array of value
1478	ALLOCATE(dl_value( tl_dim(1)%i_len, &
1479	& tl_dim(2)%i_len, &
1480	& tl_dim(3)%i_len, &
1481	& tl_dim(4)%i_len) )
1482
1483	dl_value(:,:,:,:)=0
1484
1485	DO jk=2,il_dim(3)+1
1486	DO jj=2,il_dim(2)+1
1487	DO ji=2,il_dim(1)+1
1488
1489	dl_value( 1+il_ishape(ji-1):il_ishape(ji), &
1490	& 1+il_jshape(jj-1):il_jshape(jj), &
1491	& 1+il_kshape(jk-1):il_kshape(jk), &
1492	& 1 ) = td_var%d_value(ji-1,jj-1,jk-1,1)
1493
1494	ENDDO
1495	ENDDO
1496	ENDDO
1497
1498	! initialise variable with value
1499	create_boundary_matrix=var_init(TRIM(td_var%c_name),dl_value(:,:,:,:))
1500
1501	DEALLOCATE(dl_value)
1502
1503	END FUNCTION create_boundary_matrix
1504	!-------------------------------------------------------------------
1505	!> @brief
1506	!> This subroutine use mask to filled land point with _FillValue
1507	!>
1508	!> @details
1509	!>
1510	!> @author J.Paul
1511	!> @date November, 2013 - Initial Version
1512	!>
1513	!> @param[inout] td_var variable structure
1514	!> @param[in] td_mask mask variable structure
1515	!-------------------------------------------------------------------
1516	SUBROUTINE create_boundary_use_mask( td_var, td_mask )
1517
1518	IMPLICIT NONE
1519
1520	! Argument
1521	TYPE(TVAR), INTENT(INOUT) :: td_var
1522	TYPE(TVAR), INTENT(IN ) :: td_mask
1523
1524	! local variable
1525	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask
1526
1527	! loop indices
1528	INTEGER(i4) :: jk
1529	INTEGER(i4) :: jl
1530	!----------------------------------------------------------------
1531
1532	IF( ANY(td_var%t_dim(1:2)%i_len /= &
1533	& td_mask%t_dim(1:2)%i_len) )THEN
1534	CALL logger_debug(" mask dimension ( "//&
1535	& TRIM(fct_str(td_mask%t_dim(1)%i_len))//","//&
1536	& TRIM(fct_str(td_mask%t_dim(2)%i_len))//")" )
1537	CALL logger_debug(" variable dimension ( "//&
1538	& TRIM(fct_str(td_var%t_dim(1)%i_len))//","//&
1539	& TRIM(fct_str(td_var%t_dim(2)%i_len))//")" )
1540	CALL logger_fatal("CREATE BOUNDARY USE MASK: mask and "//&
1541	& "variable dimension differ." )
1542	ENDIF
1543
1544	ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
1545	& td_var%t_dim(2)%i_len) )
1546
1547	il_mask(:,:)=INT(td_mask%d_value(:,:,1,1))
1548
1549	DO jl=1,td_var%t_dim(4)%i_len
1550	DO jk=1,td_var%t_dim(3)%i_len
1551	WHERE( il_mask(:,:) < jk ) td_var%d_value(:,:,jk,jl)=td_var%d_fill
1552	ENDDO
1553	ENDDO
1554
1555	DEALLOCATE( il_mask )
1556
1557	END SUBROUTINE create_boundary_use_mask
1558	!-------------------------------------------------------------------
1559	!> @brief
1560	!> This function extract level over domain on each grid point, and return
1561	!> array of variable structure
1562	!>
1563	!> @author J.Paul
1564	!> @date November, 2013 - Initial Version
1565	!>
1566	!> @param[in] td_level array of level variable structure
1567	!> @param[in] td_dom array of domain structure
1568	!> @return array of variable structure
1569	!-------------------------------------------------------------------
1570	FUNCTION create_boundary_get_level(td_level, td_dom)
1571	IMPLICIT NONE
1572	! Argument
1573	TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_level
1574	TYPE(TDOM), DIMENSION(:), INTENT(IN) :: td_dom
1575
1576	! function
1577	TYPE(TVAR), DIMENSION(ip_npoint) :: create_boundary_get_level
1578
1579	! local variable
1580	TYPE(TVAR), DIMENSION(ip_npoint) :: tl_var
1581
1582	! loop indices
1583	INTEGER(i4) :: ji
1584	!----------------------------------------------------------------
1585
1586	IF( SIZE(td_level(:)) /= ip_npoint .OR. &
1587	& SIZE(td_dom(:)) /= ip_npoint )THEN
1588	CALL logger_error("CREATE BDY GET LEVEL: invalid dimension. "//&
1589	& "check input array of level and domain.")
1590	ELSE
1591
1592	DO ji=1,ip_npoint
1593
1594	tl_var(ji)=var_copy(td_level(ji))
1595
1596	IF( ASSOCIATED(tl_var(ji)%d_value) ) DEALLOCATE(tl_var(ji)%d_value)
1597
1598	tl_var(ji)%t_dim(1)%i_len=td_dom(ji)%t_dim(1)%i_len
1599	tl_var(ji)%t_dim(2)%i_len=td_dom(ji)%t_dim(2)%i_len
1600	ALLOCATE(tl_var(ji)%d_value(tl_var(ji)%t_dim(1)%i_len, &
1601	& tl_var(ji)%t_dim(2)%i_len, &
1602	& tl_var(ji)%t_dim(3)%i_len, &
1603	& tl_var(ji)%t_dim(4)%i_len) )
1604
1605	tl_var(ji)%d_value(:,:,:,:) = &
1606	& td_level(ji)%d_value( td_dom(ji)%i_imin:td_dom(ji)%i_imax, &
1607	& td_dom(ji)%i_jmin:td_dom(ji)%i_jmax, :, : )
1608
1609	ENDDO
1610	! save result
1611	create_boundary_get_level(:)=var_copy(tl_var(:))
1612
1613	! clean
1614	CALL var_clean(tl_var(:))
1615
1616	ENDIF
1617	END FUNCTION create_boundary_get_level
1618	!-------------------------------------------------------------------
1619	!> @brief
1620	!> This subroutine check if variable need depth dimension,
1621	!> get depth variable value in an open mpp structure
1622	!> and check if agree with already input depth variable.
1623	!>
1624	!> @details
1625	!>
1626	!> @author J.Paul
1627	!> @date November, 2014 - Initial Version
1628	!> @date January, 2016
1629	!> - check if variable need/use depth dimension
1630	!>
1631	!> @param[in] td_var variable structure
1632	!> @param[in] td_mpp mpp structure
1633	!> @param[in] id_nlevel mpp structure
1634	!> @param[inout] td_depth depth variable structure
1635	!-------------------------------------------------------------------
1636	SUBROUTINE create_boundary_check_depth( td_var, td_mpp, id_nlevel, td_depth )
1637
1638	IMPLICIT NONE
1639
1640	! Argument
1641	TYPE(TVAR) , INTENT(IN ) :: td_var
1642	TYPE(TMPP) , INTENT(IN ) :: td_mpp
1643	INTEGER(i4), INTENT(IN ) :: id_nlevel
1644	TYPE(TVAR) , INTENT(INOUT) :: td_depth
1645
1646	! local variable
1647	INTEGER(i4) :: il_varid
1648	TYPE(TVAR) :: tl_depth
1649	! loop indices
1650	!----------------------------------------------------------------
1651
1652	IF( td_var%t_dim(jp_K)%l_use .AND. &
1653	& ( TRIM(td_var%c_axis) == '' .OR. &
1654	& INDEX(TRIM(td_var%c_axis),'Z') /= 0 )&
1655	& )THEN
1656
1657	! check vertical dimension
1658	IF( td_mpp%t_dim(jp_K)%l_use )THEN
1659	IF( td_mpp%t_dim(jp_K)%i_len /= id_nlevel .AND. &
1660	& td_mpp%t_dim(jp_K)%i_len /= 1 )THEN
1661	CALL logger_error("CREATE BOUNDARY: dimension in file "//&
1662	& TRIM(td_mpp%c_name)//" not agree with namelist in_nlevel ")
1663	ENDIF
1664	ENDIF
1665
1666	! get or check depth value
1667	IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN
1668
1669	il_varid=td_mpp%t_proc(1)%i_depthid
1670	IF( ASSOCIATED(td_depth%d_value) )THEN
1671
1672	tl_depth=iom_mpp_read_var(td_mpp, il_varid)
1673
1674	IF( ANY( td_depth%d_value(:,:,:,:) /= &
1675	& tl_depth%d_value(:,:,:,:) ) )THEN
1676
1677	CALL logger_error("CREATE BOUNDARY: depth value "//&
1678	& "for variable "//TRIM(td_var%c_name)//&
1679	& "from "//TRIM(td_mpp%c_name)//" not conform "//&
1680	& " to those from former file(s).")
1681
1682	ENDIF
1683	CALL var_clean(tl_depth)
1684
1685	ELSE
1686	td_depth=iom_mpp_read_var(td_mpp,il_varid)
1687	ENDIF
1688
1689	ENDIF
1690	ELSE
1691	CALL logger_debug("CREATE BOUNDARY: no depth dimension use"//&
1692	& " for variable "//TRIM(td_var%c_name))
1693	ENDIF
1694
1695	END SUBROUTINE create_boundary_check_depth
1696	!-------------------------------------------------------------------
1697	!> @brief
1698	!> This subroutine check if variable need time dimension,
1699	!> get date and time in an open mpp structure
1700	!> and check if agree with date and time already read.
1701	!>
1702	!> @details
1703	!>
1704	!> @author J.Paul
1705	!> @date November, 2014 - Initial Version
1706	!> @date January, 2016
1707	!> - check if variable need/use time dimension
1708	!>
1709	!> @param[in] td_var variable structure
1710	!> @param[in] td_mpp mpp structure
1711	!> @param[inout] td_time time variable structure
1712	!-------------------------------------------------------------------
1713	SUBROUTINE create_boundary_check_time( td_var, td_mpp, td_time )
1714
1715	IMPLICIT NONE
1716
1717	! Argument
1718	TYPE(TVAR), INTENT(IN ) :: td_var
1719	TYPE(TMPP), INTENT(IN ) :: td_mpp
1720	TYPE(TVAR), INTENT(INOUT) :: td_time
1721
1722	! local variable
1723	INTEGER(i4) :: il_varid
1724	TYPE(TVAR) :: tl_time
1725
1726	TYPE(TDATE) :: tl_date1
1727	TYPE(TDATE) :: tl_date2
1728	! loop indices
1729	!----------------------------------------------------------------
1730	IF( td_var%t_dim(jp_L)%l_use .AND. &
1731	& ( TRIM(td_var%c_axis) == '' .OR. &
1732	& INDEX(TRIM(td_var%c_axis),'T') /= 0 )&
1733	& )THEN
1734
1735	! get or check depth value
1736	IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN
1737
1738	il_varid=td_mpp%t_proc(1)%i_timeid
1739	IF( ASSOCIATED(td_time%d_value) )THEN
1740
1741	tl_time=iom_mpp_read_var(td_mpp, il_varid)
1742
1743	tl_date1=var_to_date(td_time)
1744	tl_date2=var_to_date(tl_time)
1745	IF( tl_date1 - tl_date2 /= 0 )THEN
1746
1747	CALL logger_warn("CREATE BOUNDARY: date from "//&
1748	& TRIM(td_mpp%c_name)//" not conform "//&
1749	& " to those from former file(s).")
1750
1751	ENDIF
1752	CALL var_clean(tl_time)
1753
1754	ELSE
1755	td_time=iom_mpp_read_var(td_mpp,il_varid)
1756	ENDIF
1757
1758	ENDIF
1759
1760	ELSE
1761	CALL logger_debug("CREATE BOUNDARY: no time dimension use"//&
1762	& " for variable "//TRIM(td_var%c_name))
1763	ENDIF
1764
1765	END SUBROUTINE create_boundary_check_time
1766	END PROGRAM create_boundary

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

Download in other formats: