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 12080 for utils/tools/SIREN/src/extrap.f90 – NEMO

Ignore:
Timestamp:
2019-12-06T10:30:14+01:00 (4 years ago)
Author:
jpaul
Message:

update nemo trunk

File:
1 edited

Legend:

Unmodified
Added
Removed

  • utils/tools/SIREN/src/extrap.f90

    r9598 r12080  
    22! NEMO system team, System and Interface for oceanic RElocable Nesting 
    33!---------------------------------------------------------------------- 
    4 ! 
    5 ! MODULE: extrap 
    64! 
    75! DESCRIPTION: 
    … …  
    5553!> @author 
    5654!> J.Paul 
    57 ! REVISION HISTORY: 
     55!> 
    5856!> @date November, 2013 - Initial Version 
    5957!> @date September, 2014 
    … …  
    7068!> - smooth extrapolated points 
    7169!> 
    72 !> @note Software governed by the CeCILL licence     (./LICENSE) 
     70!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    7371!---------------------------------------------------------------------- 
    7472MODULE extrap 
     73 
    7574   USE netcdf                          ! nf90 library 
    7675   USE kind                            ! F90 kind parameter 
    … …  
    120119    
    121120CONTAINS 
     121   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     122   FUNCTION extrap__detect(td_var0) & 
     123         &  RESULT (if_detect) 
    122124   !------------------------------------------------------------------- 
    123125   !> @brief 
    … …  
    140142   !> @date June, 2015 
    141143   !> - do not use level to select points to be extrapolated 
    142    ! 
     144   !> 
    143145   !> @param[in] td_var0   coarse grid variable to extrapolate 
    144146   !> @return array of point to be extrapolated 
    145147   !------------------------------------------------------------------- 
    146    FUNCTION extrap__detect( td_var0 )  
     148 
    147149      IMPLICIT NONE 
     150 
    148151      ! Argument 
    149       TYPE(TVAR) ,                 INTENT(IN   ) :: td_var0 
     152      TYPE(TVAR) ,                      INTENT(IN   ) :: td_var0 
    150153 
    151154      ! function 
    152155      INTEGER(i4), DIMENSION(td_var0%t_dim(1)%i_len,& 
    153156      &                      td_var0%t_dim(2)%i_len,& 
    154       &                      td_var0%t_dim(3)%i_len ) :: extrap__detect 
     157      &                      td_var0%t_dim(3)%i_len ) :: if_detect 
    155158 
    156159      ! local variable 
    … …  
    162165 
    163166      ! force to extrapolated all points 
    164       extrap__detect(:,:,:)=1 
     167      if_detect(:,:,:)=1 
    165168 
    166169      ! do not compute grid point already inform 
    … …  
    169172            DO ji0=1,td_var0%t_dim(1)%i_len 
    170173               IF( td_var0%d_value(ji0,jj0,jk0,1) /= td_var0%d_fill )THEN 
    171                   extrap__detect(ji0,jj0,jk0)=0 
     174                  if_detect(ji0,jj0,jk0)=0 
    172175               ENDIF 
    173176            ENDDO 
    … …  
    176179 
    177180   END FUNCTION extrap__detect 
     181   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     182   FUNCTION extrap__detect_wrapper(td_var) & 
     183         & RESULT (if_detect) 
    178184   !------------------------------------------------------------------- 
    179185   !> @brief 
    … …  
    189195   !> @return 3D array of point to be extrapolated 
    190196   !------------------------------------------------------------------- 
    191    FUNCTION extrap__detect_wrapper( td_var ) 
    192197 
    193198      IMPLICIT NONE 
     199 
    194200      ! Argument 
    195201      TYPE(TVAR) ,                 INTENT(IN   ) :: td_var 
    … …  
    198204      INTEGER(i4), DIMENSION(td_var%t_dim(1)%i_len,& 
    199205      &                      td_var%t_dim(2)%i_len,& 
    200       &                      td_var%t_dim(3)%i_len ) :: extrap__detect_wrapper 
     206      &                      td_var%t_dim(3)%i_len ) :: if_detect 
    201207 
    202208      ! local variable 
    … …  
    204210      !---------------------------------------------------------------- 
    205211      ! init 
    206       extrap__detect_wrapper(:,:,:)=0 
     212      if_detect(:,:,:)=0 
    207213 
    208214      IF( .NOT. ANY(td_var%t_dim(1:3)%l_use) )THEN 
    209215         ! no dimension I-J-K used 
    210216         CALL logger_debug(" EXTRAP DETECT: nothing done for variable"//& 
    211          &              TRIM(td_var%c_name) ) 
     217            &              TRIM(td_var%c_name) ) 
    212218      ELSE IF( ALL(td_var%t_dim(1:3)%l_use) )THEN 
    213219          
    214220         ! detect point to be extrapolated on I-J-K 
    215221         CALL logger_debug(" EXTRAP DETECT: detect point "//& 
    216          &              " for variable "//TRIM(td_var%c_name) ) 
     222            &              " for variable "//TRIM(td_var%c_name) ) 
    217223          
    218          extrap__detect_wrapper(:,:,:)=extrap__detect( td_var ) 
     224      if_detect(:,:,:)=extrap__detect( td_var ) 
    219225 
    220226      ELSE IF( ALL(td_var%t_dim(1:2)%l_use) )THEN 
    … …  
    222228         ! detect point to be extrapolated on I-J 
    223229         CALL logger_debug(" EXTRAP DETECT: detect horizontal point "//& 
    224          &              " for variable "//TRIM(td_var%c_name) ) 
     230            &              " for variable "//TRIM(td_var%c_name) ) 
    225231          
    226          extrap__detect_wrapper(:,:,1:1)=extrap__detect( td_var ) 
     232         if_detect(:,:,1:1)=extrap__detect( td_var ) 
    227233 
    228234      ELSE IF( td_var%t_dim(3)%l_use )THEN 
    … …  
    230236         ! detect point to be extrapolated on K 
    231237         CALL logger_debug(" EXTRAP DETECT: detect vertical point "//& 
    232          &              " for variable "//TRIM(td_var%c_name) ) 
     238            &              " for variable "//TRIM(td_var%c_name) ) 
    233239          
    234          extrap__detect_wrapper(1:1,1:1,:)=extrap__detect( td_var ) 
     240         if_detect(1:1,1:1,:)=extrap__detect( td_var ) 
    235241 
    236242      ENDIF               
    237243 
    238244      CALL logger_debug(" EXTRAP DETECT: "//& 
    239       &  TRIM(fct_str(SUM(extrap__detect_wrapper(:,:,:))))//& 
    240       &  " points to be extrapolated" ) 
     245         &  TRIM(fct_str(SUM(if_detect(:,:,:))))//& 
     246         &  " points to be extrapolated" ) 
    241247       
    242248   END FUNCTION extrap__detect_wrapper 
     249   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     250   SUBROUTINE extrap__fill_value_wrapper(td_var, id_radius) 
    243251   !------------------------------------------------------------------- 
    244252   !> @brief 
    … …  
    260268   !> @date June, 2015 
    261269   !> - select all land points for extrapolation 
    262    ! 
     270   !> 
    263271   !> @param[inout] td_var    variable structure 
    264272   !> @param[in] id_radius    radius of the halo used to compute extrapolation  
    265273   !------------------------------------------------------------------- 
    266    SUBROUTINE extrap__fill_value_wrapper( td_var, &  
    267    &                                      id_radius ) 
     274 
    268275      IMPLICIT NONE 
     276 
    269277      ! Argument 
    270278      TYPE(TVAR) ,                  INTENT(INOUT) :: td_var 
    … …  
    311319 
    312320   END SUBROUTINE extrap__fill_value_wrapper 
     321   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     322   SUBROUTINE extrap__fill_value(td_var, cd_method, id_radius) 
    313323   !------------------------------------------------------------------- 
    314324   !> @brief 
    … …  
    325335   !> @date June, 2015 
    326336   !> - select all land points for extrapolation 
    327    ! 
     337   !> 
    328338   !> @param[inout] td_var    variable structure 
    329339   !> @param[in] cd_method    extrapolation method 
    330340   !> @param[in] id_radius    radius of the halo used to compute extrapolation 
    331341   !------------------------------------------------------------------- 
    332    SUBROUTINE extrap__fill_value( td_var, cd_method, & 
    333    &                              id_radius ) 
     342 
    334343      IMPLICIT NONE 
     344 
    335345      ! Argument 
    336346      TYPE(TVAR)      ,                 INTENT(INOUT) :: td_var 
    … …  
    383393 
    384394   END SUBROUTINE extrap__fill_value 
     395   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     396   SUBROUTINE extrap__3D(dd_value, dd_fill, id_detect,& 
     397         &               cd_method, id_radius) 
    385398   !------------------------------------------------------------------- 
    386399   !> @brief 
    … …  
    401414   !> - compute coef indices to be used 
    402415   !> - bug fix: force coef indice to 1, for dimension lenth equal to 1 
    403    ! 
     416   !> 
    404417   !> @param[inout] dd_value  3D array of variable to be extrapolated 
    405418   !> @param[in] dd_fill      FillValue of variable 
    … …  
    408421   !> @param[in] id_radius    radius of the halo used to compute extrapolation 
    409422   !------------------------------------------------------------------- 
    410    SUBROUTINE extrap__3D( dd_value, dd_fill, id_detect,& 
    411    &                      cd_method, id_radius ) 
     423 
    412424      IMPLICIT NONE 
     425 
    413426      ! Argument 
    414427      REAL(dp)   , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value 
    … …  
    461474         DO jl=1,il_shape(4) 
    462475 
    463             ! intitialise table of poitn to be extrapolated 
     476            ! initialise table of point to be extrapolated 
    464477            il_detect(:,:,:)=id_detect(:,:,:) 
    465478 
    … …  
    840853 
    841854   END SUBROUTINE extrap__3D 
     855   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     856   PURE FUNCTION extrap__3D_min_error_coef(dd_value) & 
     857         & RESULT (df_value) 
    842858   !------------------------------------------------------------------- 
    843859   !> @brief 
    … …  
    852868   !> @date July, 2015  
    853869   !> - decrease weight of third dimension 
    854    ! 
     870   !> 
    855871   !> @param[in] dd_value  3D array of variable to be extrapolated 
    856872   !> @return 3D array of coefficient for minimum error extrapolation 
    857873   !------------------------------------------------------------------- 
    858    PURE FUNCTION extrap__3D_min_error_coef( dd_value ) 
    859874 
    860875      IMPLICIT NONE 
     876 
    861877      ! Argument 
    862878      REAL(dp)   , DIMENSION(:,:,:), INTENT(IN) :: dd_value 
    … …  
    865881      REAL(dp), DIMENSION(SIZE(dd_value(:,:,:),DIM=1), & 
    866882      &                   SIZE(dd_value(:,:,:),DIM=2), & 
    867       &                   SIZE(dd_value(:,:,:),DIM=3) ) :: extrap__3D_min_error_coef 
     883      &                   SIZE(dd_value(:,:,:),DIM=3) ) :: df_value 
    868884 
    869885      ! local variable 
    … …  
    883899 
    884900      ! init 
    885       extrap__3D_min_error_coef(:,:,:)=0 
     901      df_value(:,:,:)=0 
    886902 
    887903      il_shape(:)=SHAPE(dd_value(:,:,:)) 
    … …  
    912928 
    913929      WHERE( dl_dist(:,:,:) /= 0 ) 
    914          extrap__3D_min_error_coef(:,:,:)=dl_dist(:,:,:) 
     930         df_value(:,:,:)=dl_dist(:,:,:) 
    915931      END WHERE 
    916932 
    … …  
    918934 
    919935   END FUNCTION extrap__3D_min_error_coef 
     936   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     937   PURE FUNCTION extrap__3D_min_error_fill(dd_value, dd_fill, id_radius,& 
     938         &                                 dd_dfdx, dd_dfdy, dd_dfdz,   & 
     939         &                                 dd_coef) & 
     940         & RESULT (df_value) 
    920941   !------------------------------------------------------------------- 
    921942   !> @brief 
    … …  
    935956   !> @return extrapolatd value 
    936957   !------------------------------------------------------------------- 
    937    PURE FUNCTION extrap__3D_min_error_fill( dd_value, dd_fill, id_radius, & 
    938    &                                        dd_dfdx, dd_dfdy, dd_dfdz, & 
    939    &                                        dd_coef ) 
     958 
    940959      IMPLICIT NONE 
     960 
    941961      ! Argument 
    942962      REAL(dp)   , DIMENSION(:,:,:), INTENT(IN) :: dd_value 
    … …  
    949969 
    950970      ! function 
    951       REAL(dp) :: extrap__3d_min_error_fill 
     971      REAL(dp)                                  :: df_value 
    952972 
    953973      ! local variable 
    … …  
    964984 
    965985      ! init 
    966       extrap__3D_min_error_fill=dd_fill 
     986      df_value=dd_fill 
    967987 
    968988      il_min=MAX(1,(SIZE(dd_value(:,:,:)))/(1+id_radius*2)) 
    … …  
    9951015         ! return value 
    9961016         IF( ALL(il_ind(:)/=0) )THEN 
    997             extrap__3D_min_error_fill=dd_value(il_ind(1),il_ind(2),il_ind(3)) 
     1017            df_value=dd_value(il_ind(1),il_ind(2),il_ind(3)) 
    9981018         ENDIF 
    9991019 
    … …  
    10041024 
    10051025   END FUNCTION extrap__3D_min_error_fill 
     1026   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     1027   PURE FUNCTION extrap__3D_dist_weight_coef(dd_value) & 
     1028         & RESULT (df_value) 
    10061029   !------------------------------------------------------------------- 
    10071030   !> @brief 
    … …  
    10161039   !> @date July, 2015  
    10171040   !> - decrease weight of third dimension 
    1018    ! 
     1041   !> 
    10191042   !> @param[in] dd_value  3D array of variable to be extrapolated 
    10201043   !> @return 3D array of coefficient for inverse distance weighted extrapolation 
    10211044   !------------------------------------------------------------------- 
    1022    PURE FUNCTION extrap__3D_dist_weight_coef( dd_value ) 
    10231045 
    10241046      IMPLICIT NONE 
     1047 
    10251048      ! Argument 
    1026       REAL(dp)   , DIMENSION(:,:,:), INTENT(IN) :: dd_value 
     1049      REAL(dp), DIMENSION(:,:,:), INTENT(IN) :: dd_value 
    10271050 
    10281051      ! function 
    10291052      REAL(dp), DIMENSION(SIZE(dd_value(:,:,:),DIM=1), & 
    10301053      &                   SIZE(dd_value(:,:,:),DIM=2), & 
    1031       &                   SIZE(dd_value(:,:,:),DIM=3) ) :: extrap__3D_dist_weight_coef 
     1054      &                   SIZE(dd_value(:,:,:),DIM=3) ) :: df_value 
    10321055 
    10331056      ! local variable 
    … …  
    10471070 
    10481071      ! init 
    1049       extrap__3D_dist_weight_coef(:,:,:)=0 
     1072      df_value(:,:,:)=0 
    10501073 
    10511074      il_shape(:)=SHAPE(dd_value(:,:,:)) 
    … …  
    10761099 
    10771100      WHERE( dl_dist(:,:,:) /= 0 )  
    1078          extrap__3D_dist_weight_coef(:,:,:)=1./dl_dist(:,:,:) 
     1101         df_value(:,:,:)=1./dl_dist(:,:,:) 
    10791102      END WHERE 
    10801103 
    … …  
    10821105 
    10831106   END FUNCTION extrap__3D_dist_weight_coef 
     1107   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     1108   FUNCTION extrap__3D_dist_weight_fill(dd_value, dd_fill, id_radius, & 
     1109         &                              dd_coef) & 
     1110         &  RESULT (df_value) 
    10841111   !------------------------------------------------------------------- 
    10851112   !> @brief 
    … …  
    10911118   !> @author J.Paul 
    10921119   !> @date November, 2013 - Initial Version 
    1093    ! 
     1120   !> 
    10941121   !> @param[in] dd_value  3D array of variable to be extrapolated 
    10951122   !> @param[in] dd_fill   FillValue of variable 
    … …  
    10981125   !> @return extrapolatd value 
    10991126   !------------------------------------------------------------------- 
    1100    FUNCTION extrap__3D_dist_weight_fill( dd_value, dd_fill, id_radius, & 
    1101    &                                     dd_coef ) 
     1127 
    11021128      IMPLICIT NONE 
     1129 
    11031130      ! Argument 
    11041131      REAL(dp)   , DIMENSION(:,:,:), INTENT(IN) :: dd_value 
    … …  
    11081135 
    11091136      ! function 
    1110       REAL(dp) :: extrap__3D_dist_weight_fill 
     1137      REAL(dp)                                  :: df_value 
    11111138 
    11121139      ! local variable 
    … …  
    11241151 
    11251152      ! init 
    1126       extrap__3D_dist_weight_fill=dd_fill 
     1153      df_value=dd_fill 
    11271154 
    11281155      il_min=MAX(1,(SIZE(dd_value(:,:,:)))/(1+id_radius*2)) 
    … …  
    11541181         ! return value 
    11551182         IF( SUM( dl_coef(:,:,:) ) /= 0 )THEN 
    1156             extrap__3D_dist_weight_fill = & 
    1157             &  SUM( dl_value(:,:,:) )/SUM( dl_coef(:,:,:) ) 
     1183            df_value = SUM( dl_value(:,:,:) )/SUM( dl_coef(:,:,:) ) 
    11581184         ENDIF 
    11591185 
    … …  
    11641190 
    11651191   END FUNCTION extrap__3D_dist_weight_fill 
     1192   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     1193   SUBROUTINE extrap_add_extrabands(td_var, id_isize, id_jsize) 
    11661194   !------------------------------------------------------------------- 
    11671195   !> @brief 
    … …  
    11741202   !> @author J.Paul 
    11751203   !> @date November, 2013 - Initial version 
    1176    ! 
     1204   !> 
    11771205   !> @param[inout] td_var variable  
    11781206   !> @param[in] id_isize  i-direction size of extra bands (default=im_minext) 
    … …  
    11811209   !> - invalid special case for grid with north fold 
    11821210   !------------------------------------------------------------------- 
    1183    SUBROUTINE extrap_add_extrabands(td_var, id_isize, id_jsize ) 
     1211 
    11841212      IMPLICIT NONE 
     1213 
    11851214      ! Argument 
    11861215      TYPE(TVAR) , INTENT(INOUT)  :: td_var 
    … …  
    12661295 
    12671296   END SUBROUTINE extrap_add_extrabands 
     1297   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     1298   SUBROUTINE extrap_del_extrabands(td_var, id_isize, id_jsize) 
    12681299   !------------------------------------------------------------------- 
    12691300   !> @brief 
    … …  
    12811312   !> @param[in] id_jsize  j-direction size of extra bands (default=im_minext) 
    12821313   !------------------------------------------------------------------- 
    1283    SUBROUTINE extrap_del_extrabands(td_var, id_isize, id_jsize ) 
     1314 
    12841315      IMPLICIT NONE 
     1316 
    12851317      ! Argument 
    12861318      TYPE(TVAR) , INTENT(INOUT) :: td_var 
    … …  
    13471379 
    13481380   END SUBROUTINE extrap_del_extrabands 
     1381   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    13491382END MODULE extrap 
Note: See TracChangeset for help on using the changeset viewer.