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/2013/dev_rev4119_MERCATOR4_CONFMAN/NEMOGCM/TOOLS/SIREN/src – NEMO

Context Navigation

source: branches/2013/dev_rev4119_MERCATOR4_CONFMAN/NEMOGCM/TOOLS/SIREN/src/create_boundary.f90 @ 4213

Last change on this file since 4213 was 4213, checked in by cbricaud, 10 years ago
first draft of the CONFIGURATION MANAGER demonstrator
File size: 49.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	!> @brief
10	!> This program create boundary files.
11	!>
12	!> @details
13	!> Variables are read from standard output.
14	!> Then theses variables are interpolated on fine grid boundaries.
15	!>
16	!> @author
17	!> J.Paul
18	! REVISION HISTORY:
19	!> @date Nov, 2013 - Initial Version
20	!
21	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
22	!>
23	!> @todo
24	!----------------------------------------------------------------------
25	!> @code
26	PROGRAM create_boundary
27
28	USE netcdf ! nf90 library
29	USE global ! global variable
30	USE phycst ! physical constant
31	USE kind ! F90 kind parameter
32	USE logger ! log file manager
33	USE fct ! basic useful function
34	USE date ! date manager
35	USE att ! attribute manager
36	USE dim ! dimension manager
37	USE var ! variable manager
38	USE file ! file manager
39	USE multi ! multi file manager
40	USE boundary ! boundary manager
41	USE iom ! I/O manager
42	USE dom ! domain manager
43	USE grid ! grid manager
44	USE vgrid ! vartical grid manager
45	USE extrap ! extrapolation manager
46	USE interp ! interpolation manager
47	USE filter ! filter manager
48	USE mpp ! MPP manager
49	USE iom_mpp ! MPP I/O manager
50
51	IMPLICIT NONE
52
53	! local variable
54	CHARACTER(LEN=lc) :: cl_namelist
55	CHARACTER(LEN=lc) :: cl_date
56	CHARACTER(LEN=lc) :: cl_name
57	CHARACTER(LEN=lc) :: cl_bdyout
58	CHARACTER(LEN=lc) :: cl_data
59
60	INTEGER(i4) :: il_narg
61	INTEGER(i4) :: il_status
62	INTEGER(i4) :: il_fileid
63	INTEGER(i4) :: il_attid
64	INTEGER(i4) :: il_dim
65	INTEGER(i4) :: il_imin0
66	INTEGER(i4) :: il_imax0
67	INTEGER(i4) :: il_jmin0
68	INTEGER(i4) :: il_jmax0
69	INTEGER(i4) , DIMENSION(ip_maxdim) :: il_rho
70	INTEGER(i4) , DIMENSION(2,2) :: il_offset
71	INTEGER(i4) , DIMENSION(2,2,2) :: il_ind
72
73	LOGICAL :: ll_exist
74
75	TYPE(TFILE) :: tl_coord0
76	TYPE(TFILE) :: tl_bathy0
77	TYPE(TFILE) :: tl_coord1
78	TYPE(TFILE) :: tl_bathy1
79	TYPE(TFILE) :: tl_file
80	TYPE(TFILE) :: tl_fileout
81
82	TYPE(TMPP) :: tl_mpp
83
84	TYPE(TMULTI) :: tl_multi
85
86	TYPE(TATT) :: tl_att
87
88	TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_level
89	TYPE(TVAR) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_seglvl1
90	TYPE(TVAR) :: tl_var1
91	TYPE(TVAR) , DIMENSION(:,:,:) , ALLOCATABLE :: tl_segvar1
92	TYPE(TVAR) , DIMENSION(:,:) , ALLOCATABLE :: tl_seglon1
93	TYPE(TVAR) , DIMENSION(:,:) , ALLOCATABLE :: tl_seglat1
94	TYPE(TVAR) , DIMENSION(:,:) , ALLOCATABLE :: tl_var
95	TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_lon1
96	TYPE(TVAR) , DIMENSION(:) , ALLOCATABLE :: tl_lat1
97	TYPE(TVAR) :: tl_depth
98	TYPE(TVAR) :: tl_time
99	TYPE(TVAR) :: tl_tmp
100
101	TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
102
103	TYPE(TBDY) , DIMENSION(ip_ncard) :: tl_bdy
104
105	TYPE(TDOM) :: tl_dom0
106	TYPE(TDOM) , DIMENSION(:,:) , ALLOCATABLE :: tl_segdom1
107
108	! loop indices
109	INTEGER(i4) :: jvar
110	INTEGER(i4) :: ji
111	INTEGER(i4) :: jj
112	INTEGER(i4) :: jk
113	INTEGER(i4) :: jl
114
115	! namelist variable
116	! namlog
117	CHARACTER(LEN=lc) :: cn_logfile = 'create_boundary.log'
118	CHARACTER(LEN=lc) :: cn_verbosity = 'warning'
119
120	! namcrs
121	CHARACTER(LEN=lc) :: cn_coord0 = ''
122	INTEGER(i4) :: in_perio0 = -1
123
124	! namfin
125	CHARACTER(LEN=lc) :: cn_coord1 = ''
126	CHARACTER(LEN=lc) :: cn_bathy1 = ''
127	INTEGER(i4) :: in_perio1 = -1
128
129	! namcfg
130	CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg'
131
132	! namvar
133	CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varinfo = ''
134	CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varfile = ''
135
136	! namnst
137	INTEGER(i4) :: in_imin0 = 0
138	INTEGER(i4) :: in_imax0 = 0
139	INTEGER(i4) :: in_jmin0 = 0
140	INTEGER(i4) :: in_jmax0 = 0
141	INTEGER(i4) :: in_rhoi = 1
142	INTEGER(i4) :: in_rhoj = 1
143
144	! nambdy
145	LOGICAL :: ln_north = .TRUE.
146	LOGICAL :: ln_south = .TRUE.
147	LOGICAL :: ln_east = .TRUE.
148	LOGICAL :: ln_west = .TRUE.
149	CHARACTER(LEN=lc) :: cn_north = ''
150	CHARACTER(LEN=lc) :: cn_south = ''
151	CHARACTER(LEN=lc) :: cn_east = ''
152	CHARACTER(LEN=lc) :: cn_west = ''
153	LOGICAL :: ln_oneseg = .TRUE.
154	INTEGER(i4) :: in_extrap = 0
155
156	! namout
157	CHARACTER(LEN=lc) :: cn_fileout = 'boundary.nc'
158	!-------------------------------------------------------------------
159
160	NAMELIST /namlog/ & !< logger namelist
161	& cn_logfile, & !< log file
162	& cn_verbosity !< log verbosity
163
164	NAMELIST /namcfg/ & !< config namelist
165	& cn_varcfg !< variable configuration file
166
167	NAMELIST /namcrs/ & !< coarse grid namelist
168	& cn_coord0, & !< coordinate file
169	& in_perio0 !< periodicity index
170
171	NAMELIST /namfin/ & !< fine grid namelist
172	& cn_coord1, & !< coordinate file
173	& cn_bathy1, & !< bathymetry file
174	& in_perio1 !< periodicity index
175
176	NAMELIST /namvar/ & !< variable namelist
177	& cn_varinfo, & !< list of variable and method to apply on. (ex: 'votemper:linear','vosaline:cubic' )
178	& cn_varfile !< list of variable and file where find it. (ex: 'votemper:GLORYS_gridT.nc' )
179
180	NAMELIST /namnst/ & !< nesting namelist
181	& in_imin0, & !< i-direction lower left point indice on coarse grid
182	& in_imax0, & !< i-direction upper right point indice on coarse grid
183	& in_jmin0, & !< j-direction lower left point indice on coarse grid
184	& in_jmax0, & !< j-direction upper right point indice on coarse grid
185	& in_rhoi, & !< refinement factor in i-direction
186	& in_rhoj !< refinement factor in j-direction
187
188	NAMELIST /nambdy/ & !< boundary namelist
189	& ln_north, & !< use north boundary
190	& ln_south, & !< use south boundary
191	& ln_east , & !< use east boundary
192	& ln_west , & !< use west boundary
193	& cn_north, & !< north boundary indices on fine grid
194	& cn_south, & !< south boundary indices on fine grid
195	& cn_east , & !< east boundary indices on fine grid
196	& cn_west , & !< west boundary indices on fine grid
197	& ln_oneseg, & !< use only one segment for each boundary or not
198	& in_extrap !< number of mask point to extrapolate
199
200	NAMELIST /namout/ & !< output namelist
201	& cn_fileout !< fine grid boundary file basename
202	!-------------------------------------------------------------------
203
204	!1- namelist
205	!1-1 get namelist
206	il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
207	IF( il_narg/=1 )THEN
208	PRINT *,"CREATE BOUNDARY: ERROR. need a namelist"
209	STOP
210	ELSE
211	CALL GET_COMMAND_ARGUMENT(1,cl_namelist) !f03 intrinsec
212	ENDIF
213
214	!1-2 read namelist
215	INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist)
216	IF( ll_exist )THEN
217
218	il_fileid=fct_getunit()
219
220	OPEN( il_fileid, FILE=TRIM(cl_namelist), &
221	& FORM='FORMATTED', &
222	& ACCESS='SEQUENTIAL', &
223	& STATUS='OLD', &
224	& ACTION='READ', &
225	& IOSTAT=il_status)
226	CALL fct_err(il_status)
227	IF( il_status /= 0 )THEN
228	PRINT *,"CREATE BOUNDARY: ERROR opening "//TRIM(cl_namelist)
229	STOP
230	ENDIF
231
232	READ( il_fileid, NML = namlog )
233	!1-2-1 define log file
234	CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity))
235	CALL logger_header()
236
237	READ( il_fileid, NML = namcfg )
238	!1-2-2 get variable extra information
239	CALL var_def_extra(TRIM(cn_varcfg))
240
241	READ( il_fileid, NML = namcrs )
242	READ( il_fileid, NML = namfin )
243	READ( il_fileid, NML = namvar )
244	!1-2-3 add user change in extra information
245	CALL var_chg_extra(cn_varinfo)
246	!1-2-4 match variable with file
247	tl_multi=multi_init(cn_varfile)
248
249	READ( il_fileid, NML = namnst )
250	READ( il_fileid, NML = nambdy )
251
252	READ( il_fileid, NML = namout )
253
254	CLOSE( il_fileid, IOSTAT=il_status )
255	CALL fct_err(il_status)
256	IF( il_status /= 0 )THEN
257	CALL logger_error("CREATE BOUNDARY: ERROR closing "//TRIM(cl_namelist))
258	ENDIF
259
260	ELSE
261
262	PRINT *,"CREATE BOUNDARY: ERROR. can not find "//TRIM(cl_namelist)
263
264	ENDIF
265
266	!2- open files
267	IF( TRIM(cn_coord0) /= '' )THEN
268	tl_coord0=file_init(TRIM(cn_coord0),id_perio=in_perio0)
269	CALL iom_open(tl_coord0)
270	ELSE
271	CALL logger_fatal("CREATE BOUNDARY: can not find coarse grid "//&
272	& "coordinate file. check namelist")
273	ENDIF
274
275	IF( TRIM(cn_coord1) /= '' )THEN
276	tl_coord1=file_init(TRIM(cn_coord1),id_perio=in_perio1)
277	CALL iom_open(tl_coord1)
278	ELSE
279	CALL logger_fatal("CREATE BOUNDARY: can not find fine grid coordinate "//&
280	& "file. check namelist")
281	ENDIF
282
283	IF( TRIM(cn_bathy1) /= '' )THEN
284	tl_bathy1=file_init(TRIM(cn_bathy1),id_perio=in_perio1)
285	CALL iom_open(tl_bathy1)
286	ELSE
287	CALL logger_fatal("CREATE BOUNDARY: can not find fine grid bathymetry "//&
288	& "file. check namelist")
289	ENDIF
290
291	!3- check
292	!3-1 check output file do not already exist
293	DO jk=1,ip_ncard
294	cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
295	& TRIM(ip_card(jk)) )
296	INQUIRE(FILE=TRIM(cl_bdyout), EXIST=ll_exist)
297	IF( ll_exist )THEN
298	CALL logger_fatal("CREATE BOUNDARY: output file "//TRIM(cl_bdyout)//&
299	& " already exist.")
300	ENDIF
301	ENDDO
302
303	!3-1 check namelist
304	!3-1-1 check refinement factor
305	il_rho(:)=1
306	IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN
307	CALL logger_error("CREATE BOUNDARY: invalid refinement factor."//&
308	& " check namelist "//TRIM(cl_namelist))
309	ELSE
310	il_rho(jp_I)=in_rhoi
311	il_rho(jp_J)=in_rhoj
312	ENDIF
313
314	!3-1-2
315	IF( in_imin0 < 1 .OR. in_imax0 < 1 .OR. in_jmin0 < 1 .OR. in_jmax0 < 1)THEN
316	! compute coarse grid indices around fine grid
317	il_ind(:,:,:)=grid_get_coarse_index(tl_bathy0, tl_bathy1 )
318
319	il_imin0=il_ind(1,1,1) ; il_imax0=il_ind(1,2,1)
320	il_jmin0=il_ind(2,1,1) ; il_jmax0=il_ind(2,2,1)
321	ELSE
322	il_imin0=in_imin0 ; il_imax0=in_imax0
323	il_jmin0=in_jmin0 ; il_jmax0=in_jmax0
324	ENDIF
325
326	!3-2 check domain validity
327	CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0)
328
329	!3-3 check coordinate file
330	CALL grid_check_coincidence( tl_coord0, tl_coord1, &
331	& il_imin0, il_imax0, &
332	& il_jmin0, il_jmax0, &
333	& il_rho(:) )
334
335	!4- read or compute boundary
336	tl_var1=iom_read_var(tl_bathy1,'Bathymetry')
337
338	tl_bdy(:)=boundary_init(tl_var1, ln_north, ln_south, ln_east, ln_west, &
339	& cn_north, cn_south, cn_east, cn_west, &
340	& ln_oneseg )
341
342	CALL var_clean(tl_var1)
343
344	!5- compute level
345	ALLOCATE(tl_level(ig_npoint))
346	tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist )
347
348	!6- get coordinate on each segment of each boundary
349	ALLOCATE( tl_seglon1(ip_ncard,ig_maxseg) )
350	ALLOCATE( tl_seglat1(ip_ncard,ig_maxseg) )
351	ALLOCATE( tl_segdom1(ip_ncard,ig_maxseg) )
352	ALLOCATE( tl_segvar1(tl_multi%i_nvar,ip_ncard,ig_maxseg) )
353	ALLOCATE( tl_seglvl1(ip_ncard,ig_maxseg,ig_npoint) )
354	DO jk=1,ip_ncard
355	IF( tl_bdy(jk)%l_use )THEN
356	DO jl=1,tl_bdy(jk)%i_nseg
357	!6-1 get fine grid segment domain
358	tl_segdom1(jk,jl)=create_boundary_get_dom( tl_bathy1, tl_bdy(jk), jl )
359
360	!6-2 get fine grid segment coordinate
361	CALL create_boundary_get_coord( tl_bathy1, tl_segdom1(jk,jl), &
362	& tl_seglon1(jk,jl), tl_seglat1(jk,jl) )
363	!6-2 get fine grid segment coordinate
364	tl_seglvl1(jk,jl,:)=create_bdy_get_level(tl_level(:), tl_segdom1(jk,jl))
365
366	ENDDO
367	ENDIF
368	ENDDO
369
370	DEALLOCATE(tl_level)
371
372	!7- compute boundary for variable to be used (see namelist)
373	IF( .NOT. ASSOCIATED(tl_multi%t_file) )THEN
374	CALL logger_error("CREATE BOUNDARY: no file to work on. "//&
375	& "check cn_varfile in namelist.")
376	ELSE
377	jvar=0
378	! for each file
379	DO ji=1,tl_multi%i_nfile
380	WRITE(cl_data,'(a,i2.2)') 'data_',jvar+1
381
382	IF( .NOT. ASSOCIATED(tl_multi%t_file(ji)%t_var) )THEN
383	CALL logger_error("CREATE BOUNDARY: no variable to work on for "//&
384	& "file "//TRIM(tl_multi%t_file(ji)%c_name)//&
385	& ". check cn_varfile in namelist.")
386	ELSE
387	IF( .NOT. ASSOCIATED(tl_multi%t_file(ji)%t_var) )THEN
388
389	CALL logger_error("CREATE BOUNDARY: no variable to work on for "//&
390	& "file "//TRIM(tl_multi%t_file(ji)%c_name)//&
391	& ". check cn_varfile in namelist.")
392
393	ELSEIF( TRIM(tl_multi%t_file(ji)%c_name) == TRIM(cl_data) )THEN
394	!- use input matrix to fill variable
395
396	! for each variable initialise from matrix
397	DO jj=1,tl_multi%t_file(ji)%i_nvar
398	jvar=jvar+1
399	tl_tmp=tl_multi%t_file(ji)%t_var(jj)
400	DO jk=1,ip_ncard
401	IF( tl_bdy(jk)%l_use )THEN
402	DO jl=1,tl_bdy(jk)%i_nseg
403	!7-1 fill value with matrix data
404	! pb voir comment gerer nb de dimension
405	tl_segvar1(jvar,jk,jl)=create_bdy_matrix(tl_tmp, tl_segdom1(jk,jl), tl_coord1)
406
407	!7-2 use mask
408	CALL create_bdy_use_mask(tl_segvar1(jvar,jk,jl), tl_seglvl1(jk,jl,:))
409	ENDDO
410	ENDIF
411	ENDDO
412	ENDDO
413
414	ELSE
415	!- use file to fill variable
416
417	! open file
418	tl_file=file_init(TRIM(tl_multi%t_file(ji)%c_name))
419	CALL iom_open(tl_file)
420
421	! get or check depth value
422	IF( tl_file%i_depthid /= 0 )THEN
423	IF( ASSOCIATED(tl_depth%d_value) )THEN
424	IF( ANY( tl_depth%d_value(:,:,:,:) /= &
425	& tl_tmp%d_value(:,:,:,:) ) )THEN
426	CALL logger_fatal("CREATE BOUNDARY: depth value from "//&
427	& TRIM(tl_multi%t_file(ji)%c_name)//" not conform "//&
428	& " to those from former file(s).")
429	ENDIF
430	ELSE
431	tl_depth=iom_read_var(tl_file,tl_file%i_depthid)
432	ENDIF
433	ENDIF
434
435	! get or check time value
436	IF( tl_file%i_timeid /= 0 )THEN
437	IF( ASSOCIATED(tl_time%d_value) )THEN
438	IF( ANY( tl_time%d_value(:,:,:,:) /= &
439	& tl_tmp%d_value(:,:,:,:) ) )THEN
440	CALL logger_fatal("CREATE BOUNDARY: time value from "//&
441	& TRIM(tl_multi%t_file(ji)%c_name)//" not conform "//&
442	& " to those from former file(s).")
443	ENDIF
444	ELSE
445	tl_time=iom_read_var(tl_file,tl_file%i_timeid)
446	ENDIF
447	ENDIF
448
449	IF( ANY( tl_file%t_dim(1:2)%i_len /= &
450	& tl_coord0%t_dim(1:2)%i_len) )THEN
451	!- extract value from fine grid
452	DO jk=1,ip_ncard
453	IF( tl_bdy(jk)%l_use )THEN
454
455	DO jl=1,tl_bdy(jk)%i_nseg
456	!7-1 compute domain on fine grid
457
458	! open mpp file on domain
459	!7-2 init mpp structure
460	tl_mpp=mpp_init(tl_file)
461
462	!7-3 get processor to be used
463	CALL mpp_get_use( tl_mpp, tl_segdom1(jk,jl) )
464	!7-4 open mpp files
465	CALL iom_mpp_open(tl_mpp)
466
467	! for each variable of this file
468	DO jj=1,tl_multi%t_file(ji)%i_nvar
469
470	cl_name=tl_multi%t_file(ji)%t_var(jj)%c_name
471	!7-5 read variable over domain
472	tl_segvar1(jvar+jj,jk,jl)=iom_mpp_read_var( tl_mpp, TRIM(cl_name), &
473	& td_dom=tl_segdom1(jk,jl) )
474
475	!7-6 add attribute to variable
476	tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
477	CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
478
479	tl_att=att_init('src_i-indices',(/tl_segdom1(jk,jl)%i_imin, tl_segdom1(jk,jl)%i_imax/))
480	CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
481
482	tl_att=att_init('src_j-indices',(/tl_segdom1(jk,jl)%i_jmin, tl_segdom1(jk,jl)%i_jmax/))
483	CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
484
485	! clean structure
486	CALL att_clean(tl_att)
487
488	!7-7 use mask
489	CALL create_bdy_use_mask(tl_segvar1(jvar+jj,jk,jl), tl_seglvl1(jk,jl,:))
490	ENDDO
491
492	!7-8 close mpp files
493	CALL iom_mpp_close(tl_mpp)
494
495	CALL mpp_clean(tl_mpp)
496
497	ENDDO
498	ENDIF
499	ENDDO
500	jvar=jvar+tl_multi%t_file(ji)%i_nvar
501	ELSE
502	!- interpolate value from coarse grid
503
504	DO jk=1,ip_ncard
505	IF( tl_bdy(jk)%l_use )THEN
506
507	DO jl=1,tl_bdy(jk)%i_nseg
508	!7-1 get coarse grid indices of this segment
509	il_ind(:,:,:)=grid_get_coarse_index(tl_coord0, &
510	& tl_seglon1(jk,jl), tl_seglat1(jk,jl), &
511	& id_rho=il_rho(:) )
512
513	IF( ANY(il_ind(:,:,:)==0) )THEN
514	CALL logger_error("CREATE BOUNDARY: error computing "//&
515	& " coarse grid indices")
516	ELSE
517	il_imin0=il_ind(1,1,1)
518	il_imax0=il_ind(1,2,1)
519
520	il_jmin0=il_ind(2,1,1)
521	il_jmax0=il_ind(2,2,1)
522
523	il_offset(:,:)=il_ind(:,:,2)
524	ENDIF
525
526	!7-2 compute coarse grid segment domain
527	tl_dom0=dom_init( tl_coord0, &
528	& il_imin0, il_imax0,&
529	& il_jmin0, il_jmax0 )
530
531	!7-3 add extra band (if possible) to compute interpolation
532	CALL dom_add_extra(tl_dom0)
533
534	!7-4 read variables on domain (ugly way to do it, have to work on it)
535	!7-4-1 init mpp structure
536	tl_mpp=mpp_init(tl_file)
537
538	!7-4-2 get processor to be used
539	CALL mpp_get_use( tl_mpp, tl_dom0 )
540
541	!7-4-3 open mpp files
542	CALL iom_mpp_open(tl_mpp)
543
544	! check file dimension
545	IF( ANY(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) )THEN
546	CALL logger_error("CREATE BOUNDARY INTERP: dimension of file "//&
547	& TRIM(tl_mpp%c_name)//" not conform to those of "//&
548	& TRIM(tl_coord0%c_name))
549	ELSE
550
551	! for each variable of this file
552	DO jj=1,tl_multi%t_file(ji)%i_nvar
553
554	cl_name=tl_multi%t_file(ji)%t_var(jj)%c_name
555	!7-4-4 read variable value on domain
556	tl_segvar1(jvar+jj,jk,jl)=iom_mpp_read_var( tl_mpp, TRIM(cl_name), &
557	& td_dom=tl_dom0 )
558
559	!7-4-5 work on variable
560	CALL create_boundary_interp(tl_segvar1(jvar+jj,jk,jl), &
561	& il_rho(:), &
562	& il_offset(:,:) )
563
564	!7-4-6 remove extraband added to domain
565	CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), tl_dom0, il_rho(:) )
566
567	!7-4-7 keep only useful point (width)
568	! interpolation could create more point than necessary
569	CALL boundary_clean_interp(tl_segvar1(jvar+jj,jk,jl), tl_bdy(jk) )
570
571	!7-4-8 add attribute to variable
572	tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
573	CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
574
575	tl_att=att_init('src_i-indices',(/tl_dom0%i_imin, tl_dom0%i_imax/))
576	CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
577
578	tl_att=att_init('src_j-indices',(/tl_dom0%i_jmin, tl_dom0%i_jmax/))
579	CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att)
580
581	! clean structure
582	CALL att_clean(tl_att)
583
584	!7-4-9 use mask
585	CALL create_bdy_use_mask(tl_segvar1(jvar+jj,jk,jl), tl_seglvl1(jk,jl,:))
586	ENDDO
587	ENDIF
588
589	CALL dom_clean(tl_dom0)
590
591	!7-5 close mpp files
592	CALL iom_mpp_close(tl_mpp)
593
594	!7-6 clean structure
595	CALL mpp_clean(tl_mpp)
596	ENDDO
597	ENDIF
598	ENDDO
599	jvar=jvar+tl_multi%t_file(ji)%i_nvar
600
601	ENDIF
602	CALL file_clean(tl_file)
603
604	ENDIF
605	ENDIF
606	ENDDO
607	ENDIF
608	IF( jvar /= tl_multi%i_nvar )THEN
609	CALL logger_error("CREATE BOUNDARY: it seems some variable can not be read")
610	ENDIF
611
612	!8- concatenate file
613	ALLOCATE( tl_lon1(ip_ncard) )
614	ALLOCATE( tl_lat1(ip_ncard) )
615	ALLOCATE( tl_var(tl_multi%i_nvar,ip_ncard) )
616
617	DO jk=1,ip_ncard
618	IF( tl_bdy(jk)%l_use )THEN
619
620	SELECT CASE(TRIM(tl_bdy(jk)%c_card))
621	CASE('north','south')
622	il_dim=1
623	CASE('east','west')
624	il_dim=2
625	END SELECT
626
627	DO jl=1,tl_bdy(jk)%i_nseg
628	!- concatenate variable
629	IF( jl == 1 )THEN
630	tl_lon1(jk)=tl_seglon1(jk,jl)
631	tl_lat1(jk)=tl_seglat1(jk,jl)
632	DO jvar=1,tl_multi%i_nvar
633	tl_var(jvar,jk)=tl_segvar1(jvar,jk,jl)
634	ENDDO
635	ELSE
636	tl_lon1(jk)=var_concat(tl_lon1(jk),tl_seglon1(jk,jl),DIM=il_dim)
637	tl_lat1(jk)=var_concat(tl_lat1(jk),tl_seglat1(jk,jl),DIM=il_dim)
638	DO jvar=1,tl_multi%i_nvar
639	tl_var(jvar,jk)=var_concat(tl_var(jvar,jk),tl_segvar1(jvar,jk,jl),DIM=il_dim)
640	ENDDO
641	ENDIF
642	ENDDO
643
644	! swap array
645	CALL boundary_swap(tl_lon1(jk), tl_bdy(jk))
646	CALL boundary_swap(tl_lat1(jk), tl_bdy(jk))
647	DO jvar=1,tl_multi%i_nvar
648	CALL boundary_swap(tl_var(jvar,jk), tl_bdy(jk))
649
650	!9- use additional request
651
652	!9-1 forced min and max value
653	CALL var_limit_value(tl_var(jvar,jk))
654
655	!9-2 filter
656	CALL filter_fill_value(tl_var(jvar,jk))
657
658	!9-3 extrapolate
659	CALL extrap_fill_value(tl_var(jvar,jk), id_iext=in_extrap, &
660	& id_jext=in_extrap, &
661	& id_kext=in_extrap)
662
663	ENDDO
664	ENDIF
665	ENDDO
666
667	DEALLOCATE( tl_seglon1 )
668	DEALLOCATE( tl_seglat1 )
669	DEALLOCATE( tl_segdom1 )
670	DEALLOCATE( tl_segvar1 )
671	DEALLOCATE( tl_seglvl1 )
672
673	DO jk=1,ip_ncard
674	IF( tl_bdy(jk)%l_use )THEN
675
676	!10 create file
677	!10-1 create file structure
678	!10-1-1 set file name
679	cl_bdyout=boundary_set_filename( TRIM(cn_fileout), &
680	& TRIM(tl_bdy(jk)%c_card) )
681	!10-1-2
682	tl_fileout=file_init(TRIM(cl_bdyout),id_perio=in_perio1)
683
684	!10-2 add dimension
685	tl_dim(:)=var_max_dim(tl_var(:,jk))
686
687	DO ji=1,ip_maxdim
688	IF( tl_dim(ji)%l_use ) CALL file_add_dim(tl_fileout, tl_dim(ji))
689	ENDDO
690
691	!10-3 add variables
692	IF( ALL( tl_dim(1:2)%l_use ) )THEN
693	! add longitude
694	CALL file_add_var(tl_fileout, tl_lon1(jk))
695	CALL var_clean(tl_lon1(jk))
696
697	! add latitude
698	CALL file_add_var(tl_fileout, tl_lat1(jk))
699	CALL var_clean(tl_lat1(jk))
700	ENDIF
701
702	IF( tl_dim(3)%l_use )THEN
703	! add depth
704	CALL file_add_var(tl_fileout, tl_depth)
705	ENDIF
706
707	IF( tl_dim(4)%l_use )THEN
708	! add time
709	CALL file_add_var(tl_fileout, tl_time)
710	ENDIF
711
712	! add other variable
713	DO jvar=1,tl_multi%i_nvar
714	!IF( TRIM(tl_var(jvar,jk)%c_name) /= 'X' .AND. &
715	!& TRIM(tl_var(jvar,jk)%c_name) /= 'Y' )THEN
716	CALL file_add_var(tl_fileout, tl_var(jvar,jk))
717	!ENDIF
718	CALL var_clean(tl_var(jvar,jk))
719	ENDDO
720
721	!10-4 add some attribute
722	tl_att=att_init("Created_by","SIREN create_boundary")
723	CALL file_add_att(tl_fileout, tl_att)
724
725	cl_date=date_print(date_now())
726	tl_att=att_init("Creation_date",cl_date)
727	CALL file_add_att(tl_fileout, tl_att)
728
729	! add attribute periodicity
730	il_attid=0
731	IF( ASSOCIATED(tl_fileout%t_att) )THEN
732	il_attid=att_get_id(tl_fileout%t_att(:),'periodicity')
733	ENDIF
734	IF( tl_coord1%i_perio >= 0 .AND. il_attid == 0 )THEN
735	tl_att=att_init('periodicity',tl_coord1%i_perio)
736	CALL file_add_att(tl_fileout,tl_att)
737	ENDIF
738
739	il_attid=0
740	IF( ASSOCIATED(tl_fileout%t_att) )THEN
741	il_attid=att_get_id(tl_fileout%t_att(:),'ew_overlap')
742	ENDIF
743	IF( tl_coord1%i_ew >= 0 .AND. il_attid == 0 )THEN
744	tl_att=att_init('ew_overlap',tl_coord1%i_ew)
745	CALL file_add_att(tl_fileout,tl_att)
746	ENDIF
747
748	!10-5 create file
749	CALL iom_create(tl_fileout)
750
751	!10-6 write file
752	CALL iom_write_file(tl_fileout)
753
754	!10-7 close file
755	CALL iom_close(tl_fileout)
756	CALL file_clean(tl_fileout)
757
758	ENDIF
759	ENDDO
760	DEALLOCATE( tl_lon1 )
761	DEALLOCATE( tl_lat1 )
762	DEALLOCATE( tl_var )
763
764	!11- close file
765	CALL iom_close(tl_bathy1)
766	CALL iom_close(tl_coord1)
767	CALL iom_close(tl_coord0)
768
769	!12- clean
770	CALL var_clean(tl_depth)
771	CALL var_clean(tl_time)
772	CALL file_clean(tl_fileout)
773	CALL file_clean(tl_bathy1)
774	CALL file_clean(tl_coord1)
775	CALL file_clean(tl_coord0)
776
777	! close log file
778	CALL logger_footer()
779	CALL logger_close()
780
781	!> @endcode
782	CONTAINS
783	!-------------------------------------------------------------------
784	!> @brief
785	!> This subroutine
786	!>
787	!> @details
788	!>
789	!> @author J.Paul
790	!> - 2013- Initial Version
791	!>
792	!> @param[in]
793	!> @todo
794	!-------------------------------------------------------------------
795	!> @code
796	FUNCTION create_boundary_get_dom( td_bathy1, td_bdy, id_seg )
797
798	IMPLICIT NONE
799
800	! Argument
801	TYPE(TFILE), INTENT(IN ) :: td_bathy1
802	TYPE(TBDY) , INTENT(IN ) :: td_bdy
803	INTEGER(i4), INTENT(IN ) :: id_seg
804
805	! function
806	TYPE(TDOM) :: create_boundary_get_dom
807
808	! local variable
809	INTEGER(i4) :: il_imin1
810	INTEGER(i4) :: il_imax1
811	INTEGER(i4) :: il_jmin1
812	INTEGER(i4) :: il_jmax1
813
814	TYPE(TFILE) :: tl_bathy1
815
816	! loop indices
817	INTEGER(i4) :: jl
818	!----------------------------------------------------------------
819	jl=id_seg
820
821	!1- get boundary definition
822	SELECT CASE(TRIM(td_bdy%c_card))
823	CASE('north')
824
825	il_imin1=td_bdy%t_seg(jl)%i_first
826	il_imax1=td_bdy%t_seg(jl)%i_last
827	il_jmin1=td_bdy%t_seg(jl)%i_index-(td_bdy%t_seg(jl)%i_width-1)
828	il_jmax1=td_bdy%t_seg(jl)%i_index
829
830	CASE('south')
831
832	il_imin1=td_bdy%t_seg(jl)%i_first
833	il_imax1=td_bdy%t_seg(jl)%i_last
834	il_jmin1=td_bdy%t_seg(jl)%i_index
835	il_jmax1=td_bdy%t_seg(jl)%i_index+(td_bdy%t_seg(jl)%i_width-1)
836
837	CASE('east')
838
839	il_imin1=td_bdy%t_seg(jl)%i_index-(td_bdy%t_seg(jl)%i_width-1)
840	il_imax1=td_bdy%t_seg(jl)%i_index
841	il_jmin1=td_bdy%t_seg(jl)%i_first
842	il_jmax1=td_bdy%t_seg(jl)%i_last
843
844	CASE('west')
845
846	il_imin1=td_bdy%t_seg(jl)%i_index
847	il_imax1=td_bdy%t_seg(jl)%i_index+(td_bdy%t_seg(jl)%i_width-1)
848	il_jmin1=td_bdy%t_seg(jl)%i_first
849	il_jmax1=td_bdy%t_seg(jl)%i_last
850
851	END SELECT
852
853	!2 -read fine grid domain
854	tl_bathy1=td_bathy1
855	CALL iom_open(tl_bathy1)
856
857	!2-1 compute domain
858	create_boundary_get_dom=dom_init( tl_bathy1, &
859	& il_imin1, il_imax1,&
860	& il_jmin1, il_jmax1 )
861
862	!2-2 close file
863	CALL iom_close(tl_bathy1)
864
865	END FUNCTION create_boundary_get_dom
866	!> @endcode
867	!-------------------------------------------------------------------
868	!> @brief
869	!> This subroutine
870	!>
871	!> @details
872	!>
873	!> @author J.Paul
874	!> - Nov, 2013- Initial Version
875	!>
876	!> @param[in]
877	!> @todo
878	!-------------------------------------------------------------------
879	!> @code
880	SUBROUTINE create_boundary_get_coord( td_bathy1, td_dom1, &
881	& td_lon1, td_lat1 )
882
883	IMPLICIT NONE
884
885	! Argument
886	TYPE(TFILE), INTENT(IN ) :: td_bathy1
887	TYPE(TDOM) , INTENT(IN ) :: td_dom1
888	TYPE(TVAR) , INTENT( OUT) :: td_lon1
889	TYPE(TVAR) , INTENT( OUT) :: td_lat1
890
891	! local variable
892	TYPE(TFILE) :: tl_bathy1
893
894	TYPE(TMPP) :: tl_mppbathy1
895
896	! loop indices
897	!----------------------------------------------------------------
898	!read variables on domain (ugly way to do it, have to work on it)
899
900	!1 init mpp structure
901	tl_bathy1=td_bathy1
902	tl_mppbathy1=mpp_init(tl_bathy1)
903
904	CALL file_clean(tl_bathy1)
905
906	!2 get processor to be used
907	CALL mpp_get_use( tl_mppbathy1, td_dom1 )
908
909	!3 open mpp files
910	CALL iom_mpp_open(tl_mppbathy1)
911
912	!4 read variable value on domain
913	td_lon1=iom_mpp_read_var(tl_mppbathy1,'longitude',td_dom=td_dom1)
914	td_lat1=iom_mpp_read_var(tl_mppbathy1,'latitude' ,td_dom=td_dom1)
915
916	!5 close mpp files
917	CALL iom_mpp_close(tl_mppbathy1)
918
919	!6 clean structure
920	CALL mpp_clean(tl_mppbathy1)
921
922	END SUBROUTINE create_boundary_get_coord
923	!> @endcode
924	!-------------------------------------------------------------------
925	!> @brief
926	!> This subroutine
927	!>
928	!> @details
929	!>
930	!> @author J.Paul
931	!> - Nov, 2013- Initial Version
932	!>
933	!> @param[in]
934	!> @todo
935	!-------------------------------------------------------------------
936	!> @code
937	SUBROUTINE create_boundary_get_mask( td_level1, td_dom1, &
938	& td_var, td_mask )
939
940	IMPLICIT NONE
941
942	! Argument
943	TYPE(TFILE), INTENT(IN ) :: td_level1
944	TYPE(TDOM) , INTENT(IN ) :: td_dom1
945	TYPE(TVAR) , INTENT(IN ) :: td_var
946	TYPE(TVAR) , INTENT( OUT) :: td_mask
947
948	! local variable
949	TYPE(TFILE) :: tl_level1
950
951	TYPE(TMPP) :: tl_mpplevel1
952
953	! loop indices
954	!----------------------------------------------------------------
955	!read variables on domain (ugly way to do it, have to work on it)
956
957	!1 init mpp structure
958	tl_level1=td_level1
959	tl_mpplevel1=mpp_init(tl_level1)
960
961	CALL file_clean(tl_level1)
962
963	!2 get processor to be used
964	CALL mpp_get_use( tl_mpplevel1, td_dom1 )
965
966	!3 open mpp files
967	CALL iom_mpp_open(tl_mpplevel1)
968
969	!4 read variable value on domain
970	SELECT CASE(TRIM(td_var%c_point))
971	CASE('T')
972	td_mask=iom_mpp_read_var(tl_mpplevel1,'tlevel',td_dom=td_dom1)
973	CASE('U')
974	td_mask=iom_mpp_read_var(tl_mpplevel1,'ulevel',td_dom=td_dom1)
975	CASE('V')
976	td_mask=iom_mpp_read_var(tl_mpplevel1,'vlevel',td_dom=td_dom1)
977	CASE('F')
978	td_mask=iom_mpp_read_var(tl_mpplevel1,'flevel',td_dom=td_dom1)
979	END SELECT
980
981	!5 close mpp files
982	CALL iom_mpp_close(tl_mpplevel1)
983
984	!6 clean structure
985	CALL mpp_clean(tl_mpplevel1)
986
987	END SUBROUTINE create_boundary_get_mask
988	!> @endcode
989	! !-------------------------------------------------------------------
990	! !> @brief
991	! !> This subroutine
992	! !>
993	! !> @details
994	! !>
995	! !> @author J.Paul
996	! !> - Nov, 2013- Initial Version
997	! !>
998	! !> @param[in]
999	! !> @todo
1000	! !-------------------------------------------------------------------
1001	! !> @code
1002	! SUBROUTINE create_boundary_get_var( td_var, td_bdy, &
1003	! & td_coord0, td_dom0, &
1004	! & td_mask, &
1005	! & id_rhoi, id_rhoj )
1006	!
1007	! IMPLICIT NONE
1008	!
1009	! ! Argument
1010	! TYPE(TVAR) , INTENT(INOUT) :: td_var
1011	! TYPE(TBDY) , INTENT(IN ) :: td_bdy
1012	! TYPE(TFILE), INTENT(IN ) :: td_coord0
1013	! TYPE(TDOM) , INTENT(IN ) :: td_dom0
1014	! TYPE(TVAR) , INTENT(IN ) :: td_mask
1015	! INTEGER(I4), INTENT(IN ) :: id_rhoi
1016	! INTEGER(I4), INTENT(IN ) :: id_rhoj
1017	!
1018	! ! local variable
1019	! TYPE(TVAR) :: tl_var0
1020	!
1021	! TYPE(TDOM) :: tl_dom0
1022	!
1023	! TYPE(TFILE) :: tl_file0
1024	!
1025	! TYPE(TMPP) :: tl_mppfile0
1026	!
1027	! ! loop indices
1028	! INTEGER(i4) :: jk
1029	! INTEGER(i4) :: jl
1030	! !----------------------------------------------------------------
1031	!
1032	! CALL logger_debug("CREATE BOUNDARY INTERP: read coarse grid"// TRIM(td_var%c_file) )
1033	! !1- read coarse grid variable on domain
1034	! tl_file0=file_init( TRIM(td_var%c_file) )
1035	!
1036	! !2- init
1037	! tl_dom0=td_dom0
1038	!
1039	! !3- add extra band (if possible) to compute interpolation
1040	! CALL dom_add_extra(tl_dom0)
1041	!
1042	! !4- read variables on domain (ugly way to do it, have to work on it)
1043	! !4-1 init mpp structure
1044	! tl_mppfile0=mpp_init(tl_file0)
1045	!
1046	! CALL file_clean(tl_file0)
1047	!
1048	! !4-2 get processor to be used
1049	! CALL mpp_get_use( tl_mppfile0, tl_dom0 )
1050	!
1051	! !4-3 open mpp files
1052	! CALL iom_mpp_open(tl_mppfile0)
1053	!
1054	! ! check file dimension
1055	! IF( ANY(tl_mppfile0%t_dim(1:2)%i_len /= td_coord0%t_dim(1:2)%i_len) )THEN
1056	! CALL logger_error("CREATE BOUNDARY INTERP: dimension of file "//&
1057	! & TRIM(tl_mppfile0%c_name)//" not conform to those of "//&
1058	! & TRIM(td_coord0%c_name))
1059	! ELSE
1060	!
1061	! !4-4 read variable value on domain
1062	! tl_var0=iom_mpp_read_var( tl_mppfile0, TRIM(td_var%c_name), &
1063	! & td_dom=tl_dom0 )
1064	!
1065	! !5- work on variable
1066	! CALL create_boundary_interp(tl_var0, id_rhoi, id_rhoj )
1067	!
1068	! !6- remove extraband added to domain
1069	! CALL dom_del_extra( tl_var0, tl_dom0, id_rhoi, id_rhoj )
1070	!
1071	! !6-1 remove extraband added to domain
1072	! CALL dom_clean_extra( tl_dom0 )
1073	!
1074	! !7- keep only useful point (width)
1075	! ! interpolation could create more point than necessary
1076	! CALL boundary_clean_interp(tl_var0, td_bdy )
1077	!
1078	! !8- forced min and max value
1079	! CALL var_limit_value(tl_var0)
1080	!
1081	! !9- filter
1082	! CALL filter_fill_value(tl_var0)
1083	!
1084	! td_var=tl_var0
1085	!
1086	! CALL var_clean(tl_var0)
1087	! ENDIF
1088	!
1089	! !4-5 close mpp files
1090	! CALL iom_mpp_close(tl_mppfile0)
1091	!
1092	! !4-6 clean structure
1093	! CALL mpp_clean(tl_mppfile0)
1094	!
1095	! !5- apply mask
1096	! DO jl=1,td_var%t_dim(4)%i_len
1097	! DO jk=1,td_var%t_dim(3)%i_len
1098	! WHERE( td_mask%d_value(:,:,1,1) < jk )
1099	! td_var%d_value(:,:,jk,jl)=td_var%d_fill
1100	! END WHERE
1101	! ENDDO
1102	! ENDDO
1103	!
1104	! END SUBROUTINE create_boundary_get_var
1105	! !> @endcode
1106	!-------------------------------------------------------------------
1107	!> @brief
1108	!> This subroutine
1109	!>
1110	!> @details
1111	!>
1112	!> @author J.Paul
1113	!> - Nov, 2013- Initial Version
1114	!>
1115	!> @param[in]
1116	!> @todo
1117	!-------------------------------------------------------------------
1118	!> @code
1119	SUBROUTINE create_boundary_interp( td_var, &
1120	& id_rho, &
1121	& id_offset, &
1122	& id_iext, id_jext )
1123
1124	IMPLICIT NONE
1125
1126	! Argument
1127	TYPE(TVAR) , INTENT(INOUT) :: td_var
1128	INTEGER(I4), DIMENSION(:) , INTENT(IN ) :: id_rho
1129	INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_offset
1130
1131	INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext
1132	INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext
1133
1134
1135	! local variable
1136	TYPE(TVAR) :: tl_var
1137
1138	INTEGER(i4) :: il_iext
1139	INTEGER(i4) :: il_jext
1140	! loop indices
1141	!----------------------------------------------------------------
1142
1143	! copy variable
1144	tl_var=td_var
1145
1146	!WARNING: at least two extrabands are required for cubic interpolation
1147	il_iext=2
1148	IF( PRESENT(id_iext) ) il_iext=id_iext
1149
1150	il_jext=2
1151	IF( PRESENT(id_jext) ) il_jext=id_jext
1152
1153	IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
1154	CALL logger_warn("CREATE BOUNDARY INTERP: at least extrapolation "//&
1155	& "on two points are required with cubic interpolation ")
1156	il_iext=2
1157	ENDIF
1158
1159	IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
1160	CALL logger_warn("CREATE BOUNDARY INTERP: at least extrapolation "//&
1161	& "on two points are required with cubic interpolation ")
1162	il_jext=2
1163	ENDIF
1164
1165	!2- work on variable
1166	!2-0 add extraband
1167	CALL extrap_add_extrabands(tl_var, il_iext, il_jext)
1168
1169	!2-1 extrapolate variable
1170	CALL extrap_fill_value( tl_var, id_iext=il_iext, id_jext=il_jext )
1171
1172	!2-2 interpolate Bathymetry
1173	CALL interp_fill_value( tl_var, id_rho(:), &
1174	& id_offset=id_offset(:,:) )
1175
1176	!2-3 remove extraband
1177	CALL extrap_del_extrabands(tl_var, il_iextid_rho(jp_I), il_jextid_rho(jp_J))
1178
1179	!3- save result
1180	td_var=tl_var
1181
1182	! clean variable structure
1183	CALL var_clean(tl_var)
1184
1185	END SUBROUTINE create_boundary_interp
1186	!> @endcode
1187	!-------------------------------------------------------------------
1188	!> @brief
1189	!> This function create variable, filled with matrix value
1190	!>
1191	!> @details
1192	!> A variable is create with the same name that the input variable,
1193	!> and with dimension of the coordinate file.
1194	!> Then the variable table of value is split into equal subdomain.
1195	!> Each subdomain is fill with the linked value of the matrix.
1196	!>
1197	!> @author J.Paul
1198	!> - Nov, 2013- Initial Version
1199	!>
1200	!> @param[in] td_var : variable structure
1201	!> @param[in] td_dom : domain structure
1202	!> @param[in] td_coord : coordinate
1203	!> @return variable structure
1204	!-------------------------------------------------------------------
1205	!> @code
1206	FUNCTION create_bdy_matrix(td_var, td_dom, td_coord)
1207	IMPLICIT NONE
1208	! Argument
1209	TYPE(TVAR) , INTENT(IN) :: td_var
1210	TYPE(TDOM) , INTENT(IN) :: td_dom
1211	TYPE(TFILE), INTENT(IN) :: td_coord
1212
1213	! function
1214	TYPE(TVAR) :: create_bdy_matrix
1215
1216	! local variable
1217	INTEGER(i4) :: il_ighost
1218	INTEGER(i4) :: il_jghost
1219	INTEGER(i4) , DIMENSION(2) :: il_xghost
1220	INTEGER(i4) , DIMENSION(3) :: il_dim
1221	INTEGER(i4) , DIMENSION(3) :: il_size
1222	INTEGER(i4) , DIMENSION(3) :: il_rest
1223
1224	INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ishape
1225	INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_jshape
1226	INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_kshape
1227
1228	REAL(dp) , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
1229
1230	TYPE(TVAR) :: tl_lon
1231	TYPE(TVAR) :: tl_lat
1232	TYPE(TVAR) :: tl_var
1233	TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim
1234
1235	! loop indices
1236	INTEGER(i4) :: ji
1237	INTEGER(i4) :: jj
1238	INTEGER(i4) :: jk
1239	!----------------------------------------------------------------
1240
1241	!1- read output grid
1242	tl_lon=iom_read_var(td_coord,'longitude')
1243	tl_lat=iom_read_var(td_coord,'latitude')
1244
1245	!2- look for ghost cell
1246	il_xghost(:)=grid_get_ghost( tl_lon, tl_lat )
1247
1248	il_ighost=il_xghost(1)*ig_ghost
1249	il_jghost=il_xghost(2)*ig_ghost
1250
1251	!3- write value on grid
1252	!3-1 get matrix dimension
1253	il_dim(:)=td_var%t_dim(1:3)%i_len
1254	!3-2 output dimension
1255	tl_dim(:)=tl_lon%t_dim(:)
1256
1257	! remove ghost cell
1258	tl_dim(1)%i_len=tl_dim(1)%i_len - 2il_xghost(1)ig_ghost
1259	tl_dim(2)%i_len=tl_dim(2)%i_len - 2il_xghost(2)ig_ghost
1260
1261	!3-3 split output domain in N subdomain depending of matrix dimension
1262	il_size(:) = tl_dim(1:3)%i_len / il_dim(:)
1263	il_rest(:) = MOD(tl_dim(1:3)%i_len, il_dim(:))
1264
1265	ALLOCATE( il_ishape(il_dim(1)+1) )
1266	il_ishape(:)=0
1267	DO ji=2,il_dim(1)+1
1268	il_ishape(ji)=il_ishape(ji-1)+il_size(1)
1269	ENDDO
1270	! add rest to last cell
1271	il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1)
1272
1273
1274	ALLOCATE( il_jshape(il_dim(2)+1) )
1275	il_jshape(:)=0
1276	DO jj=2,il_dim(2)+1
1277	il_jshape(jj)=il_jshape(jj-1)+il_size(2)
1278	ENDDO
1279	! add rest to last cell
1280	il_jshape(il_dim(2)+1)=il_jshape(il_dim(2)+1)+il_rest(2)
1281
1282	ALLOCATE( il_kshape(il_dim(3)+1) )
1283	il_kshape(:)=0
1284	DO jk=2,il_dim(3)+1
1285	il_kshape(jk)=il_kshape(jk-1)+il_size(3)
1286	ENDDO
1287	! add rest to last cell
1288	il_kshape(il_dim(3)+1)=il_kshape(il_dim(3)+1)+il_rest(3)
1289
1290	!3-3 write ouput table of value
1291	ALLOCATE(dl_value( tl_dim(1)%i_len, &
1292	& tl_dim(2)%i_len, &
1293	& tl_dim(3)%i_len, &
1294	& tl_dim(4)%i_len) )
1295
1296	dl_value(:,:,:,:)=0
1297
1298	DO jk=2,il_dim(3)+1
1299	DO jj=2,il_dim(2)+1
1300	DO ji=2,il_dim(1)+1
1301
1302	dl_value( 1+il_ishape(ji-1):il_ishape(ji), &
1303	& 1+il_jshape(jj-1):il_jshape(jj), &
1304	& 1+il_kshape(jk-1):il_kshape(jk), &
1305	& 1 ) = td_var%d_value(ji-1,jj-1,jk-1,1)
1306
1307	ENDDO
1308	ENDDO
1309	ENDDO
1310
1311	!3-4 initialise variable with value
1312	tl_var=var_init(TRIM(td_var%c_name),dl_value(:,:,:,:))
1313
1314	DEALLOCATE(dl_value)
1315
1316	!4- add ghost cell
1317	CALL grid_add_ghost(tl_var,il_ighost,il_jghost)
1318
1319	!5- save result
1320	create_bdy_matrix=tl_var
1321
1322	END FUNCTION create_bdy_matrix
1323	!> @endcode
1324	!-------------------------------------------------------------------
1325	!> @brief
1326	!> This subroutine
1327	!>
1328	!> @details
1329	!>
1330	!> @author J.Paul
1331	!> - Nov, 2013- Initial Version
1332	!>
1333	!> @param[in]
1334	!> @todo
1335	!-------------------------------------------------------------------
1336	!> @code
1337	SUBROUTINE create_bdy_use_mask( td_var, td_mask )
1338
1339	IMPLICIT NONE
1340
1341	! Argument
1342	TYPE(TVAR) , INTENT(INOUT) :: td_var
1343	TYPE(TVAR), DIMENSION(:), INTENT(IN ) :: td_mask
1344
1345	! local variable
1346	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask
1347
1348	! loop indices
1349	INTEGER(i4) :: jk
1350	INTEGER(i4) :: jl
1351	!----------------------------------------------------------------
1352
1353	ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
1354	& td_var%t_dim(2)%i_len) )
1355
1356	SELECT CASE(TRIM(td_var%c_point))
1357	CASE('T')
1358	il_mask(:,:)=INT(td_mask(jp_T)%d_value(:,:,1,1))
1359	CASE('U')
1360	il_mask(:,:)=INT(td_mask(jp_U)%d_value(:,:,1,1))
1361	CASE('V')
1362	il_mask(:,:)=INT(td_mask(jp_V)%d_value(:,:,1,1))
1363	CASE('F')
1364	il_mask(:,:)=INT(td_mask(jp_F)%d_value(:,:,1,1))
1365	END SELECT
1366
1367	DO jl=1,td_var%t_dim(4)%i_len
1368	DO jk=1,td_var%t_dim(3)%i_len
1369	WHERE( il_mask(:,:) < jk ) td_var%d_value(:,:,jk,jl)=td_var%d_fill
1370	ENDDO
1371	ENDDO
1372
1373	DEALLOCATE( il_mask )
1374	END SUBROUTINE create_bdy_use_mask
1375	!> @endcode
1376	!-------------------------------------------------------------------
1377	!> @brief
1378	!>
1379	!> @details
1380	!>
1381	!> @author J.Paul
1382	!> - 2013- Initial Version
1383	!>
1384	!-------------------------------------------------------------------
1385	!> @code
1386	FUNCTION create_bdy_get_level(td_level, td_dom)
1387	IMPLICIT NONE
1388	! Argument
1389	TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_level
1390	TYPE(TDOM) , INTENT(IN) :: td_dom
1391
1392	! function
1393	TYPE(TVAR), DIMENSION(ig_npoint) :: create_bdy_get_level
1394
1395	! local variable
1396	TYPE(TVAR), DIMENSION(ig_npoint) :: tl_var
1397
1398	! loop indices
1399	INTEGER(i4) :: ji
1400	!----------------------------------------------------------------
1401
1402	IF( SIZE(td_level(:)) /= ig_npoint )THEN
1403	CALL logger_error("CREATE BDY GET LEVEL: invalid dimension. "//&
1404	& "check input table of level.")
1405	ELSE
1406
1407	!tl_var(1:ig_npoint)=td_level(1:ig_npoint)
1408	create_bdy_get_level(:)=tl_var(:)
1409	DO ji=1,ig_npoint
1410
1411	tl_var(ji)=td_level(ji)
1412
1413	IF( ASSOCIATED(tl_var(ji)%d_value) ) DEALLOCATE( tl_var(ji)%d_value )
1414
1415	tl_var(ji)%t_dim(1)%i_len=td_dom%t_dim(1)%i_len
1416	tl_var(ji)%t_dim(2)%i_len=td_dom%t_dim(2)%i_len
1417	ALLOCATE(tl_var(ji)%d_value(tl_var(ji)%t_dim(1)%i_len, &
1418	& tl_var(ji)%t_dim(2)%i_len, &
1419	& tl_var(ji)%t_dim(3)%i_len, &
1420	& tl_var(ji)%t_dim(4)%i_len) )
1421
1422	tl_var(ji)%d_value(:,:,:,:) = &
1423	& td_level(ji)%d_value( td_dom%i_imin:td_dom%i_imax, &
1424	& td_dom%i_jmin:td_dom%i_jmax, :, : )
1425
1426	ENDDO
1427	!4 save result
1428	create_bdy_get_level(:)=tl_var(:)
1429
1430	ENDIF
1431	END FUNCTION create_bdy_get_level
1432	!> @endcode
1433	END PROGRAM create_boundary

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

Download in other formats: