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.
Changeset 6225 for branches/2014/dev_r4704_NOC5_MPP_BDY_UPDATE/NEMOGCM/TOOLS/SIREN/src/create_coord.f90 – NEMO

Ignore:
Timestamp:
2016-01-08T10:35:19+01:00 (8 years ago)
Author:
jamesharle
Message:

Update MPP_BDY_UPDATE branch to be consistent with head of trunk

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/2014/dev_r4704_NOC5_MPP_BDY_UPDATE/NEMOGCM/TOOLS/SIREN/src/create_coord.f90

    r4213 r6225  
    77! 
    88! DESCRIPTION: 
     9!> @file 
    910!> @brief  
    10 !> This program create coordinate file. 
     11!> This program create fine grid coordinate file. 
    1112!> 
    1213!> @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 
     14!> @section sec1 method 
     15!>    All variables from the input coordinates coarse grid file, are extracted 
     16!>    and interpolated to create fine grid coordinates files.<br/> 
     17!>    @note  
     18!>       interpolation method could be different for each variable. 
     19!> 
     20!> @section sec2 how to 
     21!>    to create fine grid coordinates files:<br/> 
     22!> @code{.sh} 
     23!>    ./SIREN/bin/create_coord create_coord.nam 
     24!> @endcode 
     25!>     
     26!> @note  
     27!>    you could find a template of the namelist in templates directory. 
     28!> 
     29!>    create_coord.nam comprise 6 namelists:<br/> 
     30!>       - logger namelist (namlog) 
     31!>       - config namelist (namcfg) 
     32!>       - coarse grid namelist (namcrs) 
     33!>       - variable namelist (namvar) 
     34!>       - nesting namelist (namnst) 
     35!>       - output namelist (namout) 
     36!>     
     37!>    @note  
     38!>       All namelists have to be in file create_coord.nam,  
     39!>       however variables of those namelists are all optional. 
     40!> 
     41!>    * _logger namelist (namlog)_:<br/> 
     42!>       - cn_logfile   : log filename 
     43!>       - cn_verbosity : verbosity ('trace','debug','info', 
     44!> 'warning','error','fatal','none') 
     45!>       - in_maxerror  : maximum number of error allowed 
     46!> 
     47!>    * _config namelist (namcfg)_:<br/> 
     48!>       - cn_varcfg : variable configuration file  
     49!> (see ./SIREN/cfg/variable.cfg) 
     50!> 
     51!>    * _coarse grid namelist (namcrs)_:<br/> 
     52!>       - cn_coord0 : coordinate file 
     53!>       - in_perio0 : NEMO periodicity index (see Model Boundary Condition in 
     54!> [NEMO documentation](http://www.nemo-ocean.eu/About-NEMO/Reference-manuals)) 
     55!> 
     56!>    * _variable namelist (namvar)_:<br/> 
     57!>       - cn_varinfo : list of variable and extra information about request(s) 
     58!> to be used.<br/> 
     59!>          each elements of *cn_varinfo* is a string character  
     60!>          (separated by ',').<br/> 
     61!>          it is composed of the variable name follow by ':',  
     62!>          then request(s) to be used on this variable.<br/>  
     63!>          request could be: 
     64!>             - int = interpolation method 
     65!>             - ext = extrapolation method 
     66!>             - flt = filter method 
     67!>  
     68!>                requests must be separated by ';' .<br/> 
     69!>                order of requests does not matter.<br/> 
     70!> 
     71!>          informations about available method could be find in @ref interp, 
     72!>          @ref extrap and @ref filter modules.<br/> 
     73!> 
     74!>          Example: 'votemper: int=linear; flt=hann(2,3); ext=dist_weight',  
     75!>          'vosaline: int=cubic'<br/> 
     76!>          @note  
     77!>             If you do not specify a method which is required,  
     78!>             default one is applied. 
     79!> 
     80!>    * _nesting namelist (namnst)_:<br/> 
     81!>       - in_imin0 : i-direction lower left  point indice  
     82!> of coarse grid subdomain to be used 
     83!>       - in_imax0 : i-direction upper right point indice 
     84!> of coarse grid subdomain to be used 
     85!>       - in_jmin0 : j-direction lower left  point indice 
     86!> of coarse grid subdomain to be used 
     87!>       - in_jmax0 : j-direction upper right point indice 
     88!> of coarse grid subdomain to be used 
     89!>       - in_rhoi  : refinement factor in i-direction 
     90!>       - in_rhoj  : refinement factor in j-direction<br/> 
     91!> 
     92!>       \image html  grid_zoom_40.png  
     93!>       \image latex grid_zoom_40.png 
     94!> 
     95!>    * _output namelist (namout)_: 
     96!>       - cn_fileout : output coordinate file name 
     97!> 
     98!> @author J.Paul 
    1899! REVISION HISTORY: 
    19 !> @date Nov, 2013 - Initial Version 
    20 ! 
     100!> @date November, 2013 - Initial Version 
     101!> @date September, 2014 
     102!> - add header for user 
     103!> - compute offset considering grid point 
     104!> - add global attributes in output file 
     105!> 
    21106!> @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 
    26107!---------------------------------------------------------------------- 
    27 !> @code 
    28108PROGRAM create_coord 
    29109 
    30 !   USE netcdf                          ! nf90 library 
    31110   USE global                          ! global variable 
    32111   USE kind                            ! F90 kind parameter 
    … …  
    39118   USE file                            ! file manager 
    40119   USE iom                             ! I/O manager 
    41    USE dom                             ! domain manager 
    42120   USE grid                            ! grid manager 
    43121   USE extrap                          ! extrapolation manager 
    … …  
    45123   USE filter                          ! filter manager 
    46124   USE mpp                             ! MPP manager 
     125   USE dom                             ! domain manager 
    47126   USE iom_mpp                         ! MPP I/O manager 
     127   USE iom_dom                         ! DOM I/O manager 
    48128 
    49129   IMPLICIT NONE 
    … …  
    56136   INTEGER(i4)                                          :: il_status 
    57137   INTEGER(i4)                                          :: il_fileid 
     138   INTEGER(i4)                                          :: il_attid 
     139   INTEGER(i4)                                          :: il_ind 
    58140   INTEGER(i4)                                          :: il_nvar 
    59 !   INTEGER(i4)      , DIMENSION(:,:,:,:)  , ALLOCATABLE :: il_value 
     141   INTEGER(i4)                                          :: il_ew 
    60142   INTEGER(i4)      , DIMENSION(ip_maxdim)              :: il_rho 
    61  
     143   INTEGER(i4)      , DIMENSION(2,2,ip_npoint)          :: il_offset 
    62144 
    63145   LOGICAL                                              :: ll_exist 
    … …  
    71153   TYPE(TDIM)       , DIMENSION(ip_maxdim)              :: tl_dim 
    72154 
    73    TYPE(TFILE)                                          :: tl_coord0 
     155   TYPE(TMPP)                                           :: tl_coord0 
    74156   TYPE(TFILE)                                          :: tl_fileout 
    75  
    76    TYPE(TMPP)                                           :: tl_mppcoordin 
    77157 
    78158   ! loop indices 
    79159   INTEGER(i4) :: ji 
     160   INTEGER(i4) :: jj 
    80161 
    81162   ! namelist variable 
     163   ! namlog 
    82164   CHARACTER(LEN=lc) :: cn_logfile = 'create_coord.log'  
    83165   CHARACTER(LEN=lc) :: cn_verbosity = 'warning'  
    84  
     166   INTEGER(i4)       :: in_maxerror = 5 
     167 
     168   ! namcfg 
     169   CHARACTER(LEN=lc) :: cn_varcfg = '../cfg/variable.cfg'  
     170 
     171   ! namcrs 
    85172   CHARACTER(LEN=lc) :: cn_coord0 = ''  
    86173   INTEGER(i4)       :: in_perio0 = -1 
    87174 
    88    CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg'  
    89  
    90    CHARACTER(LEN=lc), DIMENSION(ig_maxvar) :: cn_varinfo = '' 
    91  
     175   ! namvar 
     176   CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' 
     177 
     178   !namnst 
    92179   INTEGER(i4)       :: in_imin0 = 0 
    93180   INTEGER(i4)       :: in_imax0 = 0 
    … …  
    97184   INTEGER(i4)       :: in_rhoj  = 1 
    98185 
     186   !namout 
    99187   CHARACTER(LEN=lc) :: cn_fileout= 'coord_fine.nc' 
    100188   !------------------------------------------------------------------- 
    101189 
    102    NAMELIST /namlog/ & !< logger namelist 
    103    &  cn_logfile,    & !< log file 
    104    &  cn_verbosity     !< logger verbosity 
    105  
    106    NAMELIST /namcfg/ &  !< config namelist 
     190   NAMELIST /namlog/ &  !  logger namelist 
     191   &  cn_logfile,    &  !< logger file name 
     192   &  cn_verbosity,  &  !< logger verbosity 
     193   &  in_maxerror       !< logger maximum error 
     194 
     195   NAMELIST /namcfg/ &  !  config namelist 
    107196   &  cn_varcfg         !< variable configuration file 
    108197 
    109    NAMELIST /namcrs/ &  ! coarse grid namelist 
     198   NAMELIST /namcrs/ &  !  coarse grid namelist 
    110199   &  cn_coord0 , &     !< coordinate file 
    111200   &  in_perio0         !< periodicity index 
    112201 
    113    NAMELIST /namvar/ &  ! namvar 
     202   NAMELIST /namvar/ &  !  variable namelist 
    114203   &  cn_varinfo        !< list of variable and extra information about  
    115204                        !< interpolation, extrapolation or filter method to be used.  
    116                         !< (ex: 'votemper/linear/hann/dist_weight','vosaline/cubic' )  
     205                        !< (ex: 'votemper:linear,hann,dist_weight','vosaline:cubic' )  
    117206    
    118    NAMELIST /namnst/ &  !< nesting namelist 
     207   NAMELIST /namnst/ &  !  nesting namelist 
    119208   &  in_imin0,   &     !< i-direction lower left  point indice  
    120209   &  in_imax0,   &     !< i-direction upper right point indice 
    … …  
    124213   &  in_rhoj           !< refinement factor in j-direction 
    125214 
    126    NAMELIST /namout/ &  !< output namelist 
    127    &  cn_fileout       !< fine grid coordinate file    
     215   NAMELIST /namout/ &  !  output namelist 
     216   &  cn_fileout        !< fine grid coordinate file    
    128217   !------------------------------------------------------------------- 
    129218 
    130    !1- namelist 
    131    !1-1 get namelist 
     219   ! namelist 
     220   ! get namelist 
    132221   il_narg=COMMAND_ARGUMENT_COUNT() !f03 intrinsec 
    133222   IF( il_narg/=1 )THEN 
    … …  
    138227   ENDIF 
    139228    
    140    !1-2 read namelist 
     229   ! read namelist 
    141230   INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist) 
    142231   IF( ll_exist )THEN 
    143        
     232  
    144233      il_fileid=fct_getunit() 
    145234 
    … …  
    157246 
    158247      READ( il_fileid, NML = namlog ) 
    159       !1-2-1 define log file 
    160       CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity)) 
     248      ! define logger file 
     249      CALL logger_open(TRIM(cn_logfile),TRIM(cn_verbosity),in_maxerror) 
    161250      CALL logger_header() 
    162251 
    163252      READ( il_fileid, NML = namcfg ) 
    164       !1-2-2 get variable extra information on configuration file 
     253      ! get variable extra information on configuration file 
    165254      CALL var_def_extra(TRIM(cn_varcfg)) 
    166255 
    167256      READ( il_fileid, NML = namcrs ) 
    168257      READ( il_fileid, NML = namvar ) 
    169       !1-2-3 add user change in extra information 
     258      ! add user change in extra information 
    170259      CALL var_chg_extra( cn_varinfo ) 
    171260 
    … …  
    182271 
    183272      PRINT *,"ERROR in create_coord: can't find "//TRIM(cl_namelist) 
    184  
    185    ENDIF 
    186  
    187    !2- open files 
     273      STOP 
     274 
     275   ENDIF 
     276 
     277   ! open files 
    188278   IF( cn_coord0 /= '' )THEN 
    189       tl_coord0=file_init(TRIM(cn_coord0),id_perio=in_perio0) 
    190       CALL iom_open(tl_coord0) 
     279      tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0) 
     280      CALL grid_get_info(tl_coord0) 
    191281   ELSE 
    192        CALL logger_fatal("CREATE COORD: no coarse grid coordinate found. "//& 
     282      CALL logger_fatal("CREATE COORD: no coarse grid coordinate found. "//& 
    193283      &     "check namelist")       
    194284   ENDIF 
    195285 
    196    !3- check 
    197    !3-1 check output file do not already exist 
     286   ! check 
     287   ! check output file do not already exist 
    198288   INQUIRE(FILE=TRIM(cn_fileout), EXIST=ll_exist) 
    199289   IF( ll_exist )THEN 
    … …  
    202292   ENDIF 
    203293 
    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."//& 
     294   ! check nesting parameters 
     295   IF( in_imin0 < 0 .OR. in_imax0 < 0 .OR. in_jmin0 < 0 .OR. in_jmax0 < 0)THEN 
     296      CALL logger_fatal("CREATE COORD: invalid points indices."//& 
    207297      &  " check namelist "//TRIM(cl_namelist)) 
    208298   ENDIF 
    … …  
    215305      il_rho(jp_I)=in_rhoi 
    216306      il_rho(jp_J)=in_rhoj       
    217    ENDIF 
    218  
    219    !3-3 check domain validity 
     307 
     308      il_offset(:,:,:)=create_coord_get_offset(il_rho(:)) 
     309   ENDIF 
     310 
     311   ! check domain validity 
    220312   CALL grid_check_dom(tl_coord0, in_imin0, in_imax0, in_jmin0, in_jmax0 ) 
    221313 
    222    !4- compute domain 
     314   ! compute domain 
    223315   tl_dom=dom_init( tl_coord0,         & 
    224316   &                in_imin0, in_imax0,& 
    225317   &                in_jmin0, in_jmax0 ) 
    226318 
    227    ! close file 
    228    CALL iom_close(tl_coord0) 
    229  
    230    !4-1 add extra band (if possible) to compute interpolation 
     319   ! add extra band (if need be) to compute interpolation 
    231320   CALL dom_add_extra(tl_dom) 
    232321 
    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 
     322   ! open mpp files 
     323   CALL iom_dom_open(tl_coord0, tl_dom) 
     324 
     325   il_nvar=tl_coord0%t_proc(1)%i_nvar 
    252326   ALLOCATE( tl_var(il_nvar) ) 
    253327   DO ji=1,il_nvar 
    254328 
    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 
     329      tl_var(ji)=iom_dom_read_var(tl_coord0, & 
     330      &                          TRIM(tl_coord0%t_proc(1)%t_var(ji)%c_name),& 
     331      &                          tl_dom) 
     332 
     333      SELECT CASE(TRIM(tl_var(ji)%c_point)) 
     334         CASE('T') 
     335            jj=jp_T 
     336         CASE('U') 
     337            jj=jp_U 
     338         CASE('V') 
     339            jj=jp_V 
     340         CASE('F') 
     341            jj=jp_F 
     342      END SELECT 
     343 
     344      ! interpolate variables 
     345      CALL create_coord_interp( tl_var(ji), il_rho(:), & 
     346      &                         il_offset(:,:,jj) ) 
     347 
     348      ! remove extraband added to domain 
     349      CALL dom_del_extra( tl_var(ji), tl_dom, il_rho(:), .true. ) 
     350 
     351      ! filter 
    266352      CALL filter_fill_value(tl_var(ji))       
    267353 
    268354   ENDDO 
    269355 
    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 
     356   ! close mpp files 
     357   CALL iom_dom_close(tl_coord0) 
     358 
     359   ! clean 
     360   CALL mpp_clean(tl_coord0) 
     361 
     362   ! create file 
    277363   tl_fileout=file_init(TRIM(cn_fileout)) 
    278364 
    279    !10-1 add dimension 
     365   ! add dimension 
    280366   ! save biggest dimension 
    281367   tl_dim(:)=var_max_dim(tl_var(:)) 
    … …  
    285371   ENDDO 
    286372 
    287    !10-2 add variables 
    288  
    289    DO ji=1,il_nvar 
     373   ! add variables 
     374   DO ji=il_nvar,1,-1 
    290375      CALL file_add_var(tl_fileout, tl_var(ji)) 
     376      CALL var_clean(tl_var(ji)) 
    291377   ENDDO 
    292378 
    293    !10-3 add some attribute 
     379   ! add some attribute 
    294380   tl_att=att_init("Created_by","SIREN create_coord") 
    295381   CALL file_add_att(tl_fileout, tl_att) 
    … …  
    299385   CALL file_add_att(tl_fileout, tl_att) 
    300386 
    301    tl_att=att_init("source_file",TRIM(fct_basename(cn_coord0))) 
     387   tl_att=att_init("src_file",TRIM(fct_basename(cn_coord0))) 
    302388   CALL file_add_att(tl_fileout, tl_att)    
    303389 
    304    tl_att=att_init("source_i-indices",(/in_imin0,in_imax0/)) 
     390   tl_att=att_init("src_i_indices",(/in_imin0,in_imax0/)) 
    305391   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 
     392   tl_att=att_init("src_j_indices",(/in_jmin0,in_jmax0/)) 
     393   CALL file_add_att(tl_fileout, tl_att) 
     394   IF( .NOT. ALL(il_rho(:)==1) )THEN 
     395      tl_att=att_init("refinment_factor",(/il_rho(jp_I),il_rho(jp_J)/)) 
     396      CALL file_add_att(tl_fileout, tl_att) 
     397   ENDIF 
     398 
     399   ! add attribute periodicity 
     400   il_attid=0 
     401   IF( ASSOCIATED(tl_fileout%t_att) )THEN 
     402      il_attid=att_get_index(tl_fileout%t_att(:),'periodicity') 
     403   ENDIF 
     404   IF( tl_dom%i_perio >= 0 .AND. il_attid == 0 )THEN 
     405      tl_att=att_init('periodicity',tl_dom%i_perio) 
     406      CALL file_add_att(tl_fileout,tl_att) 
     407   ENDIF 
     408 
     409   ! add attribute east west overlap 
     410   il_attid=0 
     411   IF( ASSOCIATED(tl_fileout%t_att) )THEN 
     412      il_attid=att_get_index(tl_fileout%t_att(:),'ew_overlap') 
     413   ENDIF 
     414   IF( il_attid == 0 )THEN 
     415      il_ind=var_get_index(tl_fileout%t_var(:),'longitude') 
     416      il_ew=grid_get_ew_overlap(tl_fileout%t_var(il_ind)) 
     417      IF( il_ew >= 0 )THEN 
     418         tl_att=att_init('ew_overlap',il_ew) 
     419         CALL file_add_att(tl_fileout,tl_att) 
     420      ENDIF 
     421   ENDIF 
     422 
     423   ! create file 
    310424   CALL iom_create(tl_fileout) 
    311425 
    312    !10-5 write file 
     426   ! write file 
    313427   CALL iom_write_file(tl_fileout) 
    314428 
    315    !10-6 close file 
     429   ! close file 
    316430   CALL iom_close(tl_fileout) 
    317431 
    318    !11- clean 
    319    DO ji=1,il_nvar 
    320       CALL var_clean(tl_var(ji)) 
    321    ENDDO 
     432   ! clean 
     433   CALL att_clean(tl_att) 
     434   CALL var_clean(tl_var(:)) 
     435   DEALLOCATE( tl_var)  
     436 
    322437   CALL file_clean(tl_fileout) 
    323  
    324    DEALLOCATE( tl_var)  
    325438 
    326439   ! close log file 
    327440   CALL logger_footer() 
    328    CALL logger_close()    
    329  
    330 !> @endcode 
     441   CALL logger_close()  
     442 
    331443CONTAINS 
    332444   !------------------------------------------------------------------- 
    333445   !> @brief 
    334    !> This subroutine 
     446   !> This function compute offset over Arakawa grid points,  
     447   !> given refinement factor. 
     448   !>  
     449   !> @author J.Paul 
     450   !> @date August, 2014 - Initial Version 
     451   !> 
     452   !> @param[in] id_rho array of refinement factor 
     453   !> @return array of offset 
     454   !------------------------------------------------------------------- 
     455   FUNCTION create_coord_get_offset( id_rho ) 
     456      IMPLICIT NONE 
     457      ! Argument       
     458      INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_rho 
     459 
     460      ! function 
     461      INTEGER(i4), DIMENSION(2,2,ip_npoint) :: create_coord_get_offset 
     462      ! local variable 
     463      ! loop indices 
     464      !---------------------------------------------------------------- 
     465 
     466      ! case 'T' 
     467      create_coord_get_offset(jp_I,:,jp_T)=FLOOR(REAL(id_rho(jp_I)-1,dp)*0.5) 
     468      create_coord_get_offset(jp_J,:,jp_T)=FLOOR(REAL(id_rho(jp_J)-1,dp)*0.5) 
     469      ! case 'U' 
     470      create_coord_get_offset(jp_I,1,jp_U)=0 
     471      create_coord_get_offset(jp_I,2,jp_U)=id_rho(jp_I)-1 
     472      create_coord_get_offset(jp_J,:,jp_U)=FLOOR(REAL(id_rho(jp_J)-1,dp)*0.5) 
     473      ! case 'V' 
     474      create_coord_get_offset(jp_I,:,jp_V)=FLOOR(REAL(id_rho(jp_I)-1,dp)*0.5) 
     475      create_coord_get_offset(jp_J,1,jp_V)=0 
     476      create_coord_get_offset(jp_J,2,jp_V)=id_rho(jp_J)-1 
     477      ! case 'F' 
     478      create_coord_get_offset(jp_I,1,jp_F)=0 
     479      create_coord_get_offset(jp_I,2,jp_F)=id_rho(jp_I)-1 
     480      create_coord_get_offset(jp_J,1,jp_F)=0 
     481      create_coord_get_offset(jp_J,2,jp_F)=id_rho(jp_J)-1 
     482 
     483 
     484   END FUNCTION create_coord_get_offset 
     485   !------------------------------------------------------------------- 
     486   !> @brief 
     487   !> This subroutine interpolate variable, given refinment factor. 
    335488   !>  
    336489   !> @details  
     490   !>  Optionaly, you could specify number of points  
     491   !>    to be extrapolated in i- and j-direction.<br/> 
     492   !>  variable mask is first computed (using _FillValue) and interpolated.<br/> 
     493   !>  variable is then extrapolated, and interpolated.<br/>  
     494   !>  Finally interpolated mask is applied on refined variable. 
    337495   !> 
    338496   !> @author J.Paul 
    339    !> - Nov, 2013- Initial Version 
     497   !> @date November, 2013 - Initial Version 
    340498   !> 
    341    !> @param[in]  
    342    !> @todo  
     499   !> @param[inout] td_var variable strcuture  
     500   !> @param[in] id_rho    array of refinement factor 
     501   !> @param[in] id_offset offset between fine grid and coarse grid 
     502   !> @param[in] id_iext   number of points to be extrapolated in i-direction 
     503   !> @param[in] id_jext   number of points to be extrapolated in j-direction 
     504   !> 
     505   !> @todo check if mask is really needed 
    343506   !------------------------------------------------------------------- 
    344    !> @code 
    345507   SUBROUTINE create_coord_interp( td_var,          & 
    346508   &                               id_rho,          & 
     509   &                               id_offset,       & 
    347510   &                               id_iext, id_jext) 
    348511 
    … …  
    350513 
    351514      ! 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 
     515      TYPE(TVAR) ,                 INTENT(INOUT) :: td_var 
     516      INTEGER(i4), DIMENSION(:)  , INTENT(IN   ) :: id_rho 
     517      INTEGER(i4), DIMENSION(:,:), INTENT(IN)    :: id_offset 
     518      INTEGER(i4),                 INTENT(IN   ), OPTIONAL :: id_iext 
     519      INTEGER(i4),                 INTENT(IN   ), OPTIONAL :: id_jext 
    356520 
    357521      ! local variable 
    358522      TYPE(TVAR)  :: tl_mask 
    359       TYPE(TVAR)  :: tl_var 
    360523 
    361524      INTEGER(i1), DIMENSION(:,:,:,:), ALLOCATABLE :: bl_mask 
    362  
    363       INTEGER(i4), DIMENSION(2,2) :: il_offset 
    364525 
    365526      INTEGER(i4) :: il_iext 
    … …  
    369530      !---------------------------------------------------------------- 
    370531 
    371       ! copy variable 
    372       tl_var=td_var 
     532      IF( ANY(SHAPE(id_offset(:,:)) /= 2) )THEN 
     533         CALL logger_error("CREATE COORD INTERP: invalid dimension of "//& 
     534         &                 "offset array") 
     535      ENDIF 
    373536 
    374537      !WARNING: two extrabands are required for cubic interpolation 
    … …  
    391554      ENDIF 
    392555 
    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 
     556      IF( ANY(id_rho(:)>1) )THEN 
     557         ! work on mask 
     558         ! create mask 
     559         ALLOCATE(bl_mask(td_var%t_dim(1)%i_len, & 
     560         &                td_var%t_dim(2)%i_len, & 
     561         &                td_var%t_dim(3)%i_len, & 
     562         &                td_var%t_dim(4)%i_len) ) 
     563 
     564         bl_mask(:,:,:,:)=1 
     565         WHERE(td_var%d_value(:,:,:,:)==td_var%d_fill) bl_mask(:,:,:,:)=0       
     566 
     567         SELECT CASE(TRIM(td_var%c_point)) 
     568         CASE DEFAULT ! 'T' 
     569            tl_mask=var_init('tmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),& 
     570            &                id_ew=td_var%i_ew ) 
     571         CASE('U') 
     572            tl_mask=var_init('umask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),& 
     573            &                id_ew=td_var%i_ew ) 
     574         CASE('V') 
     575            tl_mask=var_init('vmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),& 
     576            &                id_ew=td_var%i_ew ) 
     577         CASE('F') 
     578            tl_mask=var_init('fmask',bl_mask(:,:,:,:),td_dim=td_var%t_dim(:),& 
     579            &                id_ew=td_var%i_ew ) 
     580         END SELECT          
     581 
     582         DEALLOCATE(bl_mask) 
     583 
     584         ! interpolate mask 
     585         CALL interp_fill_value( tl_mask, id_rho(:), & 
     586         &                       id_offset=id_offset(:,:) ) 
     587 
     588         ! work on variable 
     589         ! add extraband 
     590         CALL extrap_add_extrabands(td_var, il_iext, il_jext) 
     591 
     592         ! extrapolate variable 
     593         CALL extrap_fill_value( td_var ) 
     594 
     595         ! interpolate variable 
     596         CALL interp_fill_value( td_var, id_rho(:), & 
     597         &                       id_offset=id_offset(:,:)) 
     598 
     599         ! remove extraband 
     600         CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J)) 
     601 
     602         ! keep original mask  
     603         WHERE( tl_mask%d_value(:,:,:,:) == 0 ) 
     604            td_var%d_value(:,:,:,:)=td_var%d_fill 
     605         END WHERE 
     606      ENDIF 
    443607 
    444608      ! clean variable structure 
    445609      CALL var_clean(tl_mask) 
    446       CALL var_clean(tl_var) 
    447610 
    448611   END SUBROUTINE create_coord_interp 
    449    !> @endcode 
    450612END PROGRAM create_coord 
Note: See TracChangeset for help on using the changeset viewer.