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_coord.f90 in trunk/NEMOGCM/TOOLS/SIREN/src – NEMO

source: trunk/NEMOGCM/TOOLS/SIREN/src/create_coord.f90 @ 4528

Last change on this file since 4528 was 4213, checked in by cbricaud, 10 years ago

first draft of the CONFIGURATION MANAGER demonstrator
File size: 13.7 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5!
6! PROGRAM: create_coord
7!
8! DESCRIPTION:
9!> @brief
10!> This program create coordinate file.
11!>
12!> @details
13!> Variables are extracted from the input coordinates coarse grid,
14!> and interpolated to create fine coordinates files.
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!> - add extrapolation (case coordin with mask)
25!> - add extraction from a grid at fine resolution
26!----------------------------------------------------------------------
27!> @code
28PROGRAM create_coord
29
30!   USE netcdf                          ! nf90 library
31   USE global                          ! global variable
32   USE kind                            ! F90 kind parameter
33   USE logger                          ! log file manager
34   USE fct                             ! basic useful function
35   USE date                            ! date manager
36   USE att                             ! attribute manager
37   USE dim                             ! dimension manager
38   USE var                             ! variable manager
39   USE file                            ! file manager
40   USE iom                             ! I/O manager
41   USE dom                             ! domain manager
42   USE grid                            ! grid manager
43   USE extrap                          ! extrapolation manager
44   USE interp                          ! interpolation manager
45   USE filter                          ! filter manager
46   USE mpp                             ! MPP manager
47   USE iom_mpp                         ! MPP I/O manager
48
49   IMPLICIT NONE
50
51   ! local variable
52   CHARACTER(LEN=lc)                                    :: cl_namelist
53   CHARACTER(LEN=lc)                                    :: cl_date
54
55   INTEGER(i4)                                          :: il_narg
56   INTEGER(i4)                                          :: il_status
57   INTEGER(i4)                                          :: il_fileid
58   INTEGER(i4)                                          :: il_nvar
59!   INTEGER(i4)      , DIMENSION(:,:,:,:)  , ALLOCATABLE :: il_value
60   INTEGER(i4)      , DIMENSION(ip_maxdim)              :: il_rho
61
62
63   LOGICAL                                              :: ll_exist
64
65   TYPE(TATT)                                           :: tl_att
66
67   TYPE(TDOM)                                           :: tl_dom
68
69   TYPE(TVAR)       , DIMENSION(:)        , ALLOCATABLE :: tl_var
70
71   TYPE(TDIM)       , DIMENSION(ip_maxdim)              :: tl_dim
72
73   TYPE(TFILE)                                          :: tl_coord0
74   TYPE(TFILE)                                          :: tl_fileout
75
76   TYPE(TMPP)                                           :: tl_mppcoordin
77
78   ! loop indices
79   INTEGER(i4) :: ji
80
81   ! namelist variable
82   CHARACTER(LEN=lc) :: cn_logfile = 'create_coord.log' 
83   CHARACTER(LEN=lc) :: cn_verbosity = 'warning' 
84
85   CHARACTER(LEN=lc) :: cn_coord0 = '' 
86   INTEGER(i4)       :: in_perio0 = -1
87
88   CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 
89
90   CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varinfo = ''
91
92   INTEGER(i4)       :: in_imin0 = 0
93   INTEGER(i4)       :: in_imax0 = 0
94   INTEGER(i4)       :: in_jmin0 = 0
95   INTEGER(i4)       :: in_jmax0 = 0
96   INTEGER(i4)       :: in_rhoi  = 1
97   INTEGER(i4)       :: in_rhoj  = 1
98
99   CHARACTER(LEN=lc) :: cn_fileout= 'coord_fine.nc'
100   !-------------------------------------------------------------------
101
102   NAMELIST /namlog/ & !< logger namelist
103   &  cn_logfile,    & !< log file
104   &  cn_verbosity     !< logger verbosity
105
106   NAMELIST /namcfg/ &  !< config namelist
107   &  cn_varcfg         !< variable configuration file
108
109   NAMELIST /namcrs/ &  ! coarse grid namelist
110   &  cn_coord0 , &     !< coordinate file
111   &  in_perio0         !< periodicity index
112
113   NAMELIST /namvar/ &  ! namvar
114   &  cn_varinfo        !< list of variable and extra information about
115                        !< interpolation, extrapolation or filter method to be used.
116                        !< (ex: 'votemper/linear/hann/dist_weight','vosaline/cubic' )
117   
118   NAMELIST /namnst/ &  !< nesting namelist
119   &  in_imin0,   &     !< i-direction lower left  point indice
120   &  in_imax0,   &     !< i-direction upper right point indice
121   &  in_jmin0,   &     !< j-direction lower left  point indice
122   &  in_jmax0,   &     !< j-direction upper right point indice
123   &  in_rhoi,    &     !< refinement factor in i-direction
124   &  in_rhoj           !< refinement factor in j-direction
125
126   NAMELIST /namout/ &  !< output namelist
127   &  cn_fileout       !< fine grid coordinate file   
128   !-------------------------------------------------------------------
129
130   !1- namelist
131   !1-1 get namelist
132   il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec
133   IF( il_narg/=1 )THEN
134      PRINT *,"ERROR in create_coord: need a namelist"
135      STOP
136   ELSE
137      CALL GET_COMMAND_ARGUMENT(1,cl_namelist) !f03 intrinsec
138   ENDIF
139   
140   !1-2 read namelist
141   INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist)
142   IF( ll_exist )THEN
143     
144      il_fileid=fct_getunit()
145
146      OPEN( il_fileid, FILE=TRIM(cl_namelist),   &
147      &                FORM='FORMATTED',         &
148      &                ACCESS='SEQUENTIAL',      &
149      &                STATUS='OLD',             &
150      &                ACTION='READ',            &
151      &                IOSTAT=il_status)
152      CALL fct_err(il_status)
153      IF( il_status /= 0 )THEN
154         PRINT *,"ERROR in create_coord: error opening "//TRIM(cl_namelist)
155         STOP
156      ENDIF
157
158      READ( il_fileid, NML = namlog )
159      !1-2-1 define log file
160      CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity))
161      CALL logger_header()
162
163      READ( il_fileid, NML = namcfg )
164      !1-2-2 get variable extra information on configuration file
165      CALL var_def_extra(TRIM(cn_varcfg))
166
167      READ( il_fileid, NML = namcrs )
168      READ( il_fileid, NML = namvar )
169      !1-2-3 add user change in extra information
170      CALL var_chg_extra( cn_varinfo )
171
172      READ( il_fileid, NML = namnst )
173      READ( il_fileid, NML = namout )
174
175      CLOSE( il_fileid, IOSTAT=il_status )
176      CALL fct_err(il_status)
177      IF( il_status /= 0 )THEN
178         CALL logger_error("CREATE COORD: closing "//TRIM(cl_namelist))
179      ENDIF
180
181   ELSE
182
183      PRINT *,"ERROR in create_coord: can't find "//TRIM(cl_namelist)
184
185   ENDIF
186
187   !2- open files
188   IF( cn_coord0 /= '' )THEN
189      tl_coord0=file_init(TRIM(cn_coord0),id_perio=in_perio0)
190      CALL iom_open(tl_coord0)
191   ELSE
192       CALL logger_fatal("CREATE COORD: no coarse grid coordinate found. "//&
193      &     "check namelist")     
194   ENDIF
195
196   !3- check
197   !3-1 check output file do not already exist
198   INQUIRE(FILE=TRIM(cn_fileout), EXIST=ll_exist)
199   IF( ll_exist )THEN
200      CALL logger_fatal("CREATE COORD: output file "//TRIM(cn_fileout)//&
201      &  " already exist.")
202   ENDIF
203
204   !3-2 check namelist
205   IF( in_imin0 < 1 .OR. in_imax0 < 1 .OR. in_jmin0 < 1 .OR. in_jmax0 < 1)THEN
206      CALL logger_error("CREATE COORD: invalid point indice."//&
207      &  " check namelist "//TRIM(cl_namelist))
208   ENDIF
209
210   il_rho(:)=1
211   IF( in_rhoi < 1 .OR. in_rhoj < 1 )THEN
212      CALL logger_error("CREATE COORD: invalid refinement factor."//&
213      &  " check namelist "//TRIM(cl_namelist))
214   ELSE
215      il_rho(jp_I)=in_rhoi
216      il_rho(jp_J)=in_rhoj     
217   ENDIF
218
219   !3-3 check domain validity
220   CALL grid_check_dom(tl_coord0, in_imin0, in_imax0, in_jmin0, in_jmax0 )
221
222   !4- compute domain
223   tl_dom=dom_init( tl_coord0,         &
224   &                in_imin0, in_imax0,&
225   &                in_jmin0, in_jmax0 )
226
227   ! close file
228   CALL iom_close(tl_coord0)
229
230   !4-1 add extra band (if possible) to compute interpolation
231   CALL dom_add_extra(tl_dom)
232
233   !5- read variables on domain (ugly way to do it, have to work on it)
234   !5-1 init mpp structure
235   tl_mppcoordin=mpp_init(tl_coord0)
236
237   CALL file_clean(tl_coord0)
238
239   !5-2 get processor to be used
240   CALL mpp_get_use( tl_mppcoordin, tl_dom )
241
242   !5-3 open mpp files
243   CALL iom_mpp_open(tl_mppcoordin)
244
245   !5-4 fill variable value on domain
246   CALL iom_mpp_fill_var(tl_mppcoordin, tl_dom)
247
248   !5-5 close mpp files
249   CALL iom_mpp_close(tl_mppcoordin)
250
251   il_nvar=tl_mppcoordin%t_proc(1)%i_nvar
252   ALLOCATE( tl_var(il_nvar) )
253   DO ji=1,il_nvar
254
255      tl_var(ji)=tl_mppcoordin%t_proc(1)%t_var(ji)
256      !7- interpolate variables
257      CALL create_coord_interp( tl_var(ji), il_rho(:) )
258
259      !6- remove extraband added to domain
260      CALL dom_del_extra( tl_var(ji), tl_dom, il_rho(:) )
261
262      !7- add ghost cell
263      CALL grid_add_ghost(tl_var(ji),tl_dom%i_ighost,tl_dom%i_jghost)     
264
265      !8- filter
266      CALL filter_fill_value(tl_var(ji))     
267
268   ENDDO
269
270   !9- clean
271   DO ji=1,il_nvar
272      CALL var_clean(tl_mppcoordin%t_proc(1)%t_var(ji))
273   ENDDO
274   CALL mpp_clean(tl_mppcoordin)
275
276   !10- create file
277   tl_fileout=file_init(TRIM(cn_fileout))
278
279   !10-1 add dimension
280   ! save biggest dimension
281   tl_dim(:)=var_max_dim(tl_var(:))
282
283   DO ji=1,ip_maxdim
284      IF( tl_dim(ji)%l_use ) CALL file_add_dim(tl_fileout, tl_dim(ji))
285   ENDDO
286
287   !10-2 add variables
288
289   DO ji=1,il_nvar
290      CALL file_add_var(tl_fileout, tl_var(ji))
291   ENDDO
292
293   !10-3 add some attribute
294   tl_att=att_init("Created_by","SIREN create_coord")
295   CALL file_add_att(tl_fileout, tl_att)
296
297   cl_date=date_print(date_now())
298   tl_att=att_init("Creation_date",cl_date)
299   CALL file_add_att(tl_fileout, tl_att)
300
301   tl_att=att_init("source_file",TRIM(fct_basename(cn_coord0)))
302   CALL file_add_att(tl_fileout, tl_att)   
303
304   tl_att=att_init("source_i-indices",(/in_imin0,in_imax0/))
305   CALL file_add_att(tl_fileout, tl_att)   
306   tl_att=att_init("source_j-indices",(/in_jmin0,in_jmax0/))
307   CALL file_add_att(tl_fileout, tl_att)   
308
309   !10-4 create file
310   CALL iom_create(tl_fileout)
311
312   !10-5 write file
313   CALL iom_write_file(tl_fileout)
314
315   !10-6 close file
316   CALL iom_close(tl_fileout)
317
318   !11- clean
319   DO ji=1,il_nvar
320      CALL var_clean(tl_var(ji))
321   ENDDO
322   CALL file_clean(tl_fileout)
323
324   DEALLOCATE( tl_var) 
325
326   ! close log file
327   CALL logger_footer()
328   CALL logger_close()   
329
330!> @endcode
331CONTAINS
332   !-------------------------------------------------------------------
333   !> @brief
334   !> This subroutine
335   !>
336   !> @details
337   !>
338   !> @author J.Paul
339   !> - Nov, 2013- Initial Version
340   !>
341   !> @param[in]
342   !> @todo
343   !-------------------------------------------------------------------
344   !> @code
345   SUBROUTINE create_coord_interp( td_var,          &
346   &                               id_rho,          &
347   &                               id_iext, id_jext)
348
349      IMPLICIT NONE
350
351      ! Argument
352      TYPE(TVAR) ,               INTENT(INOUT) :: td_var
353      INTEGER(i4), DIMENSION(:), INTENT(IN   ) :: id_rho
354      INTEGER(i4),               INTENT(IN   ), OPTIONAL :: id_iext
355      INTEGER(i4),               INTENT(IN   ), OPTIONAL :: id_jext
356
357      ! local variable
358      TYPE(TVAR)  :: tl_mask
359      TYPE(TVAR)  :: tl_var
360
361      INTEGER(i1), DIMENSION(:,:,:,:), ALLOCATABLE :: bl_mask
362
363      INTEGER(i4), DIMENSION(2,2) :: il_offset
364
365      INTEGER(i4) :: il_iext
366      INTEGER(i4) :: il_jext
367
368      ! loop indices
369      !----------------------------------------------------------------
370
371      ! copy variable
372      tl_var=td_var
373
374      !WARNING: two extrabands are required for cubic interpolation
375      il_iext=2
376      IF( PRESENT(id_iext) ) il_iext=id_iext
377
378      il_jext=2
379      IF( PRESENT(id_jext) ) il_jext=id_jext
380     
381      IF( il_iext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
382         CALL logger_warn("CREATE COORD INTERP: at least extrapolation "//&
383         &  "on two points are required with cubic interpolation ")
384         il_iext=2
385      ENDIF
386
387      IF( il_jext < 2 .AND. td_var%c_interp(1) == 'cubic' )THEN
388         CALL logger_warn("CREATE COORD INTERP: at least extrapolation "//&
389         &  "on two points are required with cubic interpolation ")
390         il_jext=2
391      ENDIF
392
393      !1- work on mask
394      !1-1 create mask
395      ALLOCATE(bl_mask(tl_var%t_dim(1)%i_len, &
396      &                tl_var%t_dim(2)%i_len, &
397      &                tl_var%t_dim(3)%i_len, &
398      &                tl_var%t_dim(4)%i_len) )
399
400      bl_mask(:,:,:,:)=1
401      WHERE(tl_var%d_value(:,:,:,:)==tl_var%d_fill) bl_mask(:,:,:,:)=0     
402
403      SELECT CASE(TRIM(tl_var%c_point))
404      CASE DEFAULT ! 'T'
405         tl_mask=var_init('tmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
406      CASE('U')
407         tl_mask=var_init('umask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
408      CASE('V')
409         tl_mask=var_init('vmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
410      CASE('F')
411         tl_mask=var_init('fmask', bl_mask(:,:,:,:), td_dim=tl_var%t_dim(:))
412      END SELECT         
413
414      DEALLOCATE(bl_mask)
415
416      !1-2 interpolate mask
417      il_offset(:,:)=1
418      CALL interp_fill_value( tl_mask, id_rho(:), &
419      &                       id_offset=il_offset(:,:) )
420
421      !2- work on variable
422      !2-0 add extraband
423      CALL extrap_add_extrabands(tl_var, il_iext, il_jext)
424
425      !2-1 extrapolate variable
426      CALL extrap_fill_value( tl_var, id_iext=il_iext, id_jext=il_jext )
427
428      !2-2 interpolate variable
429      il_offset(:,:)=1
430      CALL interp_fill_value( tl_var, id_rho(:), &
431      &                       id_offset=il_offset(:,:))
432
433      !2-3 remove extraband
434      CALL extrap_del_extrabands(tl_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J))
435
436      !3- keep original mask
437      WHERE( tl_mask%d_value(:,:,:,:) == 0 )
438         tl_var%d_value(:,:,:,:)=tl_var%d_fill
439      END WHERE
440
441      !4- save result
442      td_var=tl_var
443
444      ! clean variable structure
445      CALL var_clean(tl_mask)
446      CALL var_clean(tl_var)
447
448   END SUBROUTINE create_coord_interp
449   !> @endcode
450END PROGRAM create_coord
Note: See TracBrowser for help on using the repository browser.