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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
create_restart.f90 in branches/UKMO/dev_r5518_25hr_mean_assim_bkg/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/UKMO/dev_r5518_25hr_mean_assim_bkg/NEMOGCM/TOOLS/SIREN/src/create_restart.f90 @ 6758

Last change on this file since 6758 was 6758, checked in by kingr, 8 years ago

Merged branches/UKMO/nemo_v3_6_STABLE_copy@6237

File size: 42.0 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5!
6! PROGRAM: create_restart
7!
8! DESCRIPTION:
9!> @file
10!> @brief
11!> This program create restart file.
12!>
13!> @details
14!> @section sec1 method
15!> Variables could be extracted from fine grid file, interpolated from coarse
16!> grid file or restart file, or manually written.<br/>
17!> Then they are split over new decomposition.
18!> @note
19!>    method could be different for each variable.
20!>
21!> @section sec2 how to
22!>    to create restart file:<br/>
23!> @code{.sh}
24!>    ./SIREN/bin/create_restart create_restart.nam
25!> @endcode
26!>   
27!> @note
28!>    you could find a template of the namelist in templates directory.
29!>
30!>    create_restart.nam comprise 9 namelists:<br/>
31!>       - logger namelist (namlog)
32!>       - config namelist (namcfg)
33!>       - coarse grid namelist (namcrs)
34!>       - fine grid namelist (namfin)
35!>       - vertical grid namelist (namzgr)
36!>       - partial step namelist (namzps)
37!>       - variable namelist (namvar)
38!>       - nesting namelist (namnst)
39!>       - output namelist (namout)
40!>   
41!>    @note
42!>       All namelists have to be in file create_restart.nam
43!>       however variables of those namelists are all optional.
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!>
55!>    * _coarse grid namelist (namcrs):<br/>
56!>       - cn_coord0 : coordinate file
57!>       - in_perio0 : NEMO periodicity index (see Model Boundary Condition in
58!> [NEMO documentation](http://www.nemo-ocean.eu/About-NEMO/Reference-manuals))
59!>
60!>    * _fine grid namelist (namfin)_:<br/>
61!>       - cn_coord1 : coordinate file
62!>       - cn_bathy1 : bathymetry file
63!>       - in_perio1 : NEMO periodicity index
64!>
65!>    * _vertical grid namelist (namzgr)_:<br/>
66!>       - dn_pp_to_be_computed  :
67!>       - dn_ppsur              :
68!>       - dn_ppa0               :
69!>       - dn_ppa1               :
70!>       - dn_ppa2               :
71!>       - dn_ppkth              :
72!>       - dn_ppkth2             :
73!>       - dn_ppacr              :
74!>       - dn_ppacr2             :
75!>       - dn_ppdzmin            :
76!>       - dn_pphmax             :
77!>       - in_nlevel             : number of vertical level
78!>
79!>    * _partial step namelist (namzps)_:<br/>
80!>       - dn_e3zps_min          :
81!>       - dn_e3zps_rat          :
82!>
83!>    * _variable namelist (namvar)_:<br/>
84!>       - cn_varinfo : list of variable and extra information about request(s)
85!>       to be used.<br/>
86!>          each elements of *cn_varinfo* is a string character
87!>          (separated by ',').<br/>
88!>          it is composed of the variable name follow by ':',
89!>          then request(s) to be used on this variable.<br/>
90!>          request could be:
91!>             - int = interpolation method
92!>             - ext = extrapolation method
93!>             - flt = filter method
94!>             - min = minimum value
95!>             - max = maximum value
96!>             - unt = new units
97!>             - unf = unit scale factor (linked to new units)
98!>
99!>             requests must be separated by ';'.<br/>
100!>             order of requests does not matter.<br/>
101!>
102!>          informations about available method could be find in @ref interp,
103!>          @ref extrap and @ref filter.<br/>
104!>          Example: 'votemper: int=linear; flt=hann; ext=dist_weight','vosaline: int=cubic'
105!>          @note
106!>             If you do not specify a method which is required,
107!>             default one is apply.
108!>       - cn_varfile : list of variable, and corresponding file<br/>
109!>          *cn_varfile* is the path and filename of the file where find
110!>          variable.<br/>
111!>          @note
112!>             *cn_varfile* could be a matrix of value, if you want to filled
113!>             manually variable value.<br/>
114!>             the variable array of value is split into equal subdomain.<br/>
115!>             Each subdomain is filled with the corresponding value
116!>             of the matrix.<br/>         
117!>             separators used to defined matrix are:
118!>                - ',' for line
119!>                - '/' for row
120!>                - '\' for level<br/>
121!>                Example:<br/>
122!>                   3,2,3/1,4,5  =>  @f$ \left( \begin{array}{ccc}
123!>                                         3 & 2 & 3 \\
124!>                                         1 & 4 & 5 \end{array} \right) @f$
125!>
126!>          Examples:
127!>             - 'votemper:gridT.nc', 'vozocrtx:gridU.nc'
128!>             - 'votemper:10\25', 'vozocrtx:gridU.nc'
129!>
130!>             to get all variable from one file:
131!>             - 'all:restart.dimg'
132!>
133!>    * _nesting namelist (namnst)_:<br/>
134!>       - in_rhoi  : refinement factor in i-direction
135!>       - in_rhoj  : refinement factor in j-direction
136!>       @note
137!>          coarse grid indices will be deduced from fine grid
138!>          coordinate file.
139!>
140!>    * _output namelist (namout)_:<br/>
141!>       - cn_fileout : output file
142!>       - ln_extrap : extrapolate land point or not
143!>       - in_niproc : i-direction number of processor
144!>       - in_njproc : j-direction numebr of processor
145!>       - in_nproc  : total number of processor to be used
146!>       - cn_type   : output format ('dimg', 'cdf')
147!>
148!> @author J.Paul
149! REVISION HISTORY:
150!> @date November, 2013 - Initial Version
151!> @date September, 2014
152!> - add header for user
153!> - offset computed considering grid point
154!> - add attributes in output variable
155!> @date June, 2015
156!> - extrapolate all land points, and add ln_extrap in namelist.
157!> - allow to change unit.
158!>
159!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
160!----------------------------------------------------------------------
161PROGRAM create_restart
162
163   USE global                          ! global variable
164   USE kind                            ! F90 kind parameter
165   USE logger                          ! log file manager
166   USE fct                             ! basic useful function
167   USE date                            ! date manager
168   USE att                             ! attribute manager
169   USE dim                             ! dimension manager
170   USE var                             ! variable manager
171   USE file                            ! file manager
172   USE multi                           ! multi file manager
173   USE iom                             ! I/O manager
174   USE grid                            ! grid manager
175   USE vgrid                            ! vertical grid manager
176   USE extrap                          ! extrapolation manager
177   USE interp                          ! interpolation manager
178   USE filter                          ! filter manager
179   USE mpp                             ! MPP manager
180   USE dom                             ! domain manager
181   USE iom_mpp                         ! MPP I/O manager
182   USE iom_dom                         ! DOM I/O manager
183
184   IMPLICIT NONE
185
186
187   ! local variable
188   CHARACTER(LEN=lc)                                  :: cl_namelist
189   CHARACTER(LEN=lc)                                  :: cl_date
190   CHARACTER(LEN=lc)                                  :: cl_name
191   CHARACTER(LEN=lc)                                  :: cl_data
192   CHARACTER(LEN=lc)                                  :: cl_fileout 
193
194   INTEGER(i4)                                        :: il_narg
195   INTEGER(i4)                                        :: il_status
196   INTEGER(i4)                                        :: il_fileid
197   INTEGER(i4)                                        :: il_nvar
198   INTEGER(i4)                                        :: il_attid
199   INTEGER(i4)                                        :: il_imin1
200   INTEGER(i4)                                        :: il_imax1
201   INTEGER(i4)                                        :: il_jmin1
202   INTEGER(i4)                                        :: il_jmax1
203   INTEGER(i4)                                        :: il_imin0
204   INTEGER(i4)                                        :: il_imax0
205   INTEGER(i4)                                        :: il_jmin0
206   INTEGER(i4)                                        :: il_jmax0
207   INTEGER(i4)                                        :: il_index
208   INTEGER(i4)      , DIMENSION(ip_maxdim)            :: il_rho
209   INTEGER(i4)      , DIMENSION(2,2)                  :: il_xghost
210   INTEGER(i4)      , DIMENSION(2,2)                  :: il_offset
211   INTEGER(i4)      , DIMENSION(2,2)                  :: il_ind
212
213   LOGICAL                                            :: ll_exist
214
215   TYPE(TDOM)                                         :: tl_dom1
216   TYPE(TDOM)                                         :: tl_dom0
217
218   TYPE(TATT)                                         :: tl_att
219   
220   TYPE(TVAR)                                         :: tl_depth
221   TYPE(TVAR)                                         :: tl_time
222   TYPE(TVAR)                                         :: tl_lon
223   TYPE(TVAR)                                         :: tl_lat
224   TYPE(TVAR)       , DIMENSION(:)      , ALLOCATABLE :: tl_var
225   TYPE(TVAR)       , DIMENSION(:)      , ALLOCATABLE :: tl_level
226   
227   TYPE(TDIM)       , DIMENSION(ip_maxdim)            :: tl_dim
228
229   TYPE(TMPP)                                         :: tl_coord0
230   TYPE(TMPP)                                         :: tl_coord1
231   TYPE(TMPP)                                         :: tl_bathy1
232   TYPE(TMPP)                                         :: tl_mpp
233   TYPE(TMPP)                                         :: tl_mppout
234
235   TYPE(TMULTI)                                       :: tl_multi
236
237   ! loop indices
238   INTEGER(i4) :: ji
239   INTEGER(i4) :: jj
240   INTEGER(i4) :: jvar
241
242   ! namelist variable
243   ! namlog
244   CHARACTER(LEN=lc) :: cn_logfile = 'create_restart.log' 
245   CHARACTER(LEN=lc) :: cn_verbosity = 'warning' 
246   INTEGER(i4)       :: in_maxerror = 5
247
248   ! namcfg
249   CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 
250
251   ! namcrs
252   CHARACTER(LEN=lc) :: cn_coord0 = '' 
253   INTEGER(i4)       :: in_perio0 = -1
254
255   ! namfin
256   CHARACTER(LEN=lc) :: cn_coord1 = ''
257   CHARACTER(LEN=lc) :: cn_bathy1 = ''
258   INTEGER(i4)       :: in_perio1 = -1
259
260   !namzgr
261   REAL(dp)          :: dn_pp_to_be_computed = 0._dp
262   REAL(dp)          :: dn_ppsur     = -3958.951371276829_dp
263   REAL(dp)          :: dn_ppa0      =   103.9530096000000_dp
264   REAL(dp)          :: dn_ppa1      =     2.4159512690000_dp
265   REAL(dp)          :: dn_ppa2      =   100.7609285000000_dp
266   REAL(dp)          :: dn_ppkth     =    15.3510137000000_dp
267   REAL(dp)          :: dn_ppkth2    =    48.0298937200000_dp
268   REAL(dp)          :: dn_ppacr     =     7.0000000000000_dp
269   REAL(dp)          :: dn_ppacr2    =    13.000000000000_dp
270   REAL(dp)          :: dn_ppdzmin   = 6._dp
271   REAL(dp)          :: dn_pphmax    = 5750._dp
272   INTEGER(i4)       :: in_nlevel    = 75
273
274   !namzps
275   REAL(dp)          :: dn_e3zps_min = 25._dp
276   REAL(dp)          :: dn_e3zps_rat = 0.2_dp
277
278   ! namvar
279   CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''
280   CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''
281
282   ! namnst
283   INTEGER(i4)       :: in_rhoi = 0
284   INTEGER(i4)       :: in_rhoj = 0
285
286   ! namout
287   CHARACTER(LEN=lc) :: cn_fileout = 'restart.nc' 
288   LOGICAL           :: ln_extrap  = .FALSE.
289   INTEGER(i4)       :: in_nproc   = 0
290   INTEGER(i4)       :: in_niproc  = 0
291   INTEGER(i4)       :: in_njproc  = 0
292   CHARACTER(LEN=lc) :: cn_type    = ''
293
294   !-------------------------------------------------------------------
295
296   NAMELIST /namlog/ &  !< logger namelist
297   &  cn_logfile,    &  !< log file
298   &  cn_verbosity,  &  !< log verbosity
299   &  in_maxerror       !< logger maximum error
300
301   NAMELIST /namcfg/ &  !< configuration namelist
302   &  cn_varcfg         !< variable configuration file
303
304   NAMELIST /namcrs/ &  !< coarse grid namelist
305   &  cn_coord0,  &     !< coordinate file
306   &  in_perio0         !< periodicity index
307   
308   NAMELIST /namfin/ &  !< fine grid namelist
309   &  cn_coord1,   &    !< coordinate file
310   &  cn_bathy1,   &    !< bathymetry file
311   &  in_perio1         !< periodicity index
312 
313   NAMELIST /namzgr/ &
314   &  dn_pp_to_be_computed, &
315   &  dn_ppsur,     &
316   &  dn_ppa0,      &
317   &  dn_ppa1,      &
318   &  dn_ppa2,      &
319   &  dn_ppkth,     &
320   &  dn_ppkth2,    &
321   &  dn_ppacr,     &
322   &  dn_ppacr2,    &
323   &  dn_ppdzmin,   &
324   &  dn_pphmax,    &
325   &  in_nlevel         !< number of vertical level
326
327   NAMELIST /namzps/ &
328   &  dn_e3zps_min, &
329   &  dn_e3zps_rat
330
331   NAMELIST /namvar/ &  !< variable namelist
332   &  cn_varinfo, &     !< list of variable and interpolation method to be used.
333   &  cn_varfile        !< list of variable file
334   
335   NAMELIST /namnst/ &  !< nesting namelist
336   &  in_rhoi,    &     !< refinement factor in i-direction
337   &  in_rhoj           !< refinement factor in j-direction
338
339   NAMELIST /namout/ &  !< output namlist
340   &  cn_fileout, &     !< fine grid bathymetry file
341   &  ln_extrap,  &     !< extrapolate or not
342   &  in_niproc,  &     !< i-direction number of processor
343   &  in_njproc,  &     !< j-direction numebr of processor
344   &  in_nproc,   &     !< number of processor to be used
345   &  cn_type           !< output type format (dimg, cdf)
346   !-------------------------------------------------------------------
347
348   ! namelist
349   ! get namelist
350   il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
351   IF( il_narg/=1 )THEN
352      PRINT *,"ERROR in create_restart: need a namelist"
353      STOP
354   ELSE
355      CALL GET_COMMAND_ARGUMENT(1,cl_namelist) !f03 intrinsec
356   ENDIF
357
358   ! read namelist
359   INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist)
360   IF( ll_exist )THEN
361     
362      il_fileid=fct_getunit()
363
364      OPEN( il_fileid, FILE=TRIM(cl_namelist), &
365      &                FORM='FORMATTED',       &
366      &                ACCESS='SEQUENTIAL',    &
367      &                STATUS='OLD',           &
368      &                ACTION='READ',          &
369      &                IOSTAT=il_status)
370      CALL fct_err(il_status)
371      IF( il_status /= 0 )THEN
372         PRINT *,"ERROR in create_restart: error opening "//TRIM(cl_namelist)
373         STOP
374      ENDIF
375
376      READ( il_fileid, NML = namlog )
377      ! define log file
378      CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror)
379      CALL logger_header()
380
381      READ( il_fileid, NML = namcfg )
382      ! get variable extra information
383      CALL var_def_extra(TRIM(cn_varcfg))
384
385      READ( il_fileid, NML = namcrs )
386      READ( il_fileid, NML = namfin )
387      READ( il_fileid, NML = namzgr )
388      READ( il_fileid, NML = namvar )
389      ! add user change in extra information
390      CALL var_chg_extra(cn_varinfo)
391      ! match variable with file
392      tl_multi=multi_init(cn_varfile)
393     
394      READ( il_fileid, NML = namnst )
395      READ( il_fileid, NML = namout )
396
397      CLOSE( il_fileid, IOSTAT=il_status )
398      CALL fct_err(il_status)
399      IF( il_status /= 0 )THEN
400         CALL logger_error("CREATE RESTART: closing "//TRIM(cl_namelist))
401      ENDIF
402
403   ELSE
404
405      PRINT *,"ERROR in create_restart: can't find "//TRIM(cl_namelist)
406      STOP
407
408   ENDIF
409
410   !
411   CALL multi_print(tl_multi)
412   IF( tl_multi%i_nvar <= 0 )THEN
413      CALL logger_fatal("CREATE RESTART: no variable to be used."//&
414      &  " check namelist.")
415   ENDIF
416
417   ! open files
418   IF( cn_coord0 /= '' )THEN
419      tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0)
420      CALL grid_get_info(tl_coord0)
421   ELSE
422      CALL logger_fatal("CREATE RESTART: no coarse grid coordinate found. "//&
423      &     "check namelist")     
424   ENDIF
425
426   IF( TRIM(cn_coord1) /= '' )THEN
427      tl_coord1=mpp_init( file_init(TRIM(cn_coord1)), id_perio=in_perio1)
428      CALL grid_get_info(tl_coord1)
429   ELSE
430      CALL logger_fatal("CREATE RESTART: no fine grid coordinate found. "//&
431      &     "check namelist")
432   ENDIF
433
434   IF( TRIM(cn_bathy1) /= '' )THEN
435      tl_bathy1=mpp_init( file_init(TRIM(cn_bathy1)), id_perio=in_perio1)
436      CALL grid_get_info(tl_bathy1)
437   ELSE
438      CALL logger_fatal("CREATE RESTART: no fine grid bathymetry found. "//&
439      &     "check namelist")
440   ENDIF
441
442   ! check
443   ! check output file do not already exist
444   IF( in_nproc > 0 )THEN
445      cl_fileout=file_rename(cn_fileout,1)
446   ELSE
447      cl_fileout=file_rename(cn_fileout)
448   ENDIF
449   INQUIRE(FILE=TRIM(cl_fileout), EXIST=ll_exist)
450   IF( ll_exist )THEN
451      CALL logger_fatal("CREATE RESTART: output file "//TRIM(cl_fileout)//&
452      &  " already exist.")
453   ENDIF
454
455   ! check refinement factor
456   il_rho(:)=1
457   IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN
458      CALL logger_error("CREATE RESTART: invalid refinement factor."//&
459      &  " check namelist "//TRIM(cl_namelist))
460   ELSE
461      il_rho(jp_I)=in_rhoi
462      il_rho(jp_J)=in_rhoj
463   ENDIF
464
465   ! check domain indices
466   ! compute coarse grid indices around fine grid
467   il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1, &
468   &                                 id_rho=il_rho(:))
469
470   il_imin0=il_ind(1,1) ; il_imax0=il_ind(1,2)
471   il_jmin0=il_ind(2,1) ; il_jmax0=il_ind(2,2)
472
473   ! check domain validity
474   CALL grid_check_dom(tl_coord0, il_imin0, il_imax0, il_jmin0, il_jmax0)
475
476   !3-2-4 check coincidence between coarse and fine grid
477   CALL grid_check_coincidence( tl_coord0, tl_coord1, &
478   &                            il_imin0, il_imax0, &
479   &                            il_jmin0, il_jmax0, &
480   &                            il_rho(:) )
481
482   ! fine grid ghost cell
483   il_xghost(:,:)=grid_get_ghost(tl_bathy1)
484
485   ! work on variables
486   IF( .NOT. ASSOCIATED(tl_multi%t_mpp) )THEN
487      CALL logger_error("CREATE RESTART: no file to work on. "//&
488      &                 "check cn_varfile in namelist.")
489   ELSE
490      ALLOCATE( tl_var( tl_multi%i_nvar ) )
491
492      jvar=0
493      ! for each file
494      DO ji=1,tl_multi%i_nmpp
495         WRITE(cl_data,'(a,i2.2)') 'data-',jvar+1
496
497         IF( .NOT. ASSOCIATED(tl_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
498
499            CALL logger_error("CREATE RESTART: no variable to work on for "//&
500            &                 "mpp "//TRIM(tl_multi%t_mpp(ji)%c_name)//&
501            &                 ". check cn_varfile in namelist.")
502
503         ELSEIF( TRIM(tl_multi%t_mpp(ji)%c_name) == TRIM(cl_data) )THEN
504         !- use input matrix to fill variable
505
506            WRITE(*,'(a)') "work on data"
507            ! for each variable initialise from matrix
508            DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
509
510               jvar=jvar+1
511               
512               WRITE(*,'(2x,a,a)') "work on variable "//&
513               &  TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
514
515               ! fill value with matrix data
516               tl_var(jvar) = create_restart_matrix( &
517               &  tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj), tl_coord1, &
518               &  in_nlevel, il_xghost(:,:) )
519
520               ! add ghost cell
521               CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:))
522
523            ENDDO
524         !- end of use input matrix to fill variable
525         ELSE
526         !- use mpp file to fill variable
527
528            WRITE(*,'(a)') "work on file "//TRIM(tl_multi%t_mpp(ji)%c_name)
529            !
530            tl_mpp=mpp_init( file_init(TRIM(tl_multi%t_mpp(ji)%t_proc(1)%c_name)) )
531            CALL grid_get_info(tl_mpp)
532
533            ! check vertical dimension
534            IF( tl_mpp%t_dim(jp_K)%l_use .AND. &
535            &   tl_mpp%t_dim(jp_K)%i_len /= in_nlevel  )THEN
536               CALL logger_error("CREATE RESTART: dimension in file "//&
537               &  TRIM(tl_mpp%c_name)//" not agree with namelist in_nlevel ")
538            ENDIF
539
540            ! open mpp file
541            CALL iom_mpp_open(tl_mpp)
542
543
544            ! get or check depth value
545            CALL create_restart_check_depth( tl_mpp, tl_depth )
546
547            ! get or check time value
548            CALL create_restart_check_time( tl_mpp, tl_time )
549
550            ! close mpp file
551            CALL iom_mpp_close(tl_mpp)
552
553            IF( ANY( tl_mpp%t_dim(1:2)%i_len /= &
554            &        tl_coord0%t_dim(1:2)%i_len) )THEN
555            !!! extract value from fine grid
556
557               IF( ANY( tl_mpp%t_dim(1:2)%i_len <= &
558               &        tl_coord1%t_dim(1:2)%i_len) )THEN
559                  CALL logger_fatal("CREATE RESTART: dimension in file "//&
560                  &  TRIM(tl_mpp%c_name)//" smaller than those in fine"//&
561                  &  " grid coordinates.")
562               ENDIF
563
564               ! compute domain on fine grid
565               il_ind(:,:)=grid_get_coarse_index(tl_mpp, tl_coord1 )
566
567               il_imin1=il_ind(1,1) ; il_imax1=il_ind(1,2)
568               il_jmin1=il_ind(2,1) ; il_jmax1=il_ind(2,2)
569
570               !- check grid coincidence
571               CALL grid_check_coincidence( tl_mpp, tl_coord1, &
572               &                            il_imin1, il_imax1, &
573               &                            il_jmin1, il_jmax1, &
574               &                            il_rho(:) )
575
576               ! compute domain
577               tl_dom1=dom_init(tl_mpp,         &
578               &                il_imin1, il_imax1, &
579               &                il_jmin1, il_jmax1)
580               
581               ! open mpp files
582               CALL iom_dom_open(tl_mpp, tl_dom1)
583
584               ! for each variable of this file
585               DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
586
587                  WRITE(*,'(2x,a,a)') "work on (extract) variable "//&
588                  &  TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
589
590                  jvar=jvar+1
591                  cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name
592                  ! read variable over domain
593                  tl_var(jvar)=iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom1)
594
595                  ! add attribute to variable
596                  tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
597                  CALL var_move_att(tl_var(jvar), tl_att)
598
599                  tl_att=att_init('src_i_indices',(/il_imin0, il_imax0/))
600                  CALL var_move_att(tl_var(jvar), tl_att)
601
602                  tl_att=att_init('src_j_indices',(/il_jmin0, il_jmax0/))
603                  CALL var_move_att(tl_var(jvar), tl_att)
604
605                  ! clean structure
606                  CALL att_clean(tl_att)
607
608                  ! add ghost cell
609                  CALL grid_add_ghost(tl_var(jvar), tl_dom1%i_ghost(:,:))
610
611               ENDDO
612
613               ! close mpp file
614               CALL iom_dom_close(tl_mpp)
615
616               ! clean structure
617               CALL mpp_clean(tl_mpp)
618               CALL dom_clean(tl_dom1)
619
620            ELSE
621            !!! get value from coarse grid
622
623               ! compute domain on coarse grid
624               tl_dom0=dom_init(tl_mpp,             &
625               &                il_imin0, il_imax0, &
626               &                il_jmin0, il_jmax0 )
627
628               ! add extra band (if possible) to compute interpolation
629               CALL dom_add_extra(tl_dom0)
630
631               ! open mpp files
632               CALL iom_dom_open(tl_mpp, tl_dom0)
633               ! for each variable of this file
634               DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar
635
636                  WRITE(*,'(2x,a,a)') "work on (interp) variable "//&
637                  &  TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
638
639                  jvar=jvar+1
640                  cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name
641
642                  ! read variable over domain
643                  tl_var(jvar)=iom_dom_read_var(tl_mpp, TRIM(cl_name), tl_dom0)
644
645                  il_offset(:,:)=grid_get_fine_offset(tl_coord0, &
646                  &                                   il_imin0, il_jmin0, &
647                  &                                   il_imax0, il_jmax0, &
648                  &                                   tl_coord1, &
649                  &                                   id_rho=il_rho(:), &
650                  &                                   cd_point=TRIM(tl_var(jvar)%c_point))
651
652                  ! interpolate variable
653                  CALL create_restart_interp(tl_var(jvar), & 
654                  &                          il_rho(:), &
655                  &                          id_offset=il_offset(:,:))
656
657                  ! remove extraband added to domain
658                  CALL dom_del_extra( tl_var(jvar), tl_dom0, il_rho(:) )
659
660                  ! add attribute to variable
661                  tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name)))
662                  CALL var_move_att(tl_var(jvar), tl_att)
663
664                  tl_att=att_init('src_i-indices',(/il_imin0, il_imax0/))
665                  CALL var_move_att(tl_var(jvar), tl_att)
666
667                  tl_att=att_init('src_j-indices',(/il_jmin0, il_jmax0/))
668                  CALL var_move_att(tl_var(jvar), tl_att)
669
670                  IF( ANY(il_rho(:)/=1) )THEN
671                     tl_att=att_init("refinment_factor", &
672                     &               (/il_rho(jp_I),il_rho(jp_J)/))
673                     CALL var_move_att(tl_var(jvar), tl_att)
674                  ENDIF
675
676                  ! clean structure
677                  CALL att_clean(tl_att)
678
679                  ! add ghost cell
680                  CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:))
681               ENDDO
682
683               ! close mpp file
684               CALL iom_dom_close(tl_mpp)
685
686               ! clean structure
687               CALL mpp_clean(tl_mpp)
688               CALL dom_clean(tl_dom0)
689
690            ENDIF
691
692            ! clean structure
693            CALL mpp_clean(tl_mpp)
694         ENDIF
695      ENDDO
696   ENDIF
697
698   il_nvar=tl_multi%i_nvar
699
700   ! clean
701   CALL multi_clean(tl_multi)
702   CALL mpp_clean(tl_coord0)
703
704   IF( .NOT. ln_extrap )THEN
705      ! compute level
706      ALLOCATE(tl_level(ip_npoint))
707      tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist )
708   ENDIF
709
710   ! clean
711   CALL mpp_clean(tl_bathy1)
712
713   ! use additional request
714   DO jvar=1,il_nvar
715
716      ! change unit and apply factor
717      CALL var_chg_unit(tl_var(jvar))
718
719      ! forced min and max value
720      CALL var_limit_value(tl_var(jvar))
721
722      ! filter
723      CALL filter_fill_value(tl_var(jvar))
724
725      IF( .NOT. ln_extrap )THEN
726         ! use mask
727         CALL create_restart_mask(tl_var(jvar), tl_level(:))
728      ENDIF
729
730   ENDDO
731
732   ! create file
733   IF( in_niproc == 0 .AND. &
734   &   in_njproc == 0 .AND. &
735   &   in_nproc == 0 )THEN
736      in_niproc = 1
737      in_njproc = 1
738      in_nproc = 1
739   ENDIF
740
741   ! add dimension
742   tl_dim(:)=var_max_dim(tl_var(:))
743
744   DO ji=1,il_nvar
745
746      IF( ALL(tl_var(ji)%t_dim(:)%i_len == tl_dim(:)%i_len) )THEN
747         tl_mppout=mpp_init( TRIM(cn_fileout), tl_var(ji), &
748         &                   in_niproc, in_njproc, in_nproc, &
749         &                   cd_type=cn_type)
750         EXIT
751      ENDIF
752
753   ENDDO
754
755   DO ji=1,ip_maxdim
756      IF( tl_dim(ji)%l_use )THEN
757         CALL mpp_move_dim(tl_mppout, tl_dim(ji))
758         SELECT CASE(TRIM(tl_dim(ji)%c_sname))
759         CASE('z','t')
760            DO jj=1,tl_mppout%i_nproc
761               CALL file_add_dim(tl_mppout%t_proc(jj), tl_dim(ji))
762            ENDDO
763         END SELECT
764      ENDIF
765   ENDDO
766
767   ! add variables
768   IF( ALL( tl_dim(1:2)%l_use ) )THEN
769
770      ! open mpp files
771      CALL iom_mpp_open(tl_coord1)
772
773      ! add longitude
774      tl_lon=iom_mpp_read_var(tl_coord1,'longitude')
775      CALL mpp_add_var(tl_mppout, tl_lon)
776      CALL var_clean(tl_lon)
777
778      ! add latitude
779      tl_lat=iom_mpp_read_var(tl_coord1,'latitude')
780      CALL mpp_add_var(tl_mppout, tl_lat)
781      CALL var_clean(tl_lat)
782
783      ! close mpp files
784      CALL iom_mpp_close(tl_coord1)
785
786   ENDIF
787
788   IF( tl_dim(3)%l_use )THEN
789      IF( ASSOCIATED(tl_depth%d_value) )THEN
790         ! add depth
791         CALL mpp_add_var(tl_mppout, tl_depth)
792      ELSE
793         CALL logger_warn("CREATE RESTART: no value for depth variable.")
794      ENDIF
795   ENDIF
796   IF( ASSOCIATED(tl_depth%d_value) ) CALL var_clean(tl_depth)
797
798   IF( tl_dim(4)%l_use )THEN
799      IF( ASSOCIATED(tl_time%d_value) )THEN
800         ! add time
801         CALL mpp_add_var(tl_mppout, tl_time)
802      ELSE
803         CALL logger_warn("CREATE RESTART: no value for time variable.")
804      ENDIF
805   ENDIF
806   IF( ASSOCIATED(tl_time%d_value) ) CALL var_clean(tl_time)
807
808   ! add other variable
809   DO jvar=il_nvar,1,-1
810      ! check if variable already add
811      il_index=var_get_index(tl_mppout%t_proc(1)%t_var(:), tl_var(jvar)%c_name)
812      IF( il_index == 0 )THEN
813         CALL mpp_add_var(tl_mppout, tl_var(jvar))
814         CALL var_clean(tl_var(jvar))
815      ENDIF
816   ENDDO
817
818   ! add some attribute
819   tl_att=att_init("Created_by","SIREN create_restart")
820   CALL mpp_add_att(tl_mppout, tl_att)
821
822   cl_date=date_print(date_now())
823   tl_att=att_init("Creation_date",TRIM(cl_date))
824   CALL mpp_add_att(tl_mppout, tl_att)
825
826   ! add attribute periodicity
827   il_attid=0
828   IF( ASSOCIATED(tl_mppout%t_proc(1)%t_att) )THEN
829      il_attid=att_get_id(tl_mppout%t_proc(1)%t_att(:),'periodicity')
830   ENDIF
831   IF( tl_coord1%i_perio >= 0 .AND. il_attid == 0 )THEN
832      tl_att=att_init('periodicity',tl_coord1%i_perio)
833      CALL mpp_add_att(tl_mppout,tl_att)
834   ENDIF
835
836   il_attid=0
837   IF( ASSOCIATED(tl_mppout%t_proc(1)%t_att) )THEN
838      il_attid=att_get_id(tl_mppout%t_proc(1)%t_att(:),'ew_overlap')
839   ENDIF
840   IF( tl_coord1%i_ew >= 0 .AND. il_attid == 0 )THEN
841      tl_att=att_init('ew_overlap',tl_coord1%i_ew)
842      CALL mpp_add_att(tl_mppout,tl_att)
843   ENDIF
844
845   ! print
846   CALL mpp_print(tl_mppout)
847
848   ! create file
849   CALL iom_mpp_create(tl_mppout)
850
851   ! write file
852   CALL iom_mpp_write_file(tl_mppout)
853   ! close file
854   CALL iom_mpp_close(tl_mppout)
855
856   ! clean
857   CALL att_clean(tl_att)
858   CALL var_clean(tl_var(:))
859   DEALLOCATE(tl_var)
860   IF( .NOT. ln_extrap )THEN
861      CALL var_clean(tl_level(:))
862      DEALLOCATE(tl_level)
863   ENDIF
864
865   CALL mpp_clean(tl_mppout)
866   CALL mpp_clean(tl_coord1)
867
868   ! close log file
869   CALL logger_footer()
870   CALL logger_close()
871
872CONTAINS
873   !-------------------------------------------------------------------
874   !> @brief
875   !> This function create variable, filled with matrix value
876   !>
877   !> @details
878   !> A variable is create with the same name that the input variable,
879   !> and with dimension of the coordinate file.<br/>
880   !> Then the variable array of value is split into equal subdomain.
881   !> Each subdomain is filled with the corresponding value of the matrix.
882   !>
883   !> @author J.Paul
884   !> @date November, 2013 - Initial Version
885   !> @date June, 2015
886   !> - do not use level anymore
887   !>
888   !> @param[in] td_var    variable structure
889   !> @param[in] td_coord  coordinate file structure
890   !> @param[in] id_nlevel number of vertical level 
891   !> @param[in] id_xghost ghost cell array
892   !> @return variable structure
893   !-------------------------------------------------------------------
894   FUNCTION create_restart_matrix(td_var, td_coord, id_nlevel, id_xghost)
895      IMPLICIT NONE
896      ! Argument
897      TYPE(TVAR)                 , INTENT(IN) :: td_var
898      TYPE(TMPP)                 , INTENT(IN) :: td_coord
899      INTEGER(i4)                , INTENT(IN) :: id_nlevel
900      INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_xghost
901
902      ! function
903      TYPE(TVAR) :: create_restart_matrix
904
905      ! local variable
906      INTEGER(i4)      , DIMENSION(3)                    :: il_dim
907      INTEGER(i4)      , DIMENSION(3)                    :: il_size
908      INTEGER(i4)      , DIMENSION(3)                    :: il_rest
909
910      INTEGER(i4)      , DIMENSION(:)      , ALLOCATABLE :: il_ishape
911      INTEGER(i4)      , DIMENSION(:)      , ALLOCATABLE :: il_jshape
912      INTEGER(i4)      , DIMENSION(:)      , ALLOCATABLE :: il_kshape
913
914      REAL(dp)         , DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
915
916      TYPE(TDIM)       , DIMENSION(ip_maxdim)            :: tl_dim
917
918      ! loop indices
919      INTEGER(i4) :: ji
920      INTEGER(i4) :: jj
921      INTEGER(i4) :: jk
922      !----------------------------------------------------------------
923
924      ! write value on grid
925      ! get matrix dimension
926      il_dim(:)=td_var%t_dim(1:3)%i_len
927
928      ! output dimension
929      tl_dim(jp_I:jp_J)=dim_copy(td_coord%t_dim(jp_I:jp_J))
930      IF( id_nlevel >= 1 )THEN
931         tl_dim(jp_K)=dim_init('Z',id_nlevel)
932      ENDIF
933
934      ! remove ghost cell
935      tl_dim(jp_I)%i_len=tl_dim(jp_I)%i_len - SUM(id_xghost(jp_I,:))*ip_ghost
936      tl_dim(jp_J)%i_len=tl_dim(jp_J)%i_len - SUM(id_xghost(jp_J,:))*ip_ghost
937
938      ! split output domain in N subdomain depending of matrix dimension
939      il_size(:) = tl_dim(1:3)%i_len / il_dim(:)
940      il_rest(:) = MOD(tl_dim(1:3)%i_len, il_dim(:))
941
942      ALLOCATE( il_ishape(il_dim(1)+1) )
943      il_ishape(:)=0
944      DO ji=2,il_dim(1)+1
945         il_ishape(ji)=il_ishape(ji-1)+il_size(1)
946      ENDDO
947      ! add rest to last cell
948      il_ishape(il_dim(1)+1)=il_ishape(il_dim(1)+1)+il_rest(1)
949
950      ALLOCATE( il_jshape(il_dim(2)+1) )
951      il_jshape(:)=0
952      DO jj=2,il_dim(2)+1
953         il_jshape(jj)=il_jshape(jj-1)+il_size(2)
954      ENDDO
955      ! add rest to last cell
956      il_jshape(il_dim(2)+1)=il_jshape(il_dim(2)+1)+il_rest(2)
957
958      ALLOCATE( il_kshape(il_dim(3)+1) )
959      il_kshape(:)=0
960      DO jk=2,il_dim(3)+1
961         il_kshape(jk)=il_kshape(jk-1)+il_size(3)
962      ENDDO
963      ! add rest to last cell
964      il_kshape(il_dim(3)+1)=il_kshape(il_dim(3)+1)+il_rest(3)
965
966      ! write ouput array of value
967      ALLOCATE(dl_value( tl_dim(1)%i_len, &
968      &                  tl_dim(2)%i_len, &
969      &                  tl_dim(3)%i_len, &
970      &                  tl_dim(4)%i_len) )
971
972      dl_value(:,:,:,:)=0
973
974      DO jk=2,il_dim(3)+1
975         DO jj=2,il_dim(2)+1
976            DO ji=2,il_dim(1)+1
977               
978               dl_value( 1+il_ishape(ji-1):il_ishape(ji), &
979               &         1+il_jshape(jj-1):il_jshape(jj), &
980               &         1+il_kshape(jk-1):il_kshape(jk), &
981               &         1 ) = td_var%d_value(ji-1,jj-1,jk-1,1)
982
983            ENDDO
984         ENDDO
985      ENDDO
986
987      ! keep attribute and type
988      create_restart_matrix=var_copy(td_var)
989      DEALLOCATE( create_restart_matrix%d_value )
990      ! save new dimension
991      create_restart_matrix%t_dim(:)=dim_copy(tl_dim(:))
992      ! add variable value
993      CALL var_add_value( create_restart_matrix, dl_value(:,:,:,:), &
994      &                   id_type=td_var%i_type)
995
996      DEALLOCATE(dl_value)
997
998      ! clean
999      DEALLOCATE(il_ishape)
1000      DEALLOCATE(il_jshape)
1001      DEALLOCATE(il_kshape)
1002
1003   END FUNCTION create_restart_matrix
1004   !-------------------------------------------------------------------
1005   !> @brief
1006   !> This subroutine use mask to filled land point with _FillValue
1007   !>
1008   !> @author J.Paul
1009   !> @date November, 2013 - Initial Version
1010   !>
1011   !> @param[inout] td_var variable structure
1012   !> @param[in] td_mask   mask variable structure
1013   !-------------------------------------------------------------------
1014   SUBROUTINE create_restart_mask( td_var, td_mask )
1015
1016      IMPLICIT NONE
1017
1018      ! Argument
1019      TYPE(TVAR)              , INTENT(INOUT) :: td_var
1020      TYPE(TVAR), DIMENSION(:), INTENT(IN   ) :: td_mask
1021
1022      ! local variable
1023      INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask
1024
1025      ! loop indices
1026      INTEGER(i4) :: jl
1027      INTEGER(i4) :: jk
1028      !----------------------------------------------------------------
1029
1030      IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
1031         IF( ANY(td_var%t_dim(1:2)%i_len /= td_mask(1)%t_dim(1:2)%i_len) )THEN
1032            CALL logger_error("CREATE RESTART MASK: dimension differ between"//&
1033            &                 " variable "//TRIM(td_var%c_name)//" ("//&
1034            &                 TRIM(fct_str(td_var%t_dim(1)%i_len))//","//&
1035            &                 TRIM(fct_str(td_var%t_dim(2)%i_len))//&
1036            &                 ") and level ("//&
1037            &                 TRIM(fct_str(td_mask(1)%t_dim(1)%i_len))//","//&
1038            &                 TRIM(fct_str(td_mask(1)%t_dim(2)%i_len))//")")
1039         ELSE
1040            ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
1041            &                 td_var%t_dim(2)%i_len) )
1042
1043            SELECT CASE(TRIM(td_var%c_point))
1044            CASE('T')
1045               il_mask(:,:)=INT(td_mask(jp_T)%d_value(:,:,1,1))
1046            CASE('U')
1047               il_mask(:,:)=INT(td_mask(jp_U)%d_value(:,:,1,1))
1048            CASE('V')
1049               il_mask(:,:)=INT(td_mask(jp_V)%d_value(:,:,1,1))
1050            CASE('F')
1051               il_mask(:,:)=INT(td_mask(jp_F)%d_value(:,:,1,1))
1052            END SELECT
1053
1054            DO jl=1,td_var%t_dim(4)%i_len
1055               DO jk=1,td_var%t_dim(3)%i_len
1056                  WHERE( il_mask(:,:) < jk )
1057                     td_var%d_value(:,:,jk,jl)=td_var%d_fill
1058                  END WHERE
1059               ENDDO
1060            ENDDO
1061
1062            DEALLOCATE( il_mask )
1063         ENDIF
1064      ENDIF
1065   END SUBROUTINE create_restart_mask
1066   !-------------------------------------------------------------------
1067   !> @brief
1068   !> This subroutine interpolate variable
1069   !>
1070   !> @author J.Paul
1071   !> @date November, 2013 - Initial Version
1072   !> @date June, 2015
1073   !> - do not use level anymore (for extrapolation)
1074   !>
1075   !> @param[inout] td_var    variable structure
1076   !> @param[in] id_rho       array of refinment factor
1077   !> @param[in] id_offset    array of offset between fine and coarse grid
1078   !> @param[in] id_iext      i-direction size of extra bands (default=im_minext)
1079   !> @param[in] id_jext      j-direction size of extra bands (default=im_minext)
1080   !-------------------------------------------------------------------
1081   SUBROUTINE create_restart_interp( td_var, & 
1082   &                                 id_rho,          &
1083   &                                 id_offset,       &
1084   &                                 id_iext, id_jext)
1085
1086      IMPLICIT NONE
1087
1088      ! Argument
1089      TYPE(TVAR) ,                 INTENT(INOUT) :: td_var
1090      INTEGER(i4), DIMENSION(:)  , INTENT(IN   ) :: id_rho
1091      INTEGER(i4), DIMENSION(:,:), INTENT(IN   ) :: id_offset
1092      INTEGER(i4),                 INTENT(IN   ), OPTIONAL :: id_iext
1093      INTEGER(i4),                 INTENT(IN   ), OPTIONAL :: id_jext
1094
1095      ! local variable
1096      INTEGER(i4) :: il_iext
1097      INTEGER(i4) :: il_jext
1098
1099      ! loop indices
1100      !----------------------------------------------------------------
1101
1102      il_iext=3
1103      IF( PRESENT(id_iext) ) il_iext=id_iext
1104
1105      il_jext=3
1106      IF( PRESENT(id_jext) ) il_jext=id_jext
1107
1108      IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
1109         CALL logger_warn("CREATE RESTART INTERP: at least extrapolation "//&
1110         &  "on two points are required with cubic interpolation ")
1111         il_iext=2
1112      ENDIF
1113
1114      IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
1115         CALL logger_warn("CREATE RESTART INTERP: at least extrapolation "//&
1116         &  "on two points are required with cubic interpolation ")
1117         il_jext=2
1118      ENDIF
1119      ! work on variable
1120      ! add extraband
1121      CALL extrap_add_extrabands(td_var, il_iext, il_jext)
1122
1123      ! extrapolate variable
1124      CALL extrap_fill_value( td_var )
1125
1126      ! interpolate variable
1127      CALL interp_fill_value( td_var, id_rho(:), &
1128      &                       id_offset=id_offset(:,:) )
1129
1130      ! remove extraband
1131      CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
1132
1133   END SUBROUTINE create_restart_interp
1134   !-------------------------------------------------------------------
1135   !> @brief
1136   !> This subroutine get depth variable value in an open mpp structure
1137   !> and check if agree with already input depth variable.
1138   !>
1139   !> @details
1140   !>
1141   !> @author J.Paul
1142   !> @date November, 2014 - Initial Version
1143   !>
1144   !> @param[in] td_mpp       mpp structure
1145   !> @param[inout] td_depth  depth variable structure
1146   !-------------------------------------------------------------------
1147   SUBROUTINE create_restart_check_depth( td_mpp, td_depth )
1148
1149      IMPLICIT NONE
1150
1151      ! Argument
1152      TYPE(TMPP), INTENT(IN   ) :: td_mpp
1153      TYPE(TVAR), INTENT(INOUT) :: td_depth
1154
1155      ! local variable
1156      INTEGER(i4) :: il_varid
1157      TYPE(TVAR)  :: tl_depth
1158      ! loop indices
1159      !----------------------------------------------------------------
1160
1161      ! get or check depth value
1162      IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN
1163
1164         il_varid=td_mpp%t_proc(1)%i_depthid
1165         IF( ASSOCIATED(td_depth%d_value) )THEN
1166
1167            tl_depth=iom_mpp_read_var(td_mpp, il_varid)
1168            IF( ANY( td_depth%d_value(:,:,:,:) /= &
1169            &        tl_depth%d_value(:,:,:,:) ) )THEN
1170
1171               CALL logger_fatal("CREATE BOUNDARY: depth value from "//&
1172               &  TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//&
1173               &  " to those from former file(s).")
1174
1175            ENDIF
1176            CALL var_clean(tl_depth)
1177
1178         ELSE
1179            td_depth=iom_mpp_read_var(td_mpp,il_varid)
1180         ENDIF
1181
1182      ENDIF
1183     
1184   END SUBROUTINE create_restart_check_depth
1185   !-------------------------------------------------------------------
1186   !> @brief
1187   !> This subroutine get date and time in an open mpp structure
1188   !> and check if agree with date and time already read.
1189   !>
1190   !> @details
1191   !>
1192   !> @author J.Paul
1193   !> @date November, 2014 - Initial Version
1194   !>
1195   !> @param[in] td_mpp      mpp structure
1196   !> @param[inout] td_time  time variable structure
1197   !-------------------------------------------------------------------
1198   SUBROUTINE create_restart_check_time( td_mpp, td_time )
1199
1200      IMPLICIT NONE
1201
1202      ! Argument
1203      TYPE(TMPP), INTENT(IN   ) :: td_mpp
1204      TYPE(TVAR), INTENT(INOUT) :: td_time
1205
1206      ! local variable
1207      INTEGER(i4) :: il_varid
1208      TYPE(TVAR)  :: tl_time
1209
1210      TYPE(TDATE) :: tl_date1
1211      TYPE(TDATE) :: tl_date2
1212      ! loop indices
1213      !----------------------------------------------------------------
1214
1215      ! get or check depth value
1216
1217      IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN
1218
1219         il_varid=td_mpp%t_proc(1)%i_timeid
1220         IF( ASSOCIATED(td_time%d_value) )THEN
1221
1222            tl_time=iom_mpp_read_var(td_mpp, il_varid)
1223
1224            tl_date1=var_to_date(td_time)
1225            tl_date2=var_to_date(tl_time)
1226            IF( tl_date1 - tl_date2 /= 0 )THEN
1227
1228               CALL logger_fatal("CREATE BOUNDARY: date from "//&
1229               &  TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//&
1230               &  " to those from former file(s).")
1231
1232            ENDIF
1233            CALL var_clean(tl_time)
1234
1235         ELSE
1236            td_time=iom_mpp_read_var(td_mpp,il_varid)
1237         ENDIF
1238
1239      ENDIF
1240     
1241   END SUBROUTINE create_restart_check_time
1242END PROGRAM create_restart
Note: See TracBrowser for help on using the repository browser.