Changeset 5609
- Timestamp:
- 2015-07-17T17:42:15+02:00 (8 years ago)
- Location:
- trunk/NEMOGCM/TOOLS/SIREN
- Files:
-
- 2 added
- 33 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/TOOLS/SIREN/src/attribute.f90
r5037 r5609 81 81 ! REVISION HISTORY: 82 82 !> @date November, 2013 - Initial Version 83 !> @date November, 2014 - Fix memory leaks bug 83 !> @date November, 2014 84 !> - Fix memory leaks bug 84 85 ! 85 86 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 130 131 INTEGER(i4) :: i_type = 0 !< attribute type 131 132 INTEGER(i4) :: i_len = 0 !< number of value store in attribute 132 CHARACTER(LEN=lc) :: c_value = "none"!< attribute value if type CHAR133 CHARACTER(LEN=lc) :: c_value = 'none' !< attribute value if type CHAR 133 134 REAL(dp), DIMENSION(:), POINTER :: d_value => NULL() !< attribute value if type SHORT,INT,FLOAT or DOUBLE 134 135 END TYPE TATT 135 136 136 137 INTERFACE att_init 137 MODULE PROCEDURE att__init_c 138 MODULE PROCEDURE att__init_c 138 139 MODULE PROCEDURE att__init_dp 139 140 MODULE PROCEDURE att__init_dp_0d … … 181 182 !> @date November, 2013 - Initial Version 182 183 !> @date November, 2014 183 !> 184 !> - use function instead of overload assignment operator 184 185 !> (to avoid memory leak) 185 186 ! … … 234 235 235 236 ! local variable 236 REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value237 REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value 237 238 !---------------------------------------------------------------- 238 239 … … 300 301 !> @author J.Paul 301 302 !> @date November, 2013 - Initial Version 302 !> @date September, 2014 - bug fix with use of id read from attribute structure 303 ! 303 !> @date September, 2014 304 !> - bug fix with use of id read from attribute structure 305 !> 304 306 !> @param[in] td_att array of attribute structure 305 307 !> @param[in] cd_name attribute name … … 355 357 356 358 att__init_c%c_name=TRIM(ADJUSTL(cd_name)) 357 358 359 att__init_c%i_type=NF90_CHAR 360 359 361 att__init_c%c_value=TRIM(ADJUSTL(cd_value)) 360 362 att__init_c%i_len=LEN( TRIM(ADJUSTL(cd_value)) ) … … 1068 1070 !> @author J.Paul 1069 1071 !> @date November, 2013 - Initial Version 1070 !> @date September, 2014 - take into account type of attribute. 1072 !> @date September, 2014 1073 !> - take into account type of attribute. 1071 1074 ! 1072 1075 !> @param[in] td_att attribute structure … … 1114 1117 1115 1118 CASE(NF90_CHAR) 1119 1116 1120 cl_value=td_att%c_value 1117 1121 -
trunk/NEMOGCM/TOOLS/SIREN/src/boundary.f90
r5037 r5609 26 26 !> - ld_west is logical to force used of north boundary [optional] 27 27 !> - cd_north is string character description of north boundary [optional] 28 !> - cd_south is string character description of north boundary [optional]29 !> - cd_east is string character description of northboundary [optional]30 !> - cd_west is string character description of northboundary [optional]28 !> - cd_south is string character description of south boundary [optional] 29 !> - cd_east is string character description of east boundary [optional] 30 !> - cd_west is string character description of west boundary [optional] 31 31 !> - ld_oneseg is logical to force to use only one segment for each boundary [optional] 32 32 !> … … 36 36 !> to know if boundary is use:<br/> 37 37 !> - tl_bdy\%l_use 38 !> 39 !> to know if boundary come from namelist (cn_north,..):<br/> 40 !> - tl_bdy\%l_nam 38 41 !> 39 42 !> to get the number of segment in boundary:<br/> … … 105 108 ! REVISION HISTORY: 106 109 !> @date November, 2013 - Initial Version 107 !> @date September, 2014 - add boundary description 108 !> @date November, 2014 - Fix memory leaks bug 110 !> @date September, 2014 111 !> - add boundary description 112 !> @date November, 2014 113 !> - Fix memory leaks bug 114 !> @date February, 2015 115 !> - Do not change indices read from namelist 116 !> - Change string character format of boundary read from namelist, 117 !> see boundary__get_info 109 118 !> 110 119 !> @todo add schematic to boundary structure description … … 157 166 PRIVATE :: seg__init ! initialise segment structure 158 167 PRIVATE :: seg__clean ! clean segment structure 159 PRIVATE :: seg__clean_unit ! clean segment structure168 PRIVATE :: seg__clean_unit ! clean one segment structure 160 169 PRIVATE :: seg__clean_arr ! clean array of segment structure 161 170 PRIVATE :: seg__copy ! copy segment structure in another … … 173 182 CHARACTER(LEN=lc) :: c_card = '' !< boundary cardinal 174 183 LOGICAL :: l_use = .FALSE. !< boundary use or not 184 LOGICAL :: l_nam = .FALSE. !< boundary get from namelist 175 185 INTEGER(i4) :: i_nseg = 0 !< number of segment in boundary 176 186 TYPE(TSEG), DIMENSION(:), POINTER :: t_seg => NULL() !< array of segment structure 177 187 END TYPE TBDY 178 188 189 ! module variable 179 190 INTEGER(i4), PARAMETER :: im_width=10 180 191 … … 223 234 !> @date November, 2013 - Initial Version 224 235 !> @date November, 2014 225 !> 236 !> - use function instead of overload assignment operator 226 237 !> (to avoid memory leak) 227 238 ! … … 260 271 !> @date November, 2013 - Initial Version 261 272 !> @date November, 2014 262 !> 273 !> - use function instead of overload assignment operator 263 274 !> (to avoid memory leak) 264 275 ! … … 353 364 END SUBROUTINE boundary__clean_arr 354 365 !------------------------------------------------------------------- 355 !> @brief This function put cardinal name inside file name.366 !> @brief This function put cardinal name and date inside file name. 356 367 ! 357 368 !> @details 358 ! 369 !> Examples : 370 !> cd_file="boundary.nc" 371 !> cd_card="west" 372 !> id_seg =2 373 !> cd_date=y2015m07d16 374 !> 375 !> function return "boundary_west_2_y2015m07d16.nc" 376 !> 377 !> cd_file="boundary.nc" 378 !> cd_card="west" 379 !> 380 !> function return "boundary_west.nc" 381 !> 359 382 !> @author J.Paul 360 383 !> @date November, 2013 - Initial Version … … 385 408 CHARACTER(LEN=lc) :: cl_date 386 409 CHARACTER(LEN=lc) :: cl_name 410 411 INTEGER(i4) :: il_ind 412 INTEGER(i4) :: il_indend 413 387 414 ! loop indices 388 415 !---------------------------------------------------------------- … … 400 427 cl_suffix=fct_split(TRIM(cl_basename),2,'.') 401 428 429 ! add segment number 402 430 IF( PRESENT(id_seg) )THEN 403 cl_segnum="_"//TRIM(fct_str(id_seg)) //"_"431 cl_segnum="_"//TRIM(fct_str(id_seg)) 404 432 ELSE 405 433 cl_segnum="" 406 434 ENDIF 407 435 436 ! add date 408 437 IF( PRESENT(cd_date) )THEN 409 cl_date= TRIM(ADJUSTL(cd_date))438 cl_date="_"//TRIM(ADJUSTL(cd_date)) 410 439 ELSE 411 440 cl_date="" 412 441 ENDIF 413 442 414 cl_name=TRIM(cl_base)//"_"//TRIM(cd_card)//TRIM(cl_segnum)//& 415 & TRIM(cl_date)//"."//TRIM(cl_suffix) 443 ! special case for obcdta 444 il_ind=INDEX(cl_base,'_obcdta_') 445 IF( il_ind/=0 )THEN 446 il_ind=il_ind-1+8 447 il_indend=LEN_TRIM(cl_base) 448 449 cl_name=TRIM(cl_base(1:il_ind))//TRIM(cd_card)//& 450 & TRIM(cl_segnum)//"_"//TRIM(cl_base(il_ind+1:il_indend))//& 451 & TRIM(cl_date)//"."//TRIM(cl_suffix) 452 ELSE 453 cl_name=TRIM(cl_base)//"_"//TRIM(cd_card)//TRIM(cl_segnum)//& 454 & TRIM(cl_date)//"."//TRIM(cl_suffix) 455 ENDIF 416 456 417 457 boundary_set_filename=TRIM(cl_dirname)//"/"//TRIM(cl_name) … … 442 482 !> ex : cn_north='index1,first1,last1(width)|index2,first2,last2' 443 483 !> 444 !> @note boundaries are compute on T point. change will be done to get data445 !> on other point when need be.484 !> @note Boundaries are compute on T point, but expressed on U,V point. 485 !> change will be done to get data on other point when need be. 446 486 !> 447 487 !> @author J.Paul … … 581 621 582 622 ! get namelist information 583 tl_tmp=boundary__get_info(cl_card(jk)) 623 tl_tmp=boundary__get_info(cl_card(jk),jk) 624 625 ! get segments indices 584 626 DO ji=1,tl_tmp%i_nseg 585 627 CALL boundary__add_seg(tl_bdy(jk),tl_tmp%t_seg(ji)) 586 628 ENDDO 629 ! indices from namelist or not 630 tl_bdy(jk)%l_nam=tl_tmp%l_nam 631 587 632 CALL boundary_clean(tl_tmp) 588 633 … … 642 687 !> @return boundary structure 643 688 !------------------------------------------------------------------- 644 FUNCTION boundary__init( cd_card, ld_use, td_seg )689 FUNCTION boundary__init( cd_card, ld_use, ld_nam, td_seg ) 645 690 IMPLICIT NONE 646 691 ! Argument 647 692 CHARACTER(LEN=*), INTENT(IN) :: cd_card 648 693 LOGICAL , INTENT(IN), OPTIONAL :: ld_use 694 LOGICAL , INTENT(IN), OPTIONAL :: ld_nam 649 695 TYPE(TSEG) , INTENT(IN), OPTIONAL :: td_seg 650 696 … … 664 710 boundary__init%l_use=.TRUE. 665 711 IF( PRESENT(ld_use) ) boundary__init%l_use=ld_use 712 713 boundary__init%l_nam=.FALSE. 714 IF( PRESENT(ld_nam) ) boundary__init%l_nam=ld_nam 666 715 667 716 IF( PRESENT(td_seg) )THEN … … 778 827 !> orthogonal index, first and last indices, of each segment. 779 828 !> And also the width of all segments of this boundary. 780 !> cn_north='index1,first1 ,last1(width)|index2,first2,last2'829 !> cn_north='index1,first1:last1(width)|index2,first2:last2' 781 830 !> 782 831 !> @author J.Paul 783 832 !> @date November, 2013 - Initial Version 833 !> @date february, 2015 834 !> - do not change indices read from namelist 835 !> - change format cn_north 784 836 ! 785 837 !> @param[in] cd_card boundary description 838 !> @param[in] id_jcard boundary index 786 839 !> @return boundary structure 787 840 !------------------------------------------------------------------- 788 FUNCTION boundary__get_info(cd_card )841 FUNCTION boundary__get_info(cd_card, id_jcard) 789 842 IMPLICIT NONE 790 843 ! Argument 791 844 CHARACTER(LEN=lc), INTENT(IN) :: cd_card 845 INTEGER(i4) , INTENT(IN) :: id_jcard 792 846 793 847 ! function … … 802 856 CHARACTER(LEN=lc) :: cl_index 803 857 CHARACTER(LEN=lc) :: cl_width 858 CHARACTER(LEN=lc) :: cl_tmp 804 859 CHARACTER(LEN=lc) :: cl_first 805 860 CHARACTER(LEN=lc) :: cl_last … … 818 873 ! width should be the same for all segment of one boundary 819 874 IF( TRIM(cl_seg) /= '' )THEN 875 876 ! initialise boundary 877 ! temporaty boundary, so it doesn't matter which caridnal is used 878 boundary__get_info=boundary__init('north',ld_nam=.TRUE.) 879 820 880 il_ind1=SCAN(fct_lower(cl_seg),'(') 821 881 IF( il_ind1 /=0 )THEN … … 831 891 ENDIF 832 892 ENDIF 893 833 894 ENDIF 834 895 … … 839 900 il_ind1=SCAN(fct_lower(cl_index),'(') 840 901 IF( il_ind1 /=0 )THEN 841 il_ind2=SCAN(fct_lower(cl_index),' (')902 il_ind2=SCAN(fct_lower(cl_index),')') 842 903 IF( il_ind2 /=0 )THEN 843 904 cl_index=TRIM(cl_index(:il_ind1-1))//TRIM(cl_index(il_ind2+1:)) … … 848 909 ENDIF 849 910 850 cl_first=fct_split(cl_seg,2,',') 911 912 cl_tmp=fct_split(cl_seg,2,',') 913 914 915 cl_first=fct_split(cl_tmp,1,':') 851 916 ! remove potential width information 852 917 il_ind1=SCAN(fct_lower(cl_first),'(') 853 918 IF( il_ind1 /=0 )THEN 854 il_ind2=SCAN(fct_lower(cl_first),' (')919 il_ind2=SCAN(fct_lower(cl_first),')') 855 920 IF( il_ind2 /=0 )THEN 856 921 cl_first=TRIM(cl_first(:il_ind1-1))//TRIM(cl_first(il_ind2+1:)) … … 861 926 ENDIF 862 927 863 cl_last =fct_split(cl_ seg,3,',')928 cl_last =fct_split(cl_tmp,2,':') 864 929 ! remove potential width information 865 930 il_ind1=SCAN(fct_lower(cl_last),'(') 866 931 IF( il_ind1 /=0 )THEN 867 il_ind2=SCAN(fct_lower(cl_last),' (')932 il_ind2=SCAN(fct_lower(cl_last),')') 868 933 IF( il_ind2 /=0 )THEN 869 934 cl_last=TRIM(cl_last(:il_ind1-1))//TRIM(cl_last(il_ind2+1:)) … … 879 944 IF( TRIM(cl_first) /= '' ) READ(cl_first,*) tl_seg%i_first 880 945 IF( TRIM(cl_last) /= '' ) READ(cl_last ,*) tl_seg%i_last 946 947 ! index expressed on U,V point, move on T point. 948 SELECT CASE(id_jcard) 949 CASE(jp_north, jp_east) 950 tl_seg%i_index=tl_seg%i_index+1 951 END SELECT 881 952 882 953 IF( (tl_seg%i_first == 0 .AND. tl_seg%i_last == 0) .OR. & … … 943 1014 944 1015 DO jk=1,ip_ncard 945 IF( .NOT. td_bdy(jk)%l_use .OR. td_bdy(jk)% i_nseg > 1)THEN1016 IF( .NOT. td_bdy(jk)%l_use .OR. td_bdy(jk)%l_nam )THEN 946 1017 ! nothing to be done 947 1018 ELSE … … 1480 1551 il_max(jp_east )=td_var%t_dim(2)%i_len 1481 1552 il_max(jp_west )=td_var%t_dim(2)%i_len 1482 1553 1483 1554 il_maxindex(jp_north)=td_var%t_dim(2)%i_len-ip_ghost 1484 1555 il_maxindex(jp_south)=td_var%t_dim(2)%i_len-ip_ghost … … 1515 1586 ENDIF 1516 1587 ENDDO 1517 1588 1518 1589 CALL boundary_check_corner(td_bdy, td_var) 1519 1590 … … 1650 1721 !> @date November, 2013 - Initial Version 1651 1722 !> @date November, 2014 1652 !> 1723 !> - use function instead of overload assignment operator 1653 1724 !> (to avoid memory leak) 1654 1725 ! … … 1687 1758 !> @date November, 2013 - Initial Version 1688 1759 !> @date November, 2014 1689 !> 1760 !> - use function instead of overload assignment operator 1690 1761 !> (to avoid memory leak) 1691 1762 ! -
trunk/NEMOGCM/TOOLS/SIREN/src/create_bathy.f90
r5037 r5609 20 20 !> ./SIREN/bin/create_bathy create_bathy.nam 21 21 !> @endcode 22 !> 22 !> <br/> 23 !> \image html bathy_40.png 24 !> \image latex bathy_30.png 25 !> 26 !> @note 27 !> you could find a template of the namelist in templates directory. 28 !> 23 29 !> create_bathy.nam comprise 7 namelists:<br/> 24 30 !> - logger namelist (namlog) … … 37 43 !> - cn_logfile : log filename 38 44 !> - cn_verbosity : verbosity ('trace','debug','info', 39 !> 'warning','error','fatal' )45 !> 'warning','error','fatal','none') 40 46 !> - in_maxerror : maximum number of error allowed 41 47 !> … … 52 58 !> - cn_coord1 : coordinate file 53 59 !> - in_perio1 : periodicity index 54 !> - ln_fillclosed : fill closed sea or not 60 !> - ln_fillclosed : fill closed sea or not (default is .TRUE.) 55 61 !> 56 62 !> * _variable namelist (namvar)_:<br/> 57 63 !> - cn_varinfo : list of variable and extra information about request(s) 58 64 !> to be used.<br/> 59 !> each elements of *cn_varinfo* is a string character.<br/> 65 !> each elements of *cn_varinfo* is a string character 66 !> (separated by ',').<br/> 60 67 !> it is composed of the variable name follow by ':', 61 68 !> then request(s) to be used on this variable.<br/> 62 69 !> request could be: 63 !> - interpolation method 64 !> - extrapolation method 65 !> - filter method 66 !> - > minimum value 67 !> - < maximum value 70 !> - int = interpolation method 71 !> - ext = extrapolation method 72 !> - flt = filter method 73 !> - min = minimum value 74 !> - max = maximum value 75 !> - unt = new units 76 !> - unf = unit scale factor (linked to new units) 68 77 !> 69 78 !> requests must be separated by ';'.<br/> … … 72 81 !> informations about available method could be find in @ref interp, 73 82 !> @ref extrap and @ref filter modules.<br/> 74 !> Example: 'Bathymetry: 2*hamming(2,3); >0'83 !> Example: 'Bathymetry: flt=2*hamming(2,3); min=0' 75 84 !> @note 76 85 !> If you do not specify a method which is required, … … 90 99 !> - ',' for line 91 100 !> - '/' for row 92 !> - '\' for level<br/>93 101 !> Example:<br/> 94 102 !> 3,2,3/1,4,5 => @f$ \left( \begin{array}{ccc} … … 99 107 !> - 'Bathymetry:gridT.nc' 100 108 !> - 'Bathymetry:5000,5000,5000/5000,3000,5000/5000,5000,5000' 101 !>102 !> \image html bathy_40.png103 !> \image latex bathy_30.png104 109 !> 105 110 !> * _nesting namelist (namnst)_:<br/> … … 119 124 !> - add header for user 120 125 !> - Bug fix, compute offset depending of grid point 126 !> @date June, 2015 127 !> - extrapolate all land points. 128 !> - allow to change unit. 121 129 ! 130 !> @todo 131 !> - use create_bathy_check_depth as in create_boundary 132 !> - use create_bathy_check_time as in create_boundary 133 !> - check tl_multi is not empty 134 !> 122 135 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 123 136 !---------------------------------------------------------------------- … … 482 495 ENDIF 483 496 497 ! use additional request 484 498 DO jk=1,tl_multi%i_nvar 499 500 ! change unit and apply factor 501 CALL var_chg_unit(tl_var(jk)) 502 485 503 ! forced min and max value 486 504 CALL var_limit_value(tl_var(jk)) … … 557 575 558 576 ! add other variables 559 DO jk= 1,tl_multi%i_nvar577 DO jk=tl_multi%i_nvar,1,-1 560 578 CALL file_add_var(tl_fileout, tl_var(jk)) 561 579 CALL var_clean(tl_var(jk)) … … 897 915 IMPLICIT NONE 898 916 ! Argument 899 TYPE(TVAR) , INTENT(IN) :: td_var900 TYPE(TMPP) , INTENT(IN) :: td_mpp901 INTEGER(i4) , INTENT(IN) :: id_imin902 INTEGER(i4) , INTENT(IN) :: id_imax903 INTEGER(i4) , INTENT(IN) :: id_jmin904 INTEGER(i4) , INTENT(IN) :: id_jmax917 TYPE(TVAR) , INTENT(IN) :: td_var 918 TYPE(TMPP) , INTENT(IN) :: td_mpp 919 INTEGER(i4) , INTENT(IN) :: id_imin 920 INTEGER(i4) , INTENT(IN) :: id_imax 921 INTEGER(i4) , INTENT(IN) :: id_jmin 922 INTEGER(i4) , INTENT(IN) :: id_jmax 905 923 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_offset 906 924 INTEGER(i4), DIMENSION(:) , INTENT(IN) :: id_rho … … 1073 1091 1074 1092 ! extrapolate variable 1075 CALL extrap_fill_value( td_var, id_offset=id_offset(:,:), & 1076 & id_rho=id_rho(:), & 1077 & id_iext=il_iext, id_jext=il_jext ) 1093 CALL extrap_fill_value( td_var ) 1078 1094 1079 1095 ! interpolate Bathymetry -
trunk/NEMOGCM/TOOLS/SIREN/src/create_boundary.f90
r5037 r5609 23 23 !> ./SIREN/bin/create_boundary create_boundary.nam 24 24 !> @endcode 25 !> 25 !> <br/> 26 !> \image html boundary_NEATL36_70.png 27 !> \image latex boundary_NEATL36_70.png 28 !> 29 !> @note 30 !> you could find a template of the namelist in templates directory. 31 !> 26 32 !> create_boundary.nam comprise 9 namelists:<br/> 27 33 !> - logger namelist (namlog) … … 42 48 !> - cn_logfile : log filename 43 49 !> - cn_verbosity : verbosity ('trace','debug','info', 44 !> 'warning','error','fatal' )50 !> 'warning','error','fatal','none') 45 51 !> - in_maxerror : maximum number of error allowed 46 52 !> … … 79 85 !> * _variable namelist (namvar)_:<br/> 80 86 !> - cn_varinfo : list of variable and extra information about request(s) 81 !> to be used.<br/>87 !> to be used (separated by ',').<br/> 82 88 !> each elements of *cn_varinfo* is a string character.<br/> 83 89 !> it is composed of the variable name follow by ':', 84 90 !> then request(s) to be used on this variable.<br/> 85 91 !> request could be: 86 !> - interpolation method 87 !> - extrapolation method 88 !> - filter method 92 !> - int = interpolation method 93 !> - ext = extrapolation method 94 !> - flt = filter method 95 !> - unt = new units 96 !> - unf = unit scale factor (linked to new units) 89 97 !> 90 98 !> requests must be separated by ';'.<br/> … … 94 102 !> @ref extrap and @ref filter.<br/> 95 103 !> 96 !> Example: 'votemper: linear;hann;dist_weight', 'vosaline:cubic'104 !> Example: 'votemper:int=linear;flt=hann;ext=dist_weight', 'vosaline:int=cubic' 97 105 !> @note 98 106 !> If you do not specify a method which is required, … … 136 144 !> segments are separated by '|'.<br/> 137 145 !> each segments of the boundary is composed of: 138 !> - orthogonal indice (.ie. for north boundary,139 !> J-indice where boundary are).140 !> - first indice of boundary(I-indice for north boundary)141 !> - last indice of boundary(I-indice for north boundary)<br/>142 !> indices must be separated by ' ,' .<br/>146 !> - indice of velocity (orthogonal to boundary .ie. 147 !> for north boundary, J-indice). 148 !> - indice of segemnt start (I-indice for north boundary) 149 !> - indice of segment end (I-indice for north boundary)<br/> 150 !> indices must be separated by ':' .<br/> 143 151 !> - optionally, boundary size could be added between '(' and ')' 144 152 !> in the first segment defined. … … 147 155 !> 148 156 !> Examples: 149 !> - cn_north='index1,first1,last1(width)' 150 !> - cn_north='index1(width),first1,last1|index2,first2,last2' 151 !> 152 !> \image html boundary_50.png 153 !> \image latex boundary_50.png 154 !> 157 !> - cn_north='index1,first1:last1(width)' 158 !> - cn_north='index1(width),first1:last1|index2,first2:last2' 159 !> \image html boundary_50.png 160 !> \image latex boundary_50.png 155 161 !> - cn_south : south boundary indices on fine grid 156 162 !> - cn_east : east boundary indices on fine grid 157 163 !> - cn_west : west boundary indices on fine grid 158 164 !> - ln_oneseg : use only one segment for each boundary or not 159 !> - in_extrap : number of mask point to be extrapolated 160 !> 161 !> * _output namelist (namout)_:<br/> 165 !> 166 !> * _output namelist (namout)_:<br/> 162 167 !> - cn_fileout : fine grid boundary basename 163 168 !> (cardinal and segment number will be automatically added) 169 !> - dn_dayofs : date offset in day (change only ouput file name) 170 !> - ln_extrap : extrapolate land point or not 171 !> 172 !> Examples: 173 !> - cn_fileout=boundary.nc<br/> 174 !> if time_counter (16/07/2015 00h) is read on input file (see varfile), 175 !> west boundary will be named boundary_west_y2015m07d16 176 !> - dn_dayofs=-2.<br/> 177 !> if you use day offset you get boundary_west_y2015m07d14 178 !> 164 179 !> 165 180 !> @author J.Paul … … 169 184 !> - add header for user 170 185 !> - take into account grid point to compue boundaries 171 !> - reorder output dimension for north and south boundaries 186 !> - reorder output dimension for north and south boundaries 187 !> @date June, 2015 188 !> - extrapolate all land points, and add ln_extrap in namelist. 189 !> - allow to change unit. 190 !> @date July, 2015 191 !> - add namelist parameter to shift date of output file name. 172 192 !> 173 193 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 191 211 USE dom ! domain manager 192 212 USE grid ! grid manager 193 USE vgrid ! v artical grid manager213 USE vgrid ! vertical grid manager 194 214 USE extrap ! extrapolation manager 195 215 USE interp ! interpolation manager … … 213 233 INTEGER(i4) :: il_status 214 234 INTEGER(i4) :: il_fileid 215 INTEGER(i4) :: il_dim216 235 INTEGER(i4) :: il_imin0 217 236 INTEGER(i4) :: il_imax0 … … 239 258 240 259 TYPE(TDIM) , DIMENSION(ip_maxdim) :: tl_dim 260 261 TYPE(TDATE) :: tl_date 241 262 242 263 TYPE(TBDY) , DIMENSION(ip_ncard) :: tl_bdy … … 265 286 ! namelist variable 266 287 ! namlog 267 CHARACTER(LEN=lc) 268 CHARACTER(LEN=lc) 269 INTEGER(i4) 288 CHARACTER(LEN=lc) :: cn_logfile = 'create_boundary.log' 289 CHARACTER(LEN=lc) :: cn_verbosity = 'warning' 290 INTEGER(i4) :: in_maxerror = 5 270 291 271 292 ! namcfg 272 CHARACTER(LEN=lc) 293 CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 273 294 274 295 ! namcrs 275 CHARACTER(LEN=lc) 276 INTEGER(i4) 296 CHARACTER(LEN=lc) :: cn_coord0 = '' 297 INTEGER(i4) :: in_perio0 = -1 277 298 278 299 ! namfin 279 CHARACTER(LEN=lc) 280 CHARACTER(LEN=lc) 281 INTEGER(i4) 300 CHARACTER(LEN=lc) :: cn_coord1 = '' 301 CHARACTER(LEN=lc) :: cn_bathy1 = '' 302 INTEGER(i4) :: in_perio1 = -1 282 303 283 304 !namzgr 284 INTEGER(i4) :: in_nlevel = 75 305 REAL(dp) :: dn_pp_to_be_computed = 0._dp 306 REAL(dp) :: dn_ppsur = -3958.951371276829_dp 307 REAL(dp) :: dn_ppa0 = 103.9530096000000_dp 308 REAL(dp) :: dn_ppa1 = 2.4159512690000_dp 309 REAL(dp) :: dn_ppa2 = 100.7609285000000_dp 310 REAL(dp) :: dn_ppkth = 15.3510137000000_dp 311 REAL(dp) :: dn_ppkth2 = 48.0298937200000_dp 312 REAL(dp) :: dn_ppacr = 7.0000000000000_dp 313 REAL(dp) :: dn_ppacr2 = 13.000000000000_dp 314 REAL(dp) :: dn_ppdzmin = 6._dp 315 REAL(dp) :: dn_pphmax = 5750._dp 316 INTEGER(i4) :: in_nlevel = 75 317 318 !namzps 319 REAL(dp) :: dn_e3zps_min = 25._dp 320 REAL(dp) :: dn_e3zps_rat = 0.2_dp 285 321 286 322 ! namvar … … 289 325 290 326 ! namnst 291 INTEGER(i4) 292 INTEGER(i4) 327 INTEGER(i4) :: in_rhoi = 0 328 INTEGER(i4) :: in_rhoj = 0 293 329 294 330 ! nambdy 295 LOGICAL :: ln_north = .TRUE. 296 LOGICAL :: ln_south = .TRUE. 297 LOGICAL :: ln_east = .TRUE. 298 LOGICAL :: ln_west = .TRUE. 299 CHARACTER(LEN=lc) :: cn_north = '' 300 CHARACTER(LEN=lc) :: cn_south = '' 301 CHARACTER(LEN=lc) :: cn_east = '' 302 CHARACTER(LEN=lc) :: cn_west = '' 303 LOGICAL :: ln_oneseg = .TRUE. 304 INTEGER(i4) :: in_extrap = 0 331 LOGICAL :: ln_north = .TRUE. 332 LOGICAL :: ln_south = .TRUE. 333 LOGICAL :: ln_east = .TRUE. 334 LOGICAL :: ln_west = .TRUE. 335 CHARACTER(LEN=lc) :: cn_north = '' 336 CHARACTER(LEN=lc) :: cn_south = '' 337 CHARACTER(LEN=lc) :: cn_east = '' 338 CHARACTER(LEN=lc) :: cn_west = '' 339 LOGICAL :: ln_oneseg = .TRUE. 305 340 306 341 ! namout 307 CHARACTER(LEN=lc) :: cn_fileout = 'boundary.nc' 342 CHARACTER(LEN=lc) :: cn_fileout = 'boundary.nc' 343 REAL(dp) :: dn_dayofs = 0._dp 344 LOGICAL :: ln_extrap = .FALSE. 308 345 !------------------------------------------------------------------- 309 346 … … 319 356 & cn_coord0, & !< coordinate file 320 357 & in_perio0 !< periodicity index 321 358 322 359 NAMELIST /namfin/ & !< fine grid namelist 323 360 & cn_coord1, & !< coordinate file … … 326 363 327 364 NAMELIST /namzgr/ & 328 & in_nlevel 365 & dn_pp_to_be_computed, & 366 & dn_ppsur, & 367 & dn_ppa0, & 368 & dn_ppa1, & 369 & dn_ppa2, & 370 & dn_ppkth, & 371 & dn_ppkth2, & 372 & dn_ppacr, & 373 & dn_ppacr2, & 374 & dn_ppdzmin, & 375 & dn_pphmax, & 376 & in_nlevel !< number of vertical level 377 378 NAMELIST /namzps/ & 379 & dn_e3zps_min, & 380 & dn_e3zps_rat 329 381 330 382 NAMELIST /namvar/ & !< variable namelist 331 383 & cn_varinfo, & !< list of variable and method to apply on. (ex: 'votemper:linear','vosaline:cubic' ) 332 384 & cn_varfile !< list of variable and file where find it. (ex: 'votemper:GLORYS_gridT.nc' ) 333 385 334 386 NAMELIST /namnst/ & !< nesting namelist 335 387 & in_rhoi, & !< refinement factor in i-direction … … 345 397 & cn_east , & !< east boundary indices on fine grid 346 398 & cn_west , & !< west boundary indices on fine grid 347 & ln_oneseg, & !< use only one segment for each boundary or not 348 & in_extrap !< number of mask point to be extrapolated 399 & ln_oneseg !< use only one segment for each boundary or not 349 400 350 401 NAMELIST /namout/ & !< output namelist 351 & cn_fileout !< fine grid boundary file basename 402 & cn_fileout, & !< fine grid boundary file basename 403 & dn_dayofs, & !< date offset in day (change only ouput file name) 404 & ln_extrap !< extrapolate or not 352 405 !------------------------------------------------------------------- 353 406 … … 448 501 ! check 449 502 ! check output file do not already exist 503 ! WARNING: do not work when use time to create output file name 450 504 DO jk=1,ip_ncard 451 505 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 452 506 & TRIM(cp_card(jk)), 1 ) 507 INQUIRE(FILE=TRIM(cl_bdyout), EXIST=ll_exist) 508 IF( ll_exist )THEN 509 CALL logger_fatal("CREATE BOUNDARY: output file "//TRIM(cl_bdyout)//& 510 & " already exist.") 511 ENDIF 512 513 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 514 & TRIM(cp_card(jk)) ) 453 515 INQUIRE(FILE=TRIM(cl_bdyout), EXIST=ll_exist) 454 516 IF( ll_exist )THEN … … 490 552 491 553 CALL iom_mpp_open(tl_bathy1) 492 554 493 555 tl_var1=iom_mpp_read_var(tl_bathy1,'Bathymetry') 494 556 495 557 CALL iom_mpp_close(tl_bathy1) 496 558 559 ! get boundaries indices 497 560 tl_bdy(:)=boundary_init(tl_var1, ln_north, ln_south, ln_east, ln_west, & 498 561 & cn_north, cn_south, cn_east, cn_west, & … … 505 568 tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist ) 506 569 507 ! get coordinate oneach segment of each boundary570 ! get coordinate for each segment of each boundary 508 571 ALLOCATE( tl_segdom1(ip_npoint,ip_maxseg,ip_ncard) ) 509 572 ALLOCATE( tl_seglvl1(ip_npoint,ip_maxseg,ip_ncard) ) 510 573 511 574 DO jl=1,ip_ncard 512 575 IF( tl_bdy(jl)%l_use )THEN … … 516 579 tl_segdom1(:,jk,jl)=create_boundary_get_dom( tl_bathy1, & 517 580 & tl_bdy(jl), jk ) 581 582 IF( .NOT. ln_extrap )THEN 583 ! get fine grid level 584 tl_seglvl1(:,jk,jl)= & 585 & create_boundary_get_level( tl_level(:), & 586 & tl_segdom1(:,jk,jl)) 587 ENDIF 518 588 519 589 ! add extra band to fine grid domain (if possible) … … 523 593 & il_rho(jp_I), il_rho(jp_J)) 524 594 ENDDO 525 526 ! get fine grid level527 tl_seglvl1(:,jk,jl)=create_boundary_get_level( tl_level(:), &528 tl_segdom1(:,jk,jl))529 595 530 596 ENDDO … … 594 660 & in_nlevel ) 595 661 596 ! use mask597 CALL create_boundary_use_mask( tl_segvar1(jvar,jk,jl), &598 & tl_seglvl1(jpoint,jk,jl))599 600 662 !del extra 601 663 CALL dom_del_extra( tl_segvar1(jvar,jk,jl), & … … 654 716 IF( tl_bdy(jl)%l_use )THEN 655 717 656 WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//' boundary' 718 WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//& 719 & ' boundary' 657 720 DO jk=1,tl_bdy(jl)%i_nseg 658 721 ! compute domain on fine grid … … 662 725 663 726 cl_name=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name 664 WRITE(*,'(4x,a,a)') "work on variable "//TRIM(cl_name) 727 WRITE(*,'(4x,a,a)') "work on (extract) variable "//& 728 & TRIM(cl_name) 665 729 666 730 cl_point=tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_point … … 678 742 679 743 tl_dom1=dom_copy(tl_segdom1(jpoint,jk,jl)) 680 tl_lvl1=var_copy(tl_seglvl1(jpoint,jk,jl))681 744 682 745 ! open mpp files … … 687 750 & tl_mpp, TRIM(cl_name), tl_dom1) 688 751 689 ! use mask690 CALL create_boundary_use_mask( &691 & tl_segvar1(jvar+jj,jk,jl), tl_lvl1)692 693 752 ! del extra point 694 753 CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), & … … 699 758 700 759 ! add attribute to variable 701 tl_att=att_init('src_file',TRIM(fct_basename(tl_mpp%c_name))) 760 tl_att=att_init('src_file', & 761 & TRIM(fct_basename(tl_mpp%c_name))) 702 762 CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att) 703 763 704 tl_att=att_init('src_i_indices',(/tl_dom1%i_imin, tl_dom1%i_imax/)) 764 tl_att=att_init('src_i_indices', & 765 & (/tl_dom1%i_imin, tl_dom1%i_imax/)) 705 766 CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att) 706 767 707 tl_att=att_init('src_j_indices',(/tl_dom1%i_jmin, tl_dom1%i_jmax/)) 768 tl_att=att_init('src_j_indices', & 769 & (/tl_dom1%i_jmin, tl_dom1%i_jmax/)) 708 770 CALL var_move_att(tl_segvar1(jvar+jj,jk,jl), tl_att) 709 771 … … 736 798 IF( tl_bdy(jl)%l_use )THEN 737 799 738 WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//' boundary' 800 WRITE(*,'(2x,a,a)') 'work on '//TRIM(tl_bdy(jl)%c_card)//& 801 & ' boundary' 739 802 DO jk=1,tl_bdy(jl)%i_nseg 740 803 741 804 ! for each variable of this file 742 805 DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar 743 744 WRITE(*,'(4x,a,a)') "work on variable "//&806 807 WRITE(*,'(4x,a,a)') "work on (interp) variable "//& 745 808 & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) 746 809 … … 759 822 760 823 tl_dom1=dom_copy(tl_segdom1(jpoint,jk,jl)) 761 tl_lvl1=var_copy(tl_seglvl1(jpoint,jk,jl))762 824 763 825 CALL create_boundary_get_coord( tl_coord1, tl_dom1, & … … 795 857 & il_jmin0, il_jmax0 ) 796 858 797 ! add extra band (if possible) to compute interpolation 859 ! add extra band (if possible) to compute 860 ! interpolation 798 861 CALL dom_add_extra(tl_dom0) 799 862 … … 815 878 CALL dom_del_extra( tl_segvar1(jvar+jj,jk,jl), & 816 879 & tl_dom0, il_rho(:) ) 817 818 ! use mask819 CALL create_boundary_use_mask( &820 & tl_segvar1(jvar+jj,jk,jl), tl_lvl1)821 880 822 881 ! del extra point on fine grid … … 889 948 890 949 IF( jvar /= tl_multi%i_nvar )THEN 891 CALL logger_error("CREATE BOUNDARY: it seems some variable can not be read") 950 CALL logger_error("CREATE BOUNDARY: it seems some variable "//& 951 & "can not be read") 892 952 ENDIF 893 894 CALL var_clean(tl_seglvl1(:,:,:))895 DEALLOCATE( tl_seglvl1 )896 953 897 954 ! write file for each segment of each boundary 898 955 DO jl=1,ip_ncard 899 956 IF( tl_bdy(jl)%l_use )THEN 900 901 SELECT CASE(TRIM(tl_bdy(jk)%c_card))902 CASE('north','south')903 il_dim=1904 CASE('east','west')905 il_dim=2906 END SELECT907 957 908 958 DO jk=1,tl_bdy(jl)%i_nseg … … 911 961 & 'T', tl_lon1, tl_lat1 ) 912 962 963 ! force to use nav_lon, nav_lat as variable name 964 tl_lon1%c_name='nav_lon' 965 tl_lat1%c_name='nav_lat' 966 913 967 ! del extra point on fine grid 914 968 CALL dom_del_extra( tl_lon1, tl_segdom1(jp_T,jk,jl) ) … … 924 978 CALL boundary_swap(tl_lat1, tl_bdy(jl)) 925 979 DO jvar=1,tl_multi%i_nvar 926 CALL boundary_swap(tl_segvar1(jvar,jk,jl), tl_bdy(jl))927 980 928 981 ! use additional request 982 ! change unit and apply factor 983 CALL var_chg_unit(tl_segvar1(jvar,jk,jl)) 984 929 985 ! forced min and max value 930 986 CALL var_limit_value(tl_segvar1(jvar,jk,jl)) … … 933 989 CALL filter_fill_value(tl_segvar1(jvar,jk,jl)) 934 990 935 ! extrapolate 936 CALL extrap_fill_value( tl_segvar1(jvar,jk,jl), & 937 & id_iext=in_extrap, & 938 & id_jext=in_extrap, & 939 & id_kext=in_extrap ) 991 IF( .NOT. ln_extrap )THEN 992 ! use mask 993 SELECT CASE(TRIM(tl_segvar1(jvar,jk,jl)%c_point)) 994 CASE DEFAULT !'T' 995 jpoint=jp_T 996 CASE('U') 997 jpoint=jp_U 998 CASE('V') 999 jpoint=jp_V 1000 CASE('F') 1001 jpoint=jp_F 1002 END SELECT 1003 1004 CALL create_boundary_use_mask(tl_segvar1(jvar,jk,jl), & 1005 & tl_seglvl1(jpoint,jk,jl)) 1006 ENDIF 1007 1008 ! swap dimension order 1009 CALL boundary_swap(tl_segvar1(jvar,jk,jl), tl_bdy(jl)) 940 1010 941 1011 ENDDO … … 944 1014 ! create file structure 945 1015 ! set file namearray of level variable structure 946 IF( ASSOCIATED(tl_time%d_value) )THEN 947 cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" 948 cl_date=date_print( var_to_date(tl_time), cl_fmt ) 949 950 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 951 & TRIM(tl_bdy(jl)%c_card), jk, TRIM(cl_date) ) 1016 IF( tl_bdy(jl)%i_nseg > 1 )THEN 1017 IF( ASSOCIATED(tl_time%d_value) )THEN 1018 cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" 1019 tl_date=var_to_date(tl_time) 1020 tl_date=tl_date+dn_dayofs 1021 cl_date=date_print( tl_date, cl_fmt ) 1022 1023 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 1024 & TRIM(tl_bdy(jl)%c_card), jk,& 1025 & cd_date=TRIM(cl_date) ) 1026 ELSE 1027 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 1028 & TRIM(tl_bdy(jl)%c_card), jk ) 1029 ENDIF 952 1030 ELSE 953 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 954 & TRIM(tl_bdy(jl)%c_card), jk ) 1031 IF( ASSOCIATED(tl_time%d_value) )THEN 1032 cl_fmt="('y',i0.4,'m',i0.2,'d',i0.2)" 1033 tl_date=var_to_date(tl_time) 1034 tl_date=tl_date+dn_dayofs 1035 cl_date=date_print( tl_date, cl_fmt ) 1036 1037 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 1038 & TRIM(tl_bdy(jl)%c_card), & 1039 & cd_date=TRIM(cl_date) ) 1040 ELSE 1041 cl_bdyout=boundary_set_filename( TRIM(cn_fileout), & 1042 & TRIM(tl_bdy(jl)%c_card) ) 1043 ENDIF 955 1044 ENDIF 956 1045 ! … … 960 1049 tl_dim(:)=var_max_dim(tl_segvar1(:,jk,jl)) 961 1050 962 CALL dim_unorder(tl_dim(:))963 1051 SELECT CASE(TRIM(tl_bdy(jl)%c_card)) 964 1052 CASE DEFAULT ! 'north','south' 965 1053 cl_dimorder='xyzt' 966 CALL dim_reorder(tl_dim(:),TRIM(cl_dimorder))967 1054 CASE('east','west') 968 1055 cl_dimorder='yxzt' 969 CALL dim_reorder(tl_dim(:),TRIM(cl_dimorder))970 ! reorder coordinates dimension971 CALL var_reorder(tl_lon1,TRIM(cl_dimorder))972 CALL var_reorder(tl_lat1,TRIM(cl_dimorder))973 ! reorder other variable dimension974 DO jvar=1,tl_multi%i_nvar975 CALL var_reorder(tl_segvar1(jvar,jk,jl),TRIM(cl_dimorder))976 ENDDO977 1056 END SELECT 978 1057 … … 992 1071 ENDIF 993 1072 1073 1074 994 1075 IF( tl_dim(3)%l_use )THEN 995 ! add depth 996 CALL file_add_var(tl_fileout, tl_depth) 1076 IF( ASSOCIATED(tl_depth%d_value) )THEN 1077 ! add depth 1078 CALL file_add_var(tl_fileout, tl_depth) 1079 ENDIF 997 1080 ENDIF 998 1081 999 1082 IF( tl_dim(4)%l_use )THEN 1000 ! add time 1001 CALL file_add_var(tl_fileout, tl_time) 1083 IF( ASSOCIATED(tl_time%d_value) )THEN 1084 ! add time 1085 CALL file_add_var(tl_fileout, tl_time) 1086 ENDIF 1002 1087 ENDIF 1003 1088 1004 1089 ! add other variable 1005 DO jvar= 1,tl_multi%i_nvar1090 DO jvar=tl_multi%i_nvar,1,-1 1006 1091 CALL file_add_var(tl_fileout, tl_segvar1(jvar,jk,jl)) 1007 1092 CALL var_clean(tl_segvar1(jvar,jk,jl)) … … 1048 1133 1049 1134 ! write file 1050 CALL iom_write_file(tl_fileout )1135 CALL iom_write_file(tl_fileout, cl_dimorder) 1051 1136 1052 1137 ! close file … … 1066 1151 DEALLOCATE( tl_segdom1 ) 1067 1152 DEALLOCATE( tl_segvar1 ) 1153 CALL var_clean(tl_seglvl1(:,:,:)) 1154 DEALLOCATE( tl_seglvl1 ) 1155 1068 1156 1069 1157 CALL mpp_clean(tl_coord1) … … 1082 1170 !> 1083 1171 !> @author J.Paul 1084 !> -November, 2013- Initial Version1172 !> @date November, 2013- Initial Version 1085 1173 !> @date September, 2014 1086 1174 !> - take into account grid point to compute boundary indices … … 1186 1274 !------------------------------------------------------------------- 1187 1275 !> @brief 1188 !> This subroutine get coordinates over bou dnary domain1276 !> This subroutine get coordinates over boundary domain 1189 1277 !> 1190 1278 !> @author J.Paul 1191 !> - November, 2013- Initial Version 1192 !> @date September, 2014 - take into account grid point 1279 !> @date November, 2013- Initial Version 1280 !> @date September, 2014 1281 !> - take into account grid point 1193 1282 !> 1194 1283 !> @param[in] td_coord1 coordinates file structure … … 1237 1326 !------------------------------------------------------------------- 1238 1327 !> @brief 1239 !> This subroutine interpolate variable o verboundary1328 !> This subroutine interpolate variable on boundary 1240 1329 !> 1241 1330 !> @details … … 1296 1385 1297 1386 ! extrapolate variable 1298 CALL extrap_fill_value( td_var , id_iext=il_iext, id_jext=il_jext)1387 CALL extrap_fill_value( td_var ) 1299 1388 1300 1389 ! interpolate Bathymetry … … 1303 1392 1304 1393 ! remove extraband 1305 CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), il_jext*id_rho(jp_J)) 1394 CALL extrap_del_extrabands(td_var, il_iext*id_rho(jp_I), & 1395 & il_jext*id_rho(jp_J)) 1306 1396 1307 1397 END SUBROUTINE create_boundary_interp -
trunk/NEMOGCM/TOOLS/SIREN/src/create_coord.f90
r5037 r5609 24 24 !> @endcode 25 25 !> 26 !> @note 27 !> you could find a template of the namelist in templates directory. 28 !> 26 29 !> create_coord.nam comprise 6 namelists:<br/> 27 30 !> - logger namelist (namlog) … … 39 42 !> - cn_logfile : log filename 40 43 !> - cn_verbosity : verbosity ('trace','debug','info', 41 !> 'warning','error','fatal' )44 !> 'warning','error','fatal','none') 42 45 !> - in_maxerror : maximum number of error allowed 43 46 !> … … 54 57 !> - cn_varinfo : list of variable and extra information about request(s) 55 58 !> to be used.<br/> 56 !> each elements of *cn_varinfo* is a string character.<br/> 59 !> each elements of *cn_varinfo* is a string character 60 !> (separated by ',').<br/> 57 61 !> it is composed of the variable name follow by ':', 58 62 !> then request(s) to be used on this variable.<br/> 59 63 !> request could be: 60 !> - int erpolation method61 !> - ext rapolation method62 !> - f ilter method64 !> - int = interpolation method 65 !> - ext = extrapolation method 66 !> - flt = filter method 63 67 !> 64 68 !> requests must be separated by ';' .<br/> … … 68 72 !> @ref extrap and @ref filter modules.<br/> 69 73 !> 70 !> Example: 'votemper: linear; hann(2,3);dist_weight',71 !> 'vosaline: cubic'<br/>74 !> Example: 'votemper: int=linear; flt=hann(2,3); ext=dist_weight', 75 !> 'vosaline: int=cubic'<br/> 72 76 !> @note 73 77 !> If you do not specify a method which is required, … … 90 94 !> 91 95 !> * _output namelist (namout)_: 92 !> - cn_fileout : output coordinate file 96 !> - cn_fileout : output coordinate file name 93 97 !> 94 98 !> @author J.Paul … … 152 156 TYPE(TFILE) :: tl_fileout 153 157 154 ! check155 ! INTEGER(i4) :: il_imin0156 ! INTEGER(i4) :: il_imax0157 ! INTEGER(i4) :: il_jmin0158 ! INTEGER(i4) :: il_jmax0159 ! INTEGER(i4) , DIMENSION(2,2) :: il_ind2160 ! TYPE(TMPP) :: tl_mppout161 162 158 ! loop indices 163 159 INTEGER(i4) :: ji … … 165 161 166 162 ! namelist variable 163 ! namlog 167 164 CHARACTER(LEN=lc) :: cn_logfile = 'create_coord.log' 168 165 CHARACTER(LEN=lc) :: cn_verbosity = 'warning' 169 166 INTEGER(i4) :: in_maxerror = 5 170 167 168 ! namcfg 169 CHARACTER(LEN=lc) :: cn_varcfg = '../cfg/variable.cfg' 170 171 ! namcrs 171 172 CHARACTER(LEN=lc) :: cn_coord0 = '' 172 173 INTEGER(i4) :: in_perio0 = -1 173 174 174 CHARACTER(LEN=lc) :: cn_varcfg = '../cfg/variable.cfg' 175 175 ! namvar 176 176 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' 177 177 178 !namnst 178 179 INTEGER(i4) :: in_imin0 = 0 179 180 INTEGER(i4) :: in_imax0 = 0 … … 183 184 INTEGER(i4) :: in_rhoj = 1 184 185 186 !namout 185 187 CHARACTER(LEN=lc) :: cn_fileout= 'coord_fine.nc' 186 188 !------------------------------------------------------------------- … … 305 307 306 308 il_offset(:,:,:)=create_coord_get_offset(il_rho(:)) 307 308 309 ENDIF 309 310 … … 348 349 CALL dom_del_extra( tl_var(ji), tl_dom, il_rho(:), .true. ) 349 350 350 ! do not add ghost cell.351 ! ghost cell already replace by value for coordinates352 ! CALL grid_add_ghost(tl_var(ji),tl_dom%i_ghost(:,:))353 354 351 ! filter 355 352 CALL filter_fill_value(tl_var(ji)) … … 375 372 376 373 ! add variables 377 DO ji= 1,il_nvar374 DO ji=il_nvar,1,-1 378 375 CALL file_add_var(tl_fileout, tl_var(ji)) 376 CALL var_clean(tl_var(ji)) 379 377 ENDDO 380 381 ! recompute some attribute382 378 383 379 ! add some attribute … … 440 436 441 437 CALL file_clean(tl_fileout) 442 443 ! ! check domain444 ! tl_coord0=mpp_init( file_init(TRIM(cn_coord0)), id_perio=in_perio0)445 ! tl_mppout=mpp_init( file_init(TRIM(cn_fileout)) )446 ! CALL grid_get_info(tl_coord0)447 ! CALL iom_mpp_open(tl_mppout)448 !449 ! il_ind2(:,:)=grid_get_coarse_index( tl_coord0, tl_mppout, &450 ! & id_rho=il_rho(:) )451 !452 ! il_imin0=il_ind2(1,1) ; il_imax0=il_ind2(1,2)453 ! il_jmin0=il_ind2(2,1) ; il_jmax0=il_ind2(2,2)454 !455 ! IF( il_imin0 /= in_imin0 .OR. &456 ! & il_imax0 /= in_imax0 .OR. &457 ! & il_jmin0 /= in_jmin0 .OR. &458 ! & il_jmax0 /= in_jmax0 )THEN459 ! CALL logger_debug("CREATE COORD: output indices ("//&460 ! & TRIM(fct_str(il_imin0))//","//&461 ! & TRIM(fct_str(il_imax0))//") ("//&462 ! & TRIM(fct_str(il_jmin0))//","//&463 ! & TRIM(fct_str(il_jmax0))//")" )464 ! CALL logger_debug("CREATE COORD: input indices ("//&465 ! & TRIM(fct_str(in_imin0))//","//&466 ! & TRIM(fct_str(in_imax0))//") ("//&467 ! & TRIM(fct_str(in_jmin0))//","//&468 ! & TRIM(fct_str(in_jmax0))//")" )469 ! CALL logger_fatal("CREATE COORD: output domain not confrom "//&470 ! & "with input indices")471 ! ENDIF472 !473 ! CALL iom_mpp_close(tl_coord0)474 ! CALL iom_mpp_close(tl_mppout)475 438 476 439 ! close log file … … 539 502 !> @param[in] id_iext number of points to be extrapolated in i-direction 540 503 !> @param[in] id_jext number of points to be extrapolated in j-direction 504 !> 505 !> @todo check if mask is really needed 541 506 !------------------------------------------------------------------- 542 507 SUBROUTINE create_coord_interp( td_var, & … … 626 591 627 592 ! extrapolate variable 628 CALL extrap_fill_value( td_var , id_iext=il_iext, id_jext=il_jext)593 CALL extrap_fill_value( td_var ) 629 594 630 595 ! interpolate variable -
trunk/NEMOGCM/TOOLS/SIREN/src/create_restart.f90
r5037 r5609 25 25 !> @endcode 26 26 !> 27 !> @note 28 !> you could find a template of the namelist in templates directory. 29 !> 27 30 !> create_restart.nam comprise 9 namelists:<br/> 28 31 !> - logger namelist (namlog) … … 43 46 !> - cn_logfile : log filename 44 47 !> - cn_verbosity : verbosity ('trace','debug','info', 45 !> 'warning','error','fatal' )48 !> 'warning','error','fatal','none') 46 49 !> - in_maxerror : maximum number of error allowed 47 50 !> … … 59 62 !> - cn_bathy1 : bathymetry file 60 63 !> - in_perio1 : NEMO periodicity index 61 !> - in_extrap : number of land point to be extrapolated62 !> before writing file63 64 !> 64 65 !> * _vertical grid namelist (namzgr)_:<br/> … … 83 84 !> - cn_varinfo : list of variable and extra information about request(s) 84 85 !> to be used.<br/> 85 !> each elements of *cn_varinfo* is a string character.<br/> 86 !> each elements of *cn_varinfo* is a string character 87 !> (separated by ',').<br/> 86 88 !> it is composed of the variable name follow by ':', 87 89 !> then request(s) to be used on this variable.<br/> 88 90 !> request could be: 89 !> - interpolation method 90 !> - extrapolation method 91 !> - filter method 92 !> - > minimum value 93 !> - < maximum value 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) 94 98 !> 95 99 !> requests must be separated by ';'.<br/> … … 98 102 !> informations about available method could be find in @ref interp, 99 103 !> @ref extrap and @ref filter.<br/> 100 !> Example: 'votemper: linear; hann; dist_weight','vosaline:cubic'104 !> Example: 'votemper: int=linear; flt=hann; ext=dist_weight','vosaline: int=cubic' 101 105 !> @note 102 106 !> If you do not specify a method which is required, … … 136 140 !> * _output namelist (namout)_:<br/> 137 141 !> - cn_fileout : output file 138 !> - in_nproc : total number of processor to be used142 !> - ln_extrap : extrapolate land point or not 139 143 !> - in_niproc : i-direction number of processor 140 144 !> - in_njproc : j-direction numebr of processor 145 !> - in_nproc : total number of processor to be used 141 146 !> - cn_type : output format ('dimg', 'cdf') 142 147 !> … … 148 153 !> - offset computed considering grid point 149 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. 150 158 !> 151 159 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 165 173 USE iom ! I/O manager 166 174 USE grid ! grid manager 167 USE vgrid ! vertical grid manager175 USE vgrid ! vertical grid manager 168 176 USE extrap ! extrapolation manager 169 177 USE interp ! interpolation manager … … 249 257 CHARACTER(LEN=lc) :: cn_bathy1 = '' 250 258 INTEGER(i4) :: in_perio1 = -1 251 INTEGER(i4) :: in_extrap = 0252 259 253 260 !namzgr … … 279 286 ! namout 280 287 CHARACTER(LEN=lc) :: cn_fileout = 'restart.nc' 288 LOGICAL :: ln_extrap = .FALSE. 281 289 INTEGER(i4) :: in_nproc = 0 282 290 INTEGER(i4) :: in_niproc = 0 … … 301 309 & cn_coord1, & !< coordinate file 302 310 & cn_bathy1, & !< bathymetry file 303 & in_perio1, & !< periodicity index 304 & in_extrap 311 & in_perio1 !< periodicity index 305 312 306 313 NAMELIST /namzgr/ & … … 332 339 NAMELIST /namout/ & !< output namlist 333 340 & cn_fileout, & !< fine grid bathymetry file 334 & in_nproc, & !< number of processor to be used341 & ln_extrap, & !< extrapolate or not 335 342 & in_niproc, & !< i-direction number of processor 336 343 & in_njproc, & !< j-direction numebr of processor 344 & in_nproc, & !< number of processor to be used 337 345 & cn_type !< output type format (dimg, cdf) 338 346 !------------------------------------------------------------------- … … 347 355 CALL GET_COMMAND_ARGUMENT(1,cl_namelist) !f03 intrinsec 348 356 ENDIF 349 357 350 358 ! read namelist 351 359 INQUIRE(FILE=TRIM(cl_namelist), EXIST=ll_exist) … … 434 442 ! check 435 443 ! check output file do not already exist 436 cl_fileout=file_rename(cn_fileout,1) 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 437 449 INQUIRE(FILE=TRIM(cl_fileout), EXIST=ll_exist) 438 450 IF( ll_exist )THEN … … 468 480 & il_rho(:) ) 469 481 470 ! compute level 471 ALLOCATE(tl_level(ip_npoint)) 472 tl_level(:)=vgrid_get_level(tl_bathy1, cl_namelist ) 473 474 ! remove ghost cell 482 ! fine grid ghost cell 475 483 il_xghost(:,:)=grid_get_ghost(tl_bathy1) 476 DO ji=1,ip_npoint477 CALL grid_del_ghost(tl_level(ji), il_xghost(:,:))478 ENDDO479 480 ! clean481 CALL mpp_clean(tl_bathy1)482 484 483 485 ! work on variables … … 514 516 tl_var(jvar) = create_restart_matrix( & 515 517 & tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj), tl_coord1, & 516 & in_nlevel, tl_level(:) ) 518 & in_nlevel, il_xghost(:,:) ) 519 520 ! add ghost cell 521 CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:)) 517 522 518 523 ENDDO … … 535 540 ! open mpp file 536 541 CALL iom_mpp_open(tl_mpp) 542 537 543 538 544 ! get or check depth value … … 579 585 DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar 580 586 581 WRITE(*,'(2x,a,a)') "work on variable "//&587 WRITE(*,'(2x,a,a)') "work on (extract) variable "//& 582 588 & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) 583 589 … … 600 606 CALL att_clean(tl_att) 601 607 602 ! use mask603 CALL create_restart_mask(tl_var(jvar), tl_level(:))604 605 608 ! add ghost cell 606 CALL grid_add_ghost( tl_var(jvar), tl_dom1%i_ghost(:,:))609 CALL grid_add_ghost(tl_var(jvar), tl_dom1%i_ghost(:,:)) 607 610 608 611 ENDDO … … 631 634 DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar 632 635 633 WRITE(*,'(2x,a,a)') "work on variable "//&636 WRITE(*,'(2x,a,a)') "work on (interp) variable "//& 634 637 & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) 635 638 … … 646 649 & id_rho=il_rho(:), & 647 650 & cd_point=TRIM(tl_var(jvar)%c_point)) 648 649 651 650 652 ! interpolate variable 651 CALL create_restart_interp(tl_var(jvar), tl_level(:), &653 CALL create_restart_interp(tl_var(jvar), & 652 654 & il_rho(:), & 653 655 & id_offset=il_offset(:,:)) … … 675 677 CALL att_clean(tl_att) 676 678 677 ! use mask678 CALL create_restart_mask(tl_var(jvar), tl_level(:))679 680 679 ! add ghost cell 681 CALL grid_add_ghost( tl_var(jvar), il_xghost(:,:) ) 682 683 680 CALL grid_add_ghost(tl_var(jvar), il_xghost(:,:)) 684 681 ENDDO 685 682 … … 705 702 CALL mpp_clean(tl_coord0) 706 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 707 713 ! use additional request 708 714 DO jvar=1,il_nvar 709 715 716 ! change unit and apply factor 717 CALL var_chg_unit(tl_var(jvar)) 718 710 719 ! forced min and max value 711 720 CALL var_limit_value(tl_var(jvar)) … … 714 723 CALL filter_fill_value(tl_var(jvar)) 715 724 716 ! extrapolate717 CALL extrap_fill_value(tl_var(jvar), id_iext=in_extrap, &718 & id_jext=in_extrap, &719 & id_kext=in_extrap)725 IF( .NOT. ln_extrap )THEN 726 ! use mask 727 CALL create_restart_mask(tl_var(jvar), tl_level(:)) 728 ENDIF 720 729 721 730 ENDDO … … 724 733 IF( in_niproc == 0 .AND. & 725 734 & in_njproc == 0 .AND. & 726 & in_nproc 735 & in_nproc == 0 )THEN 727 736 in_niproc = 1 728 737 in_njproc = 1 … … 782 791 CALL mpp_add_var(tl_mppout, tl_depth) 783 792 ELSE 784 CALL logger_ error("CREATE RESTART: no value for depth variable.")793 CALL logger_warn("CREATE RESTART: no value for depth variable.") 785 794 ENDIF 786 795 ENDIF … … 792 801 CALL mpp_add_var(tl_mppout, tl_time) 793 802 ELSE 794 CALL logger_ error("CREATE RESTART: no value for time variable.")803 CALL logger_warn("CREATE RESTART: no value for time variable.") 795 804 ENDIF 796 805 ENDIF … … 798 807 799 808 ! add other variable 800 DO jvar= 1,il_nvar809 DO jvar=il_nvar,1,-1 801 810 ! check if variable already add 802 811 il_index=var_get_index(tl_mppout%t_proc(1)%t_var(:), tl_var(jvar)%c_name) … … 807 816 ENDDO 808 817 809 ! DO ji=1,4810 ! CALL grid_add_ghost( tl_level(ji), il_xghost(:,:) )811 ! CALL var_clean(tl_level(ji))812 ! ENDDO813 814 818 ! add some attribute 815 819 tl_att=att_init("Created_by","SIREN create_restart") … … 839 843 ENDIF 840 844 845 ! print 846 CALL mpp_print(tl_mppout) 847 841 848 ! create file 842 849 CALL iom_mpp_create(tl_mppout) … … 847 854 CALL iom_mpp_close(tl_mppout) 848 855 849 ! print850 CALL mpp_print(tl_mppout)851 852 856 ! clean 853 857 CALL att_clean(tl_att) 854 858 CALL var_clean(tl_var(:)) 855 859 DEALLOCATE(tl_var) 856 CALL var_clean(tl_level(:)) 857 DEALLOCATE(tl_level) 860 IF( .NOT. ln_extrap )THEN 861 CALL var_clean(tl_level(:)) 862 DEALLOCATE(tl_level) 863 ENDIF 858 864 859 865 CALL mpp_clean(tl_mppout) … … 876 882 !> 877 883 !> @author J.Paul 878 !> - November, 2013- Initial Version 884 !> @date November, 2013- Initial Version 885 !> @date June, 2015 886 !> - do not use level anymore 879 887 !> 880 888 !> @param[in] td_var variable structure 881 889 !> @param[in] td_coord coordinate file structure 882 890 !> @param[in] id_nlevel number of vertical level 883 !> @param[in] td_level array of level on T,U,V,F point (variable structure)891 !> @param[in] id_xghost ghost cell array 884 892 !> @return variable structure 885 893 !------------------------------------------------------------------- 886 FUNCTION create_restart_matrix(td_var, td_coord, id_nlevel, td_level)894 FUNCTION create_restart_matrix(td_var, td_coord, id_nlevel, id_xghost) 887 895 IMPLICIT NONE 888 896 ! Argument 889 TYPE(TVAR) , INTENT(IN) :: td_var890 TYPE(TMPP) , INTENT(IN) :: td_coord891 INTEGER(i4) , INTENT(IN) :: id_nlevel892 TYPE(TVAR), DIMENSION(:), INTENT(IN) :: td_level897 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 893 901 894 902 ! function … … 899 907 INTEGER(i4) , DIMENSION(3) :: il_size 900 908 INTEGER(i4) , DIMENSION(3) :: il_rest 901 INTEGER(i4) , DIMENSION(2,2) :: il_xghost902 909 903 910 INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ishape … … 915 922 !---------------------------------------------------------------- 916 923 917 ! look for ghost cell918 il_xghost(:,:)=grid_get_ghost( td_coord )919 920 924 ! write value on grid 921 925 ! get matrix dimension … … 929 933 930 934 ! remove ghost cell 931 tl_dim(jp_I)%i_len=tl_dim(jp_I)%i_len - SUM(i l_xghost(jp_I,:))*ip_ghost932 tl_dim(jp_J)%i_len=tl_dim(jp_J)%i_len - SUM(i l_xghost(jp_J,:))*ip_ghost935 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 933 937 934 938 ! split output domain in N subdomain depending of matrix dimension … … 991 995 992 996 DEALLOCATE(dl_value) 993 994 ! use mask995 CALL create_restart_mask(create_restart_matrix, td_level(:))996 997 ! add ghost cell998 CALL grid_add_ghost( create_restart_matrix, il_xghost(:,:) )999 997 1000 998 ! clean … … 1071 1069 !> 1072 1070 !> @author J.Paul 1073 !> - Nov, 2013- Initial Version 1071 !> @date November, 2013- Initial Version 1072 !> @date June, 2015 1073 !> - do not use level anymore (for extrapolation) 1074 1074 !> 1075 1075 !> @param[inout] td_var variable structure 1076 !> @param[inout] td_level fine grid level, array of variable structure1077 1076 !> @param[in] id_rho array of refinment factor 1078 1077 !> @param[in] id_offset array of offset between fine and coarse grid … … 1080 1079 !> @param[in] id_jext j-direction size of extra bands (default=im_minext) 1081 1080 !------------------------------------------------------------------- 1082 SUBROUTINE create_restart_interp( td_var, td_level,&1081 SUBROUTINE create_restart_interp( td_var, & 1083 1082 & id_rho, & 1084 1083 & id_offset, & … … 1089 1088 ! Argument 1090 1089 TYPE(TVAR) , INTENT(INOUT) :: td_var 1091 TYPE(TVAR) , DIMENSION(:) , INTENT(INOUT) :: td_level1092 1090 INTEGER(i4), DIMENSION(:) , INTENT(IN ) :: id_rho 1093 1091 INTEGER(i4), DIMENSION(:,:), INTENT(IN ) :: id_offset … … 1119 1117 il_jext=2 1120 1118 ENDIF 1121 1122 1119 ! work on variable 1123 1120 ! add extraband … … 1125 1122 1126 1123 ! extrapolate variable 1127 CALL extrap_fill_value( td_var, td_level(:), & 1128 & id_offset(:,:), & 1129 & id_rho(:), & 1130 & id_iext=il_iext, id_jext=il_jext ) 1124 CALL extrap_fill_value( td_var ) 1131 1125 1132 1126 ! interpolate variable … … 1220 1214 1221 1215 ! get or check depth value 1216 1222 1217 IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN 1223 1218 -
trunk/NEMOGCM/TOOLS/SIREN/src/dimension.f90
r5037 r5609 78 78 !> 79 79 !> This subroutine filled dimension structure with unused dimension, 80 !> then switch from " unordered" dimension to "ordered" dimension.<br/>80 !> then switch from "disordered" dimension to "ordered" dimension.<br/> 81 81 !> The dimension structure return will be:<br/> 82 82 !> tl_dim(1) => 'X', i_len=10, l_use=T, l_uld=F<br/> … … 94 94 !> - cl_neworder : character(len=4) (example: 'yxzt') 95 95 !> 96 !> to switch dimension array from ordered dimension to unordered96 !> to switch dimension array from ordered dimension to disordered 97 97 !> dimension:<br/> 98 98 !> @code 99 !> CALL dim_ unorder(tl_dim(:))99 !> CALL dim_disorder(tl_dim(:)) 100 100 !> @endcode 101 101 !> … … 111 111 !> CALL dim_reshape_2xyzt(tl_dim(:), value(:,:,:,:)) 112 112 !> @endcode 113 !> - value must be a 4D array of real(8) value " unordered"114 !> 115 !> to reshape array of value in " unordered" dimension:<br/>113 !> - value must be a 4D array of real(8) value "disordered" 114 !> 115 !> to reshape array of value in "disordered" dimension:<br/> 116 116 !> @code 117 117 !> CALL dim_reshape_xyzt2(tl_dim(:), value(:,:,:,:)) … … 123 123 !> CALL dim_reorder_2xyzt(tl_dim(:), tab(:)) 124 124 !> @endcode 125 !> - tab must be a 1D array with 4 elements " unordered".125 !> - tab must be a 1D array with 4 elements "disordered". 126 126 !> It could be composed of character, integer(4), or logical 127 127 !> 128 !> to reorder a 1D array of 4 elements in " unordered" dimension:<br/>129 !> @code 130 !> CALL dim_reorder_ 2xyzt(tl_dim(:), tab(:))128 !> to reorder a 1D array of 4 elements in "disordered" dimension:<br/> 129 !> @code 130 !> CALL dim_reorder_xyzt2(tl_dim(:), tab(:)) 131 131 !> @endcode 132 132 !> - tab must be a 1D array with 4 elements "ordered". … … 173 173 PUBLIC :: dim_print !< print dimension information 174 174 PUBLIC :: dim_copy !< copy dimension structure 175 PUBLIC :: dim_reorder !< filled dimension structure to switch from unordered to ordered dimension176 PUBLIC :: dim_ unorder !< switch dimension array from ordered to unordered dimension175 PUBLIC :: dim_reorder !< filled dimension structure to switch from disordered to ordered dimension 176 PUBLIC :: dim_disorder !< switch dimension array from ordered to disordered dimension 177 177 PUBLIC :: dim_fill_unused !< filled dimension structure with unused dimension 178 178 PUBLIC :: dim_reshape_2xyzt !< reshape array dimension to ('x','y','z','t') … … 321 321 !> @author J.Paul 322 322 !> @date November, 2013 - Initial Version 323 !> @date September, 2014 - do not check if dimension used 323 !> @date September, 2014 324 !> - do not check if dimension used 324 325 !> 325 326 !> @param[in] td_dim array of dimension structure … … 502 503 !> Optionally length could be inform, as well as short name and if dimension 503 504 !> is unlimited or not.<br/> 504 !> define dimension is supposed to be used. 505 !> 506 !> @author J.Paul 507 !> @date November, 2013 - Initial Version 505 !> By default, define dimension is supposed to be used. 506 !> Optionally you could force a defined dimension to be unused. 507 !> 508 !> @author J.Paul 509 !> @date November, 2013 - Initial Version 510 !> @date February, 2015 511 !> - add optional argument to define dimension unused 512 !> @date July, 2015 513 !> - Bug fix: inform order to disorder table instead of disorder to order 514 !> table 508 515 ! 509 516 !> @param[in] cd_name dimension name … … 511 518 !> @param[in] ld_uld dimension unlimited 512 519 !> @param[in] cd_sname dimension short name 520 !> @param[in] ld_uld dimension use or not 513 521 !> @return dimension structure 514 522 !------------------------------------------------------------------- 515 TYPE(TDIM) FUNCTION dim_init( cd_name, id_len, ld_uld, cd_sname )523 TYPE(TDIM) FUNCTION dim_init( cd_name, id_len, ld_uld, cd_sname, ld_use) 516 524 IMPLICIT NONE 517 525 … … 521 529 LOGICAL, INTENT(IN), OPTIONAL :: ld_uld 522 530 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_sname 531 LOGICAL, INTENT(IN), OPTIONAL :: ld_use 523 532 524 533 ! local variable … … 543 552 544 553 ! define dimension is supposed to be used 545 dim_init%l_use=.TRUE. 554 IF( PRESENT(ld_use) )THEN 555 dim_init%l_use=ld_use 556 ELSE 557 dim_init%l_use=.TRUE. 558 ENDIF 546 559 547 560 IF( PRESENT(cd_sname) )THEN … … 590 603 ENDIF 591 604 592 ! get dimension order er index593 dim_init%i_ 2xyzt=SCAN(TRIM(cp_dimorder),TRIM(dim_init%c_sname))605 ! get dimension order indices 606 dim_init%i_xyzt2=SCAN(TRIM(cp_dimorder),TRIM(dim_init%c_sname)) 594 607 595 608 END FUNCTION dim_init … … 655 668 !> @author J.Paul 656 669 !> @date November, 2013 - Initial Version 670 !> @date July, 2015 671 !> - Bug fix: use order to disorder table (see dim_init) 657 672 !> 658 673 !> @param[in] td_dim array of dimension structure … … 686 701 ! search missing dimension 687 702 IF( INDEX(cl_dimin,TRIM(fct_lower(cp_dimorder(ji:ji)))) == 0 )THEN 688 ! search first empty dimension 689 il_ind(:)=MINLOC( tl_dim(:)%i_ 2xyzt, tl_dim(:)%i_2xyzt== 0 )703 ! search first empty dimension (see dim_init) 704 il_ind(:)=MINLOC( tl_dim(:)%i_xyzt2, tl_dim(:)%i_xyzt2 == 0 ) 690 705 691 706 ! put missing dimension instead of empty one … … 693 708 ! update output structure 694 709 tl_dim(il_ind(1))%c_name=fct_lower(cp_dimorder(ji:ji)) 695 tl_dim(il_ind(1))%i_ 2xyzt=ji710 tl_dim(il_ind(1))%i_xyzt2=ji 696 711 tl_dim(il_ind(1))%i_len=1 697 712 tl_dim(il_ind(1))%l_use=.FALSE. … … 711 726 !> This subroutine switch element of an array (4 elts) of dimension 712 727 !> structure 713 !> from unordered dimension to ordered dimension <br/>728 !> from disordered dimension to ordered dimension <br/> 714 729 !> 715 730 !> @details … … 722 737 !> @author J.Paul 723 738 !> @date November, 2013 - Initial Version 724 !> @date September, 2014 - allow to choose ordered dimension to be output 739 !> @date September, 2014 740 !> - allow to choose ordered dimension to be output 725 741 !> 726 742 !> @param[inout] td_dim array of dimension structure … … 811 827 !------------------------------------------------------------------- 812 828 !> @brief This subroutine switch dimension array from ordered dimension ('x','y','z','t') 813 !> to unordered dimension. <br/>829 !> to disordered dimension. <br/> 814 830 !> @details 815 831 !> Example: (/'x','y','z','t'/) => (/'z','x','t','y'/)<br/> … … 822 838 !> @param[inout] td_dim array of dimension structure 823 839 !------------------------------------------------------------------- 824 SUBROUTINE dim_ unorder(td_dim)840 SUBROUTINE dim_disorder(td_dim) 825 841 IMPLICIT NONE 826 842 ! Argument … … 835 851 836 852 IF( SIZE(td_dim(:)) /= ip_maxdim )THEN 837 CALL logger_error("DIM UNORDER: invalid dimension of array dimension.")853 CALL logger_error("DIM DISORDER: invalid dimension of array dimension.") 838 854 ELSE 839 855 ! add dummy xyzt2 id to unused dimension … … 868 884 ENDIF 869 885 870 END SUBROUTINE dim_ unorder886 END SUBROUTINE dim_disorder 871 887 !------------------------------------------------------------------- 872 888 !> @brief This function reshape real(8) 4D array … … 908 924 909 925 IF( SIZE(td_dim(:)) /= ip_maxdim )THEN 910 CALL logger_error("DIM RESHAPE 2 XYZT: invalid dimension of array dimension.") 926 CALL logger_error("DIM RESHAPE 2 XYZT: invalid dimension of "//& 927 & "array dimension.") 911 928 ELSE 912 929 … … 914 931 915 932 CALL logger_fatal( & 916 & " DIM RESHAPE 2 XYZT: you should have run dim_reorder &917 & before running RESHAPE" )933 & " DIM RESHAPE 2 XYZT: you should have run dim_reorder"// & 934 & " before running RESHAPE" ) 918 935 919 936 ENDIF … … 972 989 !------------------------------------------------------------------- 973 990 !> @brief This function reshape ordered real(8) 4D array with dimension 974 !> (/'x','y','z','t'/) to an " unordered" array.<br/>991 !> (/'x','y','z','t'/) to an "disordered" array.<br/> 975 992 !> @details 976 993 !> Example: (/'x','y','z','t'/) => (/'z','x','t','y'/) … … 1009 1026 1010 1027 IF( SIZE(td_dim(:)) /= ip_maxdim )THEN 1011 CALL logger_error("DIM RESHAPE XYZT 2: invalid dimension of array dimension.") 1028 CALL logger_error("DIM RESHAPE XYZT 2: invalid dimension of "//& 1029 & "array dimension.") 1012 1030 ELSE 1013 1031 … … 1015 1033 1016 1034 CALL logger_fatal( & 1017 & " DIM RESHAPE XYZT 2: you should have run dim_reorder &1018 & before running RESHAPE" )1035 & " DIM RESHAPE XYZT 2: you should have run dim_reorder"// & 1036 & " before running RESHAPE" ) 1019 1037 1020 1038 ENDIF … … 1104 1122 1105 1123 CALL logger_error( & 1106 & " DIM REORDER 2 XYZT: you should have run dim_reorder 1107 & before running REORDER" )1124 & " DIM REORDER 2 XYZT: you should have run dim_reorder"//& 1125 & " before running REORDER" ) 1108 1126 1109 1127 ENDIF … … 1116 1134 END FUNCTION dim__reorder_2xyzt_i4 1117 1135 !------------------------------------------------------------------- 1118 !> @brief This function unordered integer(4) 1D array to be suitable with1136 !> @brief This function disordered integer(4) 1D array to be suitable with 1119 1137 !> initial dimension order (ex: dimension read in file). 1120 1138 !> @note you must have run dim_reorder before use this subroutine … … 1143 1161 IF( SIZE(td_dim(:)) /= ip_maxdim .OR. & 1144 1162 & SIZE(id_arr(:)) /= ip_maxdim )THEN 1145 CALL logger_error("DIM REORDER XYZT 2: invalid dimension of array dimension"//&1146 & "or of array of value.")1163 CALL logger_error("DIM REORDER XYZT 2: invalid dimension of "//& 1164 & "array dimension or of array of value.") 1147 1165 ELSE 1148 1166 IF( ANY(td_dim(:)%i_xyzt2==0) )THEN 1149 1167 1150 1168 CALL logger_error( & 1151 & " DIM REORDER XYZT 2: you should have run dim_reorder &1152 & before running REORDER" )1169 & " DIM REORDER XYZT 2: you should have run dim_reorder"// & 1170 & " before running REORDER" ) 1153 1171 1154 1172 ENDIF … … 1193 1211 1194 1212 CALL logger_error( & 1195 & " DIM REORDER 2 XYZT: you should have run dim_reorder &1196 & before running REORDER" )1213 & " DIM REORDER 2 XYZT: you should have run dim_reorder"// & 1214 & " before running REORDER" ) 1197 1215 1198 1216 ENDIF … … 1205 1223 END FUNCTION dim__reorder_2xyzt_l 1206 1224 !------------------------------------------------------------------- 1207 !> @brief This function unordered logical 1D array to be suitable with1225 !> @brief This function disordered logical 1D array to be suitable with 1208 1226 !> initial dimension order (ex: dimension read in file). 1209 1227 !> @note you must have run dim_reorder before use this subroutine … … 1238 1256 1239 1257 CALL logger_error( & 1240 & " DIM REORDER XYZT 2: you should have run dim_reorder 1241 & 1258 & " DIM REORDER XYZT 2: you should have run dim_reorder"//& 1259 & " before running REORDER" ) 1242 1260 1243 1261 ENDIF … … 1294 1312 END FUNCTION dim__reorder_2xyzt_c 1295 1313 !------------------------------------------------------------------- 1296 !> @brief This function unordered string 1D array to be suitable with1314 !> @brief This function disordered string 1D array to be suitable with 1297 1315 !> initial dimension order (ex: dimension read in file). 1298 1316 !> @note you must have run dim_reorder before use this subroutine … … 1326 1344 IF( ANY(td_dim(:)%i_xyzt2==0) )THEN 1327 1345 CALL logger_error( & 1328 & " DIM REORDER XYZT 2: you should have run dim_reorder &1329 & before running REORDER" )1346 & " DIM REORDER XYZT 2: you should have run dim_reorder"// & 1347 & " before running REORDER" ) 1330 1348 1331 1349 ENDIF -
trunk/NEMOGCM/TOOLS/SIREN/src/docsrc/1_install.md
r5037 r5609 14 14 SIREN codes were succesfully tested with : 15 15 - ifort (version 12.0.4) 16 - gfortran (version 4.7.2 20121109) 16 <!-- - gfortran (version 4.7.2 20121109) --> 17 17 <!-- - pgf95 (version 13.9-0) --> 18 18 -
trunk/NEMOGCM/TOOLS/SIREN/src/docsrc/3_codingRules.md
r5037 r5609 80 80 81 81 # Implicit none {#implicit} 82 All subroutines and functions will include an IMPLIC TINONE statement.82 All subroutines and functions will include an IMPLICIT NONE statement. 83 83 84 84 # Header {#header} -
trunk/NEMOGCM/TOOLS/SIREN/src/domain.f90
r5037 r5609 294 294 ! 295 295 !> @author J.Paul 296 !> -June, 2013- Initial Version296 !> @date June, 2013- Initial Version 297 297 !> @date September, 2014 298 298 !> - add boundary index … … 362 362 363 363 IF( td_mpp%i_perio < 0 .OR. td_mpp%i_perio > 6 )THEN 364 CALL logger_error("DOM INIT: invalid grid periodicity. "//& 365 & "you should use grid_get_perio to compute it") 364 CALL logger_error("DOM INIT: invalid grid periodicity ("//& 365 & TRIM(fct_str(td_mpp%i_perio))//& 366 & ") you should use grid_get_perio to compute it") 366 367 ELSE 367 368 dom__init_mpp%i_perio0=td_mpp%i_perio … … 424 425 ! 425 426 !> @author J.Paul 426 !> -June, 2013- Initial Version427 !> @date June, 2013- Initial Version 427 428 !> @date September, 2014 428 429 !> - add boundary index … … 489 490 490 491 IF( td_file%i_perio < 0 .OR. td_file%i_perio > 6 )THEN 491 CALL logger_error("DOM INIT: invalid grid periodicity. "//& 492 & "you should use grid_get_perio to compute it") 492 CALL logger_error("DOM INIT: invalid grid periodicity ("//& 493 & TRIM(fct_str(td_file%i_perio))//& 494 & ") you should use grid_get_perio to compute it") 493 495 ELSE 494 496 dom__init_file%i_perio0=td_file%i_perio … … 653 655 !> 654 656 !> @author J.Paul 655 !> - November, 2013- Subroutine written657 !> @date November, 2013 - Initial version 656 658 !> @date September, 2014 657 659 !> - use zero indice to defined cyclic or global domain -
trunk/NEMOGCM/TOOLS/SIREN/src/extrap.f90
r5037 r5609 19 19 !> defining string character _cn\_varinfo_. By default _dist_weight_.<br/> 20 20 !> Example: 21 !> - cn_varinfo='varname1: dist_weight', 'varname2:min_error'21 !> - cn_varinfo='varname1:ext=dist_weight', 'varname2:ext=min_error' 22 22 !> 23 23 !> to detect point to be extrapolated:<br/> 24 24 !> @code 25 !> il_detect(:,:,:)=extrap_detect(td_var , [td_level], [id_offset,] [id_rho,] [id_ext])25 !> il_detect(:,:,:)=extrap_detect(td_var) 26 26 !> @endcode 27 27 !> - il_detect(:,:,:) is 3D array of point to be extrapolated 28 28 !> - td_var is coarse grid variable to be extrapolated 29 !> - td_level is fine grid array of level (see vgrid_get_level) [optional]30 !> - id_offset is array of offset between fine and coarse grid [optional]31 !> - id_rho is array of refinment factor [optional]32 !> - id_ext is array of number of points to be extrapolated [optional]33 29 !> 34 30 !> to extrapolate variable:<br/> 35 31 !> @code 36 !> CALL extrap_fill_value( td_var, [ td_level], [id_offset], [id_rho], [id_iext], [id_jext], [id_kext], [id_radius], [id_maxiter])32 !> CALL extrap_fill_value( td_var, [id_radius]) 37 33 !> @endcode 38 34 !> - td_var is coarse grid variable to be extrapolated 39 !> - td_level is fine grid array of level (see vgrid_get_level) [optional]40 !> - id_offset is array of offset between fine and coarse grid [optional]41 !> - id_rho is array of refinment factor [optional]42 !> - id_iext is number of points to be extrapolated in i-direction [optional]43 !> - id_jext is number of points to be extrapolated in j-direction [optional]44 !> - id_kext is number of points to be extrapolated in k-direction [optional]45 35 !> - id_radius is radius of the halo used to compute extrapolation [optional] 46 !> - id_maxiter is maximum number of iteration [optional]47 36 !> 48 37 !> to add extraband to the variable (to be extrapolated):<br/> … … 62 51 !> - id_jsize : j-direction size of extra bands [optional] 63 52 !> 64 !> to compute first derivative of 1D array:<br/>65 !> @code66 !> dl_value(:)=extrap_deriv_1D( dd_value(:), dd_fill, [ld_discont] )67 !> @endcode68 !> - dd_value is 1D array of variable69 !> - dd_fill is FillValue of variable70 !> - ld_discont is logical to take into account longitudinal East-West discontinuity [optional]71 !>72 !> to compute first derivative of 2D array:<br/>73 !> @code74 !> dl_value(:,:)=extrap_deriv_2D( dd_value(:,:), dd_fill, cd_dim, [ld_discont] )75 !> @endcode76 !> - dd_value is 2D array of variable77 !> - dd_fill is FillValue of variable78 !> - cd_dim is character to compute derivative on first (I) or second (J) dimension79 !> - ld_discont is logical to take into account longitudinal East-West discontinuity [optional]80 !>81 !> to compute first derivative of 3D array:<br/>82 !> @code83 !> dl_value(:,:,:)=extrap_deriv_3D( dd_value(:,:,:), dd_fill, cd_dim, [ld_discont] )84 !> @endcode85 !> - dd_value is 3D array of variable86 !> - dd_fill is FillValue of variable87 !> - cd_dim is character to compute derivative on first (I), second (J), or third (K) dimension88 !> - ld_discont is logical to take into account longitudinal East-West discontinuity [optional]89 !>90 53 !> @warning _FillValue must not be zero (use var_chg_FillValue()) 91 54 !> … … 93 56 !> J.Paul 94 57 ! REVISION HISTORY: 95 !> @date Nov , 2013 - Initial Version58 !> @date November, 2013 - Initial Version 96 59 !> @date September, 2014 97 60 !> - add header 61 !> @date June, 2015 62 !> - extrapolate all land points (_FillValue) 63 !> - move deriv function to math module 64 !> @date July, 2015 65 !> - compute extrapolation from north west to south east, 66 !> and from south east to north west 98 67 !> 99 68 !> @todo 100 69 !> - create module for each extrapolation method 70 !> - smooth extrapolated points 101 71 !> 102 72 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 110 80 USE date ! date manager 111 81 USE logger ! log file manager 82 USE math ! mathematical function 112 83 USE att ! attribute manager 113 84 USE dim ! dimension manager … … 118 89 119 90 ! type and variable 120 PRIVATE :: im_maxiter !< default maximum number of iteration121 91 PRIVATE :: im_minext !< default minumum number of point to extrapolate 122 92 PRIVATE :: im_mincubic !< default minumum number of point to extrapolate for cubic interpolation … … 127 97 PUBLIC :: extrap_add_extrabands !< add extraband to the variable (to be extrapolated) 128 98 PUBLIC :: extrap_del_extrabands !< delete extraband of the variable 129 PUBLIC :: extrap_deriv_1D !< compute first derivative of 1D array130 PUBLIC :: extrap_deriv_2D !< compute first derivative of 2D array131 PUBLIC :: extrap_deriv_3D !< compute first derivative of 3D array132 99 133 100 PRIVATE :: extrap__detect_wrapper ! detected point to be extrapolated wrapper … … 141 108 PRIVATE :: extrap__3D_dist_weight_fill ! 142 109 143 INTEGER(i4), PARAMETER :: im_maxiter = 10 !< default maximum number of iteration144 110 INTEGER(i4), PARAMETER :: im_minext = 2 !< default minumum number of point to extrapolate 145 111 INTEGER(i4), PARAMETER :: im_mincubic= 4 !< default minumum number of point to extrapolate for cubic interpolation … … 171 137 !> 172 138 !> @author J.Paul 173 !> - November, 2013- Initial Version 139 !> @date November, 2013 - Initial Version 140 !> @date June, 2015 141 !> - do not use level to select points to be extrapolated 174 142 ! 175 143 !> @param[in] td_var0 coarse grid variable to extrapolate 176 !> @param[in] td_level1 fine grid array of level177 !> @param[in] id_offset array of offset between fine and coarse grid178 !> @param[in] id_rho array of refinment factor179 !> @param[in] id_ext array of number of points to be extrapolated180 144 !> @return array of point to be extrapolated 181 145 !------------------------------------------------------------------- 182 FUNCTION extrap__detect( td_var0, td_level1, & 183 & id_offset, id_rho, id_ext ) 146 FUNCTION extrap__detect( td_var0 ) 184 147 IMPLICIT NONE 185 148 ! Argument 186 149 TYPE(TVAR) , INTENT(IN ) :: td_var0 187 TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level1188 INTEGER(i4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset189 INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho190 INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_ext191 150 192 151 ! function … … 196 155 197 156 ! local variable 198 CHARACTER(LEN=lc) :: cl_level199 200 INTEGER(i4) :: il_ind201 INTEGER(i4) , DIMENSION(:,:,:), ALLOCATABLE :: il_detect202 INTEGER(i4) , DIMENSION(:,:,:), ALLOCATABLE :: il_tmp203 INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_offset204 INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_level1205 INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_level1_G0206 INTEGER(i4) , DIMENSION(:,:) , ALLOCATABLE :: il_extra207 INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_ext208 INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_rho209 INTEGER(i4) , DIMENSION(:) , ALLOCATABLE :: il_dim0210 211 TYPE(TVAR) :: tl_var1212 213 157 ! loop indices 214 158 INTEGER(i4) :: ji0 215 159 INTEGER(i4) :: jj0 216 160 INTEGER(i4) :: jk0 217 INTEGER(i4) :: ji1218 INTEGER(i4) :: jj1219 INTEGER(i4) :: ji1m220 INTEGER(i4) :: jj1m221 INTEGER(i4) :: ji1p222 INTEGER(i4) :: jj1p223 161 !---------------------------------------------------------------- 224 162 225 ! init 226 extrap__detect(:,:,:)=0 227 228 ALLOCATE( il_dim0(3) ) 229 il_dim0(:)=td_var0%t_dim(1:3)%i_len 230 231 ! optional argument 232 ALLOCATE( il_rho(ip_maxdim) ) 233 il_rho(:)=1 234 IF( PRESENT(id_rho) ) il_rho(1:SIZE(id_rho(:)))=id_rho(:) 235 236 ALLOCATE( il_offset(ip_maxdim,2) ) 237 il_offset(:,:)=0 238 IF( PRESENT(id_offset) )THEN 239 il_offset(1:SIZE(id_offset(:,:),DIM=1),& 240 & 1:SIZE(id_offset(:,:),DIM=2) )= id_offset(:,:) 241 ELSE 242 il_offset(jp_I,:)=FLOOR(REAL(il_rho(jp_I)-1,dp)*0.5) 243 il_offset(jp_J,:)=FLOOR(REAL(il_rho(jp_J)-1,dp)*0.5) 244 ENDIF 245 246 ALLOCATE( il_ext(ip_maxdim) ) 247 il_ext(:)=im_minext 248 IF( PRESENT(id_ext) ) il_ext(1:SIZE(id_ext(:)))=id_ext(:) 249 250 ALLOCATE( il_detect(il_dim0(1),& 251 & il_dim0(2),& 252 & il_dim0(3)) ) 253 il_detect(:,:,:)=0 254 255 ! select point already inform 256 DO jk0=1,td_var0%t_dim(3)%i_len 257 DO jj0=1,td_var0%t_dim(2)%i_len 258 DO ji0=1,td_var0%t_dim(1)%i_len 259 IF( td_var0%d_value(ji0,jj0,jk0,1) /= td_var0%d_fill ) il_detect(ji0,jj0,jk0)=1 260 ENDDO 261 ENDDO 262 ENDDO 263 264 IF( PRESENT(td_level1) )THEN 265 SELECT CASE(TRIM(td_var0%c_point)) 266 CASE DEFAULT !'T' 267 cl_level='tlevel' 268 CASE('U') 269 cl_level='ulevel' 270 CASE('V') 271 cl_level='vlevel' 272 CASE('F') 273 cl_level='flevel' 274 END SELECT 275 276 il_ind=var_get_index(td_level1(:),TRIM(cl_level)) 277 IF( il_ind == 0 )THEN 278 CALL logger_error("EXTRAP DETECT: can not compute point to be "//& 279 & "extrapolated for variable "//TRIM(td_var0%c_name)//& 280 & ". can not find "//& 281 & "level for variable point "//TRIM(TRIM(td_var0%c_point))) 282 ELSE 283 tl_var1=var_copy(td_level1(il_ind)) 284 285 ALLOCATE( il_level1_G0( il_dim0(1), il_dim0(2)) ) 286 IF( ALL(tl_var1%t_dim(1:2)%i_len == il_dim0(1:2)) )THEN 287 288 ! variable to be extrapolated use same resolution than level 289 il_level1_G0(:,:)=INT(tl_var1%d_value(:,:,1,1),i4) 290 291 ELSE 292 ! variable to be extrapolated do not use same resolution than level 293 ALLOCATE( il_level1(tl_var1%t_dim(1)%i_len, & 294 & tl_var1%t_dim(2)%i_len) ) 295 ! match fine grid vertical level with coarse grid 296 il_level1(:,:)=INT(tl_var1%d_value(:,:,1,1),i4)/il_rho(jp_K) 297 298 ALLOCATE( il_extra(ip_maxdim,2) ) 299 ! coarsening fine grid level 300 il_extra(jp_I,1)=CEILING(REAL(il_rho(jp_I)-1,dp)*0.5_dp) 301 il_extra(jp_I,2)=FLOOR(REAL(il_rho(jp_I)-1,dp)*0.5_dp) 302 303 il_extra(jp_J,1)=CEILING(REAL(il_rho(jp_J)-1,dp)*0.5_dp) 304 il_extra(jp_J,2)=FLOOR(REAL(il_rho(jp_J)-1,dp)*0.5_dp) 305 306 DO jj0=1,td_var0%t_dim(2)%i_len 307 308 jj1=(jj0-1)*il_rho(jp_J)+1-il_offset(jp_J,1) 309 310 jj1m=MAX( jj1-il_extra(jp_J,1), 1 ) 311 jj1p=MIN( jj1+il_extra(jp_J,2), & 312 & tl_var1%t_dim(2)%i_len-il_offset(jp_J,2) ) 313 314 DO ji0=1,td_var0%t_dim(1)%i_len 315 316 ji1=(ji0-1)*il_rho(jp_I)+1-id_offset(jp_I,1) 317 318 ji1m=MAX( ji1-il_extra(jp_I,1), 1 ) 319 ji1p=MIN( ji1+il_extra(jp_I,2), & 320 & tl_var1%t_dim(1)%i_len-id_offset(jp_I,2) ) 321 322 il_level1_G0(ji0,jj0)=MAXVAL(il_level1(ji1m:ji1p,jj1m:jj1p)) 323 324 ENDDO 325 ENDDO 326 327 ! clean 328 DEALLOCATE( il_extra ) 329 DEALLOCATE( il_level1 ) 330 331 ENDIF 332 333 ! look for sea point 334 DO jk0=1,td_var0%t_dim(3)%i_len 335 WHERE( il_level1_G0(:,:) >= jk0) 336 il_detect(:,:,jk0)=1 337 END WHERE 338 ENDDO 339 340 ! clean 341 DEALLOCATE( il_level1_G0 ) 342 CALL var_clean(tl_var1) 343 344 ENDIF 345 ENDIF 346 347 ! clean 348 DEALLOCATE( il_offset ) 349 350 ALLOCATE( il_tmp(il_dim0(1),& 351 & il_dim0(2),& 352 & il_dim0(3)) ) 353 il_tmp(:,:,:)=il_detect(:,:,:) 354 ! select extra point depending on interpolation method 355 ! compute point near grid point already inform 356 DO jk0=1,il_dim0(3) 357 DO jj0=1,il_dim0(2) 358 DO ji0=1,il_dim0(1) 359 360 IF( il_tmp(ji0,jj0,jk0) == 1 )THEN 361 il_detect( & 362 & MAX(1,ji0-il_ext(jp_I)):MIN(ji0+il_ext(jp_I),il_dim0(1)),& 363 & MAX(1,jj0-il_ext(jp_J)):MIN(jj0+il_ext(jp_J),il_dim0(2)),& 364 & MAX(1,jk0-il_ext(jp_K)):MIN(jk0+il_ext(jp_K),il_dim0(3)) & 365 & ) = 1 366 ENDIF 367 368 ENDDO 369 ENDDO 370 ENDDO 371 372 ! clean 373 DEALLOCATE( il_tmp ) 163 ! force to extrapolated all points 164 extrap__detect(:,:,:)=1 374 165 375 166 ! do not compute grid point already inform … … 377 168 DO jj0=1,td_var0%t_dim(2)%i_len 378 169 DO ji0=1,td_var0%t_dim(1)%i_len 379 IF( td_var0%d_value(ji0,jj0,jk0,1) /= td_var0%d_fill ) il_detect(ji0,jj0,jk0)=0 170 IF( td_var0%d_value(ji0,jj0,jk0,1) /= td_var0%d_fill )THEN 171 extrap__detect(ji0,jj0,jk0)=0 172 ENDIF 380 173 ENDDO 381 174 ENDDO 382 175 ENDDO 383 384 ! save result385 extrap__detect(:,:,:)=il_detect(:,:,:)386 387 ! clean388 DEALLOCATE( il_dim0 )389 DEALLOCATE( il_ext )390 DEALLOCATE( il_detect )391 DEALLOCATE( il_rho )392 176 393 177 END FUNCTION extrap__detect … … 398 182 !> 399 183 !> @author J.Paul 400 !> - November, 2013- Initial Version 184 !> @date November, 2013 - Initial Version 185 !> @date June, 2015 186 !> - select all land points for extrapolation 401 187 !> 402 188 !> @param[in] td_var coarse grid variable to extrapolate 403 !> @param[in] td_level fine grid array of level404 !> @param[in] id_offset array of offset between fine and coarse grid405 !> @param[in] id_rho array of refinment factor406 !> @param[in] id_ext array of number of points to be extrapolated407 189 !> @return 3D array of point to be extrapolated 408 190 !------------------------------------------------------------------- 409 FUNCTION extrap__detect_wrapper( td_var, td_level, & 410 & id_offset, id_rho, id_ext ) 191 FUNCTION extrap__detect_wrapper( td_var ) 411 192 412 193 IMPLICIT NONE 413 194 ! Argument 414 195 TYPE(TVAR) , INTENT(IN ) :: td_var 415 TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level416 INTEGER(i4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset417 INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho418 INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_ext419 196 420 197 ! function … … 439 216 & " for variable "//TRIM(td_var%c_name) ) 440 217 441 extrap__detect_wrapper(:,:,:)=extrap__detect( td_var, td_level, & 442 & id_offset, & 443 & id_rho, & 444 & id_ext ) 218 extrap__detect_wrapper(:,:,:)=extrap__detect( td_var ) 445 219 446 220 ELSE IF( ALL(td_var%t_dim(1:2)%l_use) )THEN … … 450 224 & " for variable "//TRIM(td_var%c_name) ) 451 225 452 extrap__detect_wrapper(:,:,1:1)=extrap__detect( td_var , td_level,& 453 & id_offset, & 454 & id_rho, & 455 & id_ext ) 226 extrap__detect_wrapper(:,:,1:1)=extrap__detect( td_var ) 456 227 457 228 ELSE IF( td_var%t_dim(3)%l_use )THEN … … 461 232 & " for variable "//TRIM(td_var%c_name) ) 462 233 463 extrap__detect_wrapper(1:1,1:1,:)=extrap__detect( td_var , td_level, & 464 & id_offset, & 465 & id_rho, & 466 & id_ext ) 234 extrap__detect_wrapper(1:1,1:1,:)=extrap__detect( td_var ) 467 235 468 236 ENDIF … … 489 257 !> 490 258 !> @author J.Paul 491 !> - Nov, 2013- Initial Version 259 !> @date November, 2013 - Initial Version 260 !> @date June, 2015 261 !> - select all land points for extrapolation 492 262 ! 493 263 !> @param[inout] td_var variable structure 494 !> @param[in] td_level fine grid array of level495 !> @param[in] id_offset array of offset between fine and coarse grid496 !> @param[in] id_rho array of refinment factor497 !> @param[in] id_iext number of points to be extrapolated in i-direction498 !> @param[in] id_jext number of points to be extrapolated in j-direction499 !> @param[in] id_kext number of points to be extrapolated in k-direction500 264 !> @param[in] id_radius radius of the halo used to compute extrapolation 501 !> @param[in] id_maxiter maximum number of iteration 502 !------------------------------------------------------------------- 503 SUBROUTINE extrap__fill_value_wrapper( td_var, td_level, & 504 & id_offset, & 505 & id_rho, & 506 & id_iext, id_jext, id_kext, & 507 & id_radius, id_maxiter ) 265 !------------------------------------------------------------------- 266 SUBROUTINE extrap__fill_value_wrapper( td_var, & 267 & id_radius ) 508 268 IMPLICIT NONE 509 269 ! Argument 510 270 TYPE(TVAR) , INTENT(INOUT) :: td_var 511 TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level512 INTEGER(i4), DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset513 INTEGER(i4), DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho514 INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext515 INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext516 INTEGER(i4), INTENT(IN ), OPTIONAL :: id_kext517 271 INTEGER(i4), INTENT(IN ), OPTIONAL :: id_radius 518 INTEGER(i4), INTENT(IN ), OPTIONAL :: id_maxiter519 272 520 273 ! local variable 521 INTEGER(i4) :: il_iext522 INTEGER(i4) :: il_jext523 INTEGER(i4) :: il_kext524 274 INTEGER(i4) :: il_radius 525 INTEGER(i4) :: il_maxiter526 275 527 276 CHARACTER(LEN=lc) :: cl_method … … 544 293 END SELECT 545 294 546 il_iext=im_minext 547 IF( PRESENT(id_iext) ) il_iext=id_iext 548 il_jext=im_minext 549 IF( PRESENT(id_jext) ) il_jext=id_jext 550 il_kext=0 551 IF( PRESENT(id_kext) ) il_kext=id_kext 552 553 IF( TRIM(td_var%c_interp(1)) == 'cubic')THEN 554 IF( il_iext > 0 .AND. il_iext < im_mincubic ) il_iext=im_mincubic 555 IF( il_jext > 0 .AND. il_jext < im_mincubic ) il_jext=im_mincubic 295 ! number of point use to compute box 296 il_radius=1 297 IF( PRESENT(id_radius) ) il_radius=id_radius 298 IF( il_radius < 0 )THEN 299 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 300 & " radius of the box used to compute extrapolation "//& 301 & "("//TRIM(fct_str(il_radius))//")") 556 302 ENDIF 557 303 558 IF( il_iext < 0 )THEN 559 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 560 & " number of points to be extrapolated in i-direction "//& 561 & "("//TRIM(fct_str(il_iext))//")") 562 ENDIF 563 564 IF( il_jext < 0 )THEN 565 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 566 & " number of points to be extrapolated in j-direction "//& 567 & "("//TRIM(fct_str(il_jext))//")") 568 ENDIF 569 570 IF( il_kext < 0 )THEN 571 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 572 & " number of points to be extrapolated in k-direction "//& 573 & "("//TRIM(fct_str(il_kext))//")") 574 ENDIF 575 576 IF( (il_iext /= 0 .AND. td_var%t_dim(1)%l_use) .OR. & 577 & (il_jext /= 0 .AND. td_var%t_dim(2)%l_use) .OR. & 578 & (il_kext /= 0 .AND. td_var%t_dim(3)%l_use) )THEN 579 580 ! number of point use to compute box 581 il_radius=1 582 IF( PRESENT(id_radius) ) il_radius=id_radius 583 IF( il_radius < 0 )THEN 584 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 585 & " radius of the box used to compute extrapolation "//& 586 & "("//TRIM(fct_str(il_radius))//")") 587 ENDIF 588 589 ! maximum number of iteration 590 il_maxiter=im_maxiter 591 IF( PRESENT(id_maxiter) ) il_maxiter=id_maxiter 592 IF( il_maxiter < 0 )THEN 593 CALL logger_error("EXTRAP FILL VALUE: invalid "//& 594 & " maximum nuber of iteration "//& 595 & "("//TRIM(fct_str(il_maxiter))//")") 596 ENDIF 597 598 CALL logger_info("EXTRAP FILL: extrapolate "//TRIM(td_var%c_name)//& 599 & " using "//TRIM(cl_method)//" method." ) 600 601 CALL extrap__fill_value( td_var, cl_method, & 602 & il_iext, il_jext, il_kext, & 603 & il_radius, il_maxiter, & 604 & td_level, & 605 & id_offset, id_rho ) 606 607 ENDIF 304 CALL logger_info("EXTRAP FILL: extrapolate "//TRIM(td_var%c_name)//& 305 & " using "//TRIM(cl_method)//" method." ) 306 307 CALL extrap__fill_value( td_var, cl_method, & 308 & il_radius ) 608 309 609 310 ENDIF … … 621 322 !> 622 323 !> @author J.Paul 623 !> - November, 2013- Initial Version 324 !> @date November, 2013 - Initial Version 325 !> @date June, 2015 326 !> - select all land points for extrapolation 624 327 ! 625 328 !> @param[inout] td_var variable structure 626 329 !> @param[in] cd_method extrapolation method 627 !> @param[in] id_iext number of points to be extrapolated in i-direction628 !> @param[in] id_jext number of points to be extrapolated in j-direction629 !> @param[in] id_kext number of points to be extrapolated in k-direction630 330 !> @param[in] id_radius radius of the halo used to compute extrapolation 631 !> @param[in] id_maxiter maximum number of iteration632 !> @param[in] td_level fine grid array of level633 !> @param[in] id_offset array of offset between fine and coarse grid634 !> @param[in] id_rho array of refinment factor635 331 !------------------------------------------------------------------- 636 332 SUBROUTINE extrap__fill_value( td_var, cd_method, & 637 & id_iext, id_jext, id_kext, & 638 & id_radius, id_maxiter, & 639 & td_level, & 640 & id_offset, & 641 & id_rho ) 333 & id_radius ) 642 334 IMPLICIT NONE 643 335 ! Argument 644 336 TYPE(TVAR) , INTENT(INOUT) :: td_var 645 337 CHARACTER(LEN=*), INTENT(IN ) :: cd_method 646 INTEGER(i4) , INTENT(IN ) :: id_iext647 INTEGER(i4) , INTENT(IN ) :: id_jext648 INTEGER(i4) , INTENT(IN ) :: id_kext649 338 INTEGER(i4) , INTENT(IN ) :: id_radius 650 INTEGER(i4) , INTENT(IN ) :: id_maxiter651 TYPE(TVAR) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: td_level652 INTEGER(i4) , DIMENSION(:,:), INTENT(IN ), OPTIONAL :: id_offset653 INTEGER(i4) , DIMENSION(:) , INTENT(IN ), OPTIONAL :: id_rho654 339 655 340 ! local variable … … 668 353 & td_var%t_dim(3)%i_len) ) 669 354 670 il_detect(:,:,:) = extrap_detect( td_var, td_level, & 671 & id_offset, & 672 & id_rho, & 673 & id_ext=(/id_iext, id_jext, id_kext/) ) 355 il_detect(:,:,:) = extrap_detect( td_var ) 356 674 357 !2- add attribute to variable 675 358 cl_extrap=fct_concat(td_var%c_extrap(:)) … … 679 362 CALL att_clean(tl_att) 680 363 681 CALL logger_info(" EXTRAP FILL: "//& 682 & TRIM(fct_str(SUM(il_detect(:,:,:))))//& 683 & " point(s) to extrapolate " ) 684 685 !3- extrapolate 686 CALL extrap__3D(td_var%d_value(:,:,:,:), td_var%d_fill, & 687 & il_detect(:,:,:), & 688 & cd_method, id_radius, id_maxiter ) 364 IF( ALL(il_detect(:,:,:)==1) )THEN 365 CALL logger_warn(" EXTRAP FILL: "//& 366 & " can not extrapolate "//TRIM(td_var%c_name)//& 367 & ". no value inform." ) 368 ELSE 369 CALL logger_info(" EXTRAP FILL: "//& 370 & TRIM(fct_str(SUM(il_detect(:,:,:))))//& 371 & " point(s) to extrapolate " ) 372 373 CALL logger_info(" EXTRAP FILL: method "//& 374 & TRIM(cd_method) ) 375 376 !3- extrapolate 377 CALL extrap__3D(td_var%d_value(:,:,:,:), td_var%d_fill, & 378 & il_detect(:,:,:), & 379 & cd_method, id_radius ) 380 ENDIF 689 381 690 382 DEALLOCATE(il_detect) … … 705 397 !> 706 398 !> @author J.Paul 707 !> - Nov, 2013- Initial Version 399 !> @date November, 2013 - Initial Version 400 !> @date July, 2015 401 !> - compute coef indices to be used 708 402 ! 709 403 !> @param[inout] dd_value 3D array of variable to be extrapolated … … 714 408 !------------------------------------------------------------------- 715 409 SUBROUTINE extrap__3D( dd_value, dd_fill, id_detect,& 716 & cd_method, id_radius , id_maxiter)410 & cd_method, id_radius ) 717 411 IMPLICIT NONE 718 412 ! Argument 719 413 REAL(dp) , DIMENSION(:,:,:,:), INTENT(INOUT) :: dd_value 720 REAL(dp) , INTENT(IN ) :: dd_fill 721 INTEGER(i4), DIMENSION(:,:,:), INTENT(INOUT) :: id_detect 722 CHARACTER(LEN=*), INTENT(IN ) :: cd_method 723 INTEGER(i4), INTENT(IN ) :: id_radius 724 INTEGER(i4), INTENT(IN ) :: id_maxiter 414 REAL(dp) , INTENT(IN ) :: dd_fill 415 INTEGER(i4), DIMENSION(:,:,:) , INTENT(INOUT) :: id_detect 416 CHARACTER(LEN=*), INTENT(IN ) :: cd_method 417 INTEGER(i4), INTENT(IN ) :: id_radius 725 418 726 419 ! local variable 727 INTEGER(i4) :: il_imin 728 INTEGER(i4) :: il_imax 729 INTEGER(i4) :: il_jmin 730 INTEGER(i4) :: il_jmax 731 INTEGER(i4) :: il_kmin 732 INTEGER(i4) :: il_kmax 733 INTEGER(i4) :: il_iter 734 INTEGER(i4) :: il_radius 735 736 INTEGER(i4), DIMENSION(4) :: il_shape 737 INTEGER(i4), DIMENSION(3) :: il_dim 420 INTEGER(i4) :: il_imin 421 INTEGER(i4) :: il_imax 422 INTEGER(i4) :: il_jmin 423 INTEGER(i4) :: il_jmax 424 INTEGER(i4) :: il_kmin 425 INTEGER(i4) :: il_kmax 426 INTEGER(i4) :: il_iter 427 INTEGER(i4) :: il_radius 428 INTEGER(i4) :: il_i1 429 INTEGER(i4) :: il_i2 430 INTEGER(i4) :: il_j1 431 INTEGER(i4) :: il_j2 432 INTEGER(i4) :: il_k1 433 INTEGER(i4) :: il_k2 434 435 INTEGER(i4), DIMENSION(4) :: il_shape 436 INTEGER(i4), DIMENSION(3) :: il_dim 738 437 739 438 INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_detect … … 743 442 REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_dfdz 744 443 REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_coef 444 445 LOGICAL :: ll_iter 745 446 746 447 ! loop indices … … 765 466 DO WHILE( ANY(il_detect(:,:,:)==1) ) 766 467 ! change extend value to minimize number of iteration 767 il_radius=id_radius+(il_iter/id_maxiter) 468 il_radius=id_radius+(il_iter-1) 469 ll_iter=.TRUE. 768 470 769 471 ALLOCATE( dl_dfdx(il_shape(1), il_shape(2), il_shape(3)) ) … … 774 476 dl_dfdx(:,:,:)=dd_fill 775 477 IF( il_shape(1) > 1 )THEN 776 dl_dfdx(:,:,:)=extrap_deriv_3D( dd_value(:,:,:,jl), dd_fill, 'I' ) 478 dl_dfdx(:,:,:)=math_deriv_3D( dd_value(:,:,:,jl), & 479 & dd_fill, 'I' ) 777 480 ENDIF 778 481 … … 780 483 dl_dfdy(:,:,:)=dd_fill 781 484 IF( il_shape(2) > 1 )THEN 782 dl_dfdy(:,:,:)=extrap_deriv_3D( dd_value(:,:,:,jl), dd_fill, 'J' ) 485 dl_dfdy(:,:,:)=math_deriv_3D( dd_value(:,:,:,jl), & 486 & dd_fill, 'J' ) 783 487 ENDIF 784 488 … … 786 490 dl_dfdz(:,:,:)=dd_fill 787 491 IF( il_shape(3) > 1 )THEN 788 dl_dfdz(:,:,:)=extrap_deriv_3D( dd_value(:,:,:,jl), dd_fill, 'K' ) 492 dl_dfdz(:,:,:)=math_deriv_3D( dd_value(:,:,:,jl), & 493 & dd_fill, 'K' ) 789 494 ENDIF 790 495 … … 804 509 805 510 DO jk=1,il_shape(3) 511 ! from North West(1,1) to South East(il_shape(1),il_shape(2)) 806 512 IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE 807 513 DO jj=1,il_shape(2) … … 813 519 il_imin=MAX(ji-il_radius,1) 814 520 il_imax=MIN(ji+il_radius,il_shape(1)) 521 ! coef indices to be used 522 il_i1 = il_radius-(ji-il_imin)+1 523 il_i2 = il_radius+(il_imax-ji)+1 815 524 IF( il_dim(1) == 1 )THEN 816 525 il_imin=ji 817 526 il_imax=ji 818 ENDIF 527 ! coef indices to be used 528 il_i1 = 1 529 il_i2 = 2 530 ENDIF 531 819 532 820 533 il_jmin=MAX(jj-il_radius,1) 821 534 il_jmax=MIN(jj+il_radius,il_shape(2)) 535 ! coef indices to be used 536 il_j1 = il_radius-(jj-il_jmin)+1 537 il_j2 = il_radius+(il_jmax-jj)+1 822 538 IF( il_dim(2) == 1 )THEN 823 539 il_jmin=jj 824 540 il_jmax=jj 541 ! coef indices to be used 542 il_j1 = 1 543 il_j2 = 2 825 544 ENDIF 826 545 827 546 il_kmin=MAX(jk-il_radius,1) 828 547 il_kmax=MIN(jk+il_radius,il_shape(3)) 548 ! coef indices to be used 549 il_k1 = il_radius-(jk-il_kmin)+1 550 il_k2 = il_radius+(il_kmax-jk)+1 829 551 IF( il_dim(3) == 1 )THEN 830 552 il_kmin=jk 831 553 il_kmax=jk 554 ! coef indices to be used 555 il_k1 = 1 556 il_k2 = 2 832 557 ENDIF 833 558 … … 845 570 & il_jmin:il_jmax, & 846 571 & il_kmin:il_kmax ), & 847 & dl_coef(:,:,:) ) 572 & dl_coef(il_i1:il_i2, & 573 & il_j1:il_j2, & 574 & il_k1:il_k2) ) 848 575 849 576 IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN 850 577 il_detect(ji,jj,jk)= 0 578 ll_iter=.FALSE. 579 ENDIF 580 581 ENDIF 582 583 ENDDO 584 ENDDO 585 ! from South East(il_shape(1),il_shape(2)) to North West(1,1) 586 IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE 587 DO jj=il_shape(2),1,-1 588 IF( ALL(il_detect(:,jj,jk) == 0) ) CYCLE 589 DO ji=il_shape(1),1,-1 590 591 IF( il_detect(ji,jj,jk) == 1 )THEN 592 593 il_imin=MAX(ji-il_radius,1) 594 il_imax=MIN(ji+il_radius,il_shape(1)) 595 ! coef indices to be used 596 il_i1 = il_radius-(ji-il_imin)+1 597 il_i2 = il_radius+(il_imax-ji)+1 598 IF( il_dim(1) == 1 )THEN 599 il_imin=ji 600 il_imax=ji 601 ! coef indices to be used 602 il_i1 = 1 603 il_i2 = 2 604 ENDIF 605 606 607 il_jmin=MAX(jj-il_radius,1) 608 il_jmax=MIN(jj+il_radius,il_shape(2)) 609 ! coef indices to be used 610 il_j1 = il_radius-(jj-il_jmin)+1 611 il_j2 = il_radius+(il_jmax-jj)+1 612 IF( il_dim(2) == 1 )THEN 613 il_jmin=jj 614 il_jmax=jj 615 ! coef indices to be used 616 il_j1 = 1 617 il_j2 = 2 618 ENDIF 619 620 il_kmin=MAX(jk-il_radius,1) 621 il_kmax=MIN(jk+il_radius,il_shape(3)) 622 ! coef indices to be used 623 il_k1 = il_radius-(jk-il_kmin)+1 624 il_k2 = il_radius+(il_kmax-jk)+1 625 IF( il_dim(3) == 1 )THEN 626 il_kmin=jk 627 il_kmax=jk 628 ! coef indices to be used 629 il_k1 = 1 630 il_k2 = 2 631 ENDIF 632 633 dd_value(ji,jj,jk,jl)=extrap__3D_min_error_fill( & 634 & dd_value( il_imin:il_imax, & 635 & il_jmin:il_jmax, & 636 & il_kmin:il_kmax,jl ), dd_fill, il_radius, & 637 & dl_dfdx( il_imin:il_imax, & 638 & il_jmin:il_jmax, & 639 & il_kmin:il_kmax ), & 640 & dl_dfdy( il_imin:il_imax, & 641 & il_jmin:il_jmax, & 642 & il_kmin:il_kmax ), & 643 & dl_dfdz( il_imin:il_imax, & 644 & il_jmin:il_jmax, & 645 & il_kmin:il_kmax ), & 646 & dl_coef(il_i1:il_i2, & 647 & il_j1:il_j2, & 648 & il_k1:il_k2) ) 649 650 IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN 651 il_detect(ji,jj,jk)= 0 652 ll_iter=.FALSE. 851 653 ENDIF 852 654 … … 862 664 DEALLOCATE( dl_coef ) 863 665 864 il_iter=il_iter+1666 IF( ll_iter ) il_iter=il_iter+1 865 667 ENDDO 866 668 ENDDO … … 875 677 DO WHILE( ANY(il_detect(:,:,:)==1) ) 876 678 ! change extend value to minimize number of iteration 877 il_radius=id_radius+(il_iter/id_maxiter) 679 il_radius=id_radius+(il_iter-1) 680 ll_iter=.TRUE. 878 681 879 682 il_dim(1)=2*il_radius+1 … … 886 689 ALLOCATE( dl_coef(il_dim(1), il_dim(2), il_dim(3)) ) 887 690 888 dl_coef(:,:,:)=extrap__3D_dist_weight_coef(dd_value(1:il_dim(1), 889 & 1:il_dim(2), 890 & 1:il_dim(3), 691 dl_coef(:,:,:)=extrap__3D_dist_weight_coef(dd_value(1:il_dim(1),& 692 & 1:il_dim(2),& 693 & 1:il_dim(3),& 891 694 & jl ) ) 892 695 893 696 DO jk=1,il_shape(3) 697 ! from North West(1,1) to South East(il_shape(1),il_shape(2)) 894 698 IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE 895 699 DO jj=1,il_shape(2) … … 901 705 il_imin=MAX(ji-il_radius,1) 902 706 il_imax=MIN(ji+il_radius,il_shape(1)) 707 ! coef indices to be used 708 il_i1 = il_radius-(ji-il_imin)+1 709 il_i2 = il_radius+(il_imax-ji)+1 903 710 IF( il_dim(1) == 1 )THEN 904 711 il_imin=ji 905 712 il_imax=ji 713 ! coef indices to be used 714 il_i1 = 1 715 il_i2 = 2 906 716 ENDIF 907 717 908 718 il_jmin=MAX(jj-il_radius,1) 909 719 il_jmax=MIN(jj+il_radius,il_shape(2)) 720 ! coef indices to be used 721 il_j1 = il_radius-(jj-il_jmin)+1 722 il_j2 = il_radius+(il_jmax-jj)+1 910 723 IF( il_dim(2) == 1 )THEN 911 724 il_jmin=jj 912 725 il_jmax=jj 726 ! coef indices to be used 727 il_j1 = 1 728 il_j2 = 2 913 729 ENDIF 914 730 915 731 il_kmin=MAX(jk-il_radius,1) 916 732 il_kmax=MIN(jk+il_radius,il_shape(3)) 733 ! coef indices to be used 734 il_k1 = il_radius-(jk-il_kmin)+1 735 il_k2 = il_radius+(il_kmax-jk)+1 917 736 IF( il_dim(3) == 1 )THEN 918 737 il_kmin=jk 919 738 il_kmax=jk 739 ! coef indices to be used 740 il_k1 = 1 741 il_k2 = 2 920 742 ENDIF 921 743 … … 925 747 & il_kmin:il_kmax, & 926 748 & jl), dd_fill, il_radius, & 927 & dl_coef(:,:,:) ) 749 & dl_coef(il_i1:il_i2, & 750 & il_j1:il_j2, & 751 & il_k1:il_k2) ) 928 752 929 753 IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN 930 754 il_detect(ji,jj,jk)= 0 755 ll_iter=.FALSE. 756 ENDIF 757 758 ENDIF 759 760 ENDDO 761 ENDDO 762 ! from South East(il_shape(1),il_shape(2)) to North West(1,1) 763 IF( ALL(il_detect(:,:,jk) == 0) ) CYCLE 764 DO jj=il_shape(2),1,-1 765 IF( ALL(il_detect(:,jj,jk) == 0) ) CYCLE 766 DO ji=il_shape(1),1,-1 767 768 IF( il_detect(ji,jj,jk) == 1 )THEN 769 770 il_imin=MAX(ji-il_radius,1) 771 il_imax=MIN(ji+il_radius,il_shape(1)) 772 ! coef indices to be used 773 il_i1 = il_radius-(ji-il_imin)+1 774 il_i2 = il_radius+(il_imax-ji)+1 775 IF( il_dim(1) == 1 )THEN 776 il_imin=ji 777 il_imax=ji 778 ! coef indices to be used 779 il_i1 = 1 780 il_i2 = 2 781 ENDIF 782 783 il_jmin=MAX(jj-il_radius,1) 784 il_jmax=MIN(jj+il_radius,il_shape(2)) 785 ! coef indices to be used 786 il_j1 = il_radius-(jj-il_jmin)+1 787 il_j2 = il_radius+(il_jmax-jj)+1 788 IF( il_dim(2) == 1 )THEN 789 il_jmin=jj 790 il_jmax=jj 791 ! coef indices to be used 792 il_j1 = 1 793 il_j2 = 2 794 ENDIF 795 796 il_kmin=MAX(jk-il_radius,1) 797 il_kmax=MIN(jk+il_radius,il_shape(3)) 798 ! coef indices to be used 799 il_k1 = il_radius-(jk-il_kmin)+1 800 il_k2 = il_radius+(il_kmax-jk)+1 801 IF( il_dim(3) == 1 )THEN 802 il_kmin=jk 803 il_kmax=jk 804 ! coef indices to be used 805 il_k1 = 1 806 il_k2 = 2 807 ENDIF 808 809 dd_value(ji,jj,jk,jl)=extrap__3D_dist_weight_fill( & 810 & dd_value( il_imin:il_imax, & 811 & il_jmin:il_jmax, & 812 & il_kmin:il_kmax, & 813 & jl), dd_fill, il_radius, & 814 & dl_coef(il_i1:il_i2, & 815 & il_j1:il_j2, & 816 & il_k1:il_k2) ) 817 818 IF( dd_value(ji,jj,jk,jl) /= dd_fill )THEN 819 il_detect(ji,jj,jk)= 0 820 ll_iter=.FALSE. 931 821 ENDIF 932 822 … … 936 826 ENDDO 937 827 ENDDO 938 828 CALL logger_info(" EXTRAP 3D: "//& 829 & TRIM(fct_str(SUM(il_detect(:,:,:))))//& 830 & " point(s) to extrapolate " ) 831 939 832 DEALLOCATE( dl_coef ) 940 il_iter=il_iter+1833 IF( ll_iter ) il_iter=il_iter+1 941 834 ENDDO 942 835 ENDDO … … 946 839 947 840 END SUBROUTINE extrap__3D 948 !-------------------------------------------------------------------949 !> @brief950 !> This function compute derivative of 1D array.951 !>952 !> @details953 !> optionaly you could specify to take into account east west discontinuity954 !> (-180° 180° or 0° 360° for longitude variable)955 !>956 !> @author J.Paul957 !> - November, 2013- Initial Version958 !959 !> @param[in] dd_value 1D array of variable to be extrapolated960 !> @param[in] dd_fill FillValue of variable961 !> @param[in] ld_discont logical to take into account east west discontinuity962 !-------------------------------------------------------------------963 PURE FUNCTION extrap_deriv_1D( dd_value, dd_fill, ld_discont )964 965 IMPLICIT NONE966 ! Argument967 REAL(dp) , DIMENSION(:), INTENT(IN) :: dd_value968 REAL(dp) , INTENT(IN) :: dd_fill969 LOGICAL , INTENT(IN), OPTIONAL :: ld_discont970 971 ! function972 REAL(dp), DIMENSION(SIZE(dd_value,DIM=1) ) :: extrap_deriv_1D973 974 ! local variable975 INTEGER(i4) :: il_imin976 INTEGER(i4) :: il_imax977 INTEGER(i4), DIMENSION(1) :: il_shape978 979 REAL(dp) :: dl_min980 REAL(dp) :: dl_max981 REAL(dp) , DIMENSION(:), ALLOCATABLE :: dl_value982 983 LOGICAL :: ll_discont984 985 ! loop indices986 INTEGER(i4) :: ji987 988 INTEGER(i4) :: i1989 INTEGER(i4) :: i2990 !----------------------------------------------------------------991 ! init992 extrap_deriv_1D(:)=dd_fill993 994 ll_discont=.FALSE.995 IF( PRESENT(ld_discont) ) ll_discont=ld_discont996 997 il_shape(:)=SHAPE(dd_value(:))998 999 ALLOCATE( dl_value(3))1000 1001 ! compute derivative in i-direction1002 DO ji=1,il_shape(1)1003 1004 il_imin=MAX(ji-1,1)1005 il_imax=MIN(ji+1,il_shape(1))1006 1007 IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN1008 i1=1 ; i2=31009 ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN1010 i1=1 ; i2=21011 ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN1012 i1=2 ; i2=31013 ENDIF1014 1015 dl_value(i1:i2)=dd_value(il_imin:il_imax)1016 IF( il_imin == 1 )THEN1017 dl_value(:)=EOSHIFT( dl_value(:), &1018 & DIM=1, &1019 & SHIFT=-1, &1020 & BOUNDARY=dl_value(1) )1021 ENDIF1022 IF( il_imax == il_shape(1) )THEN1023 dl_value(:)=EOSHIFT( dl_value(:), &1024 & DIM=1, &1025 & SHIFT=1, &1026 & BOUNDARY=dl_value(3))1027 ENDIF1028 1029 IF( ll_discont )THEN1030 dl_min=MINVAL( dl_value(:), dl_value(:)/=dd_fill )1031 dl_max=MAXVAL( dl_value(:), dl_value(:)/=dd_fill )1032 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1033 WHERE( dl_value(:) < 0._dp )1034 dl_value(:) = dl_value(:)+360._dp1035 END WHERE1036 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1037 WHERE( dl_value(:) > 180._dp )1038 dl_value(:) = dl_value(:)-180._dp1039 END WHERE1040 ENDIF1041 ENDIF1042 1043 IF( dl_value( 2) /= dd_fill .AND. & ! ji1044 & dl_value( 3) /= dd_fill .AND. & ! ji+11045 & dl_value( 1) /= dd_fill )THEN ! ji-11046 1047 extrap_deriv_1D(ji)=&1048 & ( dl_value(3) - dl_value(1) ) / &1049 & REAL( il_imax-il_imin ,dp)1050 1051 ENDIF1052 1053 ENDDO1054 1055 DEALLOCATE( dl_value )1056 1057 END FUNCTION extrap_deriv_1D1058 !-------------------------------------------------------------------1059 !> @brief1060 !> This function compute derivative of 2D array.1061 !> you have to specify in which direction derivative have to be computed:1062 !> first (I) or second (J) dimension.1063 !>1064 !> @details1065 !> optionaly you could specify to take into account east west discontinuity1066 !> (-180° 180° or 0° 360° for longitude variable)1067 !>1068 !> @author J.Paul1069 !> - November, 2013- Initial Version1070 !1071 !> @param[in] dd_value 2D array of variable to be extrapolated1072 !> @param[in] dd_fill FillValue of variable1073 !> @param[in] cd_dim compute derivative on first (I) or second (J) dimension1074 !> @param[in] ld_discont logical to take into account east west discontinuity1075 !-------------------------------------------------------------------1076 FUNCTION extrap_deriv_2D( dd_value, dd_fill, cd_dim, ld_discont )1077 1078 IMPLICIT NONE1079 ! Argument1080 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_value1081 REAL(dp) , INTENT(IN) :: dd_fill1082 CHARACTER(LEN=*) , INTENT(IN) :: cd_dim1083 LOGICAL , INTENT(IN), OPTIONAL :: ld_discont1084 1085 ! function1086 REAL(dp), DIMENSION(SIZE(dd_value,DIM=1), &1087 & SIZE(dd_value,DIM=2) ) :: extrap_deriv_2D1088 1089 ! local variable1090 INTEGER(i4) :: il_imin1091 INTEGER(i4) :: il_imax1092 INTEGER(i4) :: il_jmin1093 INTEGER(i4) :: il_jmax1094 INTEGER(i4), DIMENSION(2) :: il_shape1095 1096 REAL(dp) :: dl_min1097 REAL(dp) :: dl_max1098 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_value1099 1100 LOGICAL :: ll_discont1101 1102 ! loop indices1103 INTEGER(i4) :: ji1104 INTEGER(i4) :: jj1105 1106 INTEGER(i4) :: i11107 INTEGER(i4) :: i21108 1109 INTEGER(i4) :: j11110 INTEGER(i4) :: j21111 !----------------------------------------------------------------1112 ! init1113 extrap_deriv_2D(:,:)=dd_fill1114 1115 ll_discont=.FALSE.1116 IF( PRESENT(ld_discont) ) ll_discont=ld_discont1117 1118 il_shape(:)=SHAPE(dd_value(:,:))1119 1120 SELECT CASE(TRIM(fct_upper(cd_dim)))1121 1122 CASE('I')1123 1124 ALLOCATE( dl_value(3,il_shape(2)) )1125 ! compute derivative in i-direction1126 DO ji=1,il_shape(1)1127 1128 ! init1129 dl_value(:,:)=dd_fill1130 1131 il_imin=MAX(ji-1,1)1132 il_imax=MIN(ji+1,il_shape(1))1133 1134 IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN1135 i1=1 ; i2=31136 ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN1137 i1=1 ; i2=21138 ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN1139 i1=2 ; i2=31140 ENDIF1141 1142 dl_value(i1:i2,:)=dd_value(il_imin:il_imax,:)1143 IF( il_imin == 1 )THEN1144 dl_value(:,:)=EOSHIFT( dl_value(:,:), &1145 & DIM=1, &1146 & SHIFT=-1, &1147 & BOUNDARY=dl_value(1,:) )1148 ENDIF1149 IF( il_imax == il_shape(1) )THEN1150 dl_value(:,:)=EOSHIFT( dl_value(:,:), &1151 & DIM=1, &1152 & SHIFT=1, &1153 & BOUNDARY=dl_value(3,:))1154 ENDIF1155 1156 IF( ll_discont )THEN1157 dl_min=MINVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )1158 dl_max=MAXVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )1159 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1160 WHERE( dl_value(:,:) < 0_dp )1161 dl_value(:,:) = dl_value(:,:)+360._dp1162 END WHERE1163 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1164 WHERE( dl_value(:,:) > 180 )1165 dl_value(:,:) = dl_value(:,:)-180._dp1166 END WHERE1167 ENDIF1168 ENDIF1169 1170 WHERE( dl_value(2,:) /= dd_fill .AND. & ! ji1171 & dl_value(3,:) /= dd_fill .AND. & ! ji+11172 & dl_value(1,:) /= dd_fill ) ! ji-11173 1174 extrap_deriv_2D(ji,:)=&1175 & ( dl_value(3,:) - dl_value(1,:) ) / &1176 & REAL( il_imax-il_imin,dp)1177 1178 END WHERE1179 1180 ENDDO1181 1182 CASE('J')1183 1184 ALLOCATE( dl_value(il_shape(1),3) )1185 ! compute derivative in j-direction1186 DO jj=1,il_shape(2)1187 1188 il_jmin=MAX(jj-1,1)1189 il_jmax=MIN(jj+1,il_shape(2))1190 1191 IF( il_jmin==jj-1 .AND. il_jmax==jj+1 )THEN1192 j1=1 ; j2=31193 ELSEIF( il_jmin==jj .AND. il_jmax==jj+1 )THEN1194 j1=1 ; j2=21195 ELSEIF( il_jmin==jj-1 .AND. il_jmax==jj )THEN1196 j1=2 ; j2=31197 ENDIF1198 1199 dl_value(:,j1:j2)=dd_value(:,il_jmin:il_jmax)1200 IF( il_jmin == 1 )THEN1201 dl_value(:,:)=EOSHIFT( dl_value(:,:), &1202 & DIM=2, &1203 & SHIFT=-1, &1204 & BOUNDARY=dl_value(:,1))1205 ENDIF1206 IF( il_jmax == il_shape(2) )THEN1207 dl_value(:,:)=EOSHIFT( dl_value(:,:), &1208 & DIM=2, &1209 & SHIFT=1, &1210 & BOUNDARY=dl_value(:,3))1211 ENDIF1212 1213 IF( ll_discont )THEN1214 dl_min=MINVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )1215 dl_max=MAXVAL( dl_value(:,:), dl_value(:,:)/=dd_fill )1216 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1217 WHERE( dl_value(:,:) < 0_dp )1218 dl_value(:,:) = dl_value(:,:)+360._dp1219 END WHERE1220 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1221 WHERE( dl_value(:,:) > 180 )1222 dl_value(:,:) = dl_value(:,:)-180._dp1223 END WHERE1224 ENDIF1225 ENDIF1226 1227 WHERE( dl_value(:, 2) /= dd_fill .AND. & ! jj1228 & dl_value(:, 3) /= dd_fill .AND. & ! jj+11229 & dl_value(:, 1) /= dd_fill ) ! jj-11230 1231 extrap_deriv_2D(:,jj)=&1232 & ( dl_value(:,3) - dl_value(:,1) ) / &1233 & REAL(il_jmax-il_jmin,dp)1234 1235 END WHERE1236 1237 ENDDO1238 1239 END SELECT1240 1241 DEALLOCATE( dl_value )1242 1243 END FUNCTION extrap_deriv_2D1244 !-------------------------------------------------------------------1245 !> @brief1246 !> This function compute derivative of 3D array.1247 !> you have to specify in which direction derivative have to be computed:1248 !> first (I), second (J) or third (K) dimension.1249 !>1250 !> @details1251 !> optionaly you could specify to take into account east west discontinuity1252 !> (-180° 180° or 0° 360° for longitude variable)1253 !>1254 !> @author J.Paul1255 !> - November, 2013- Initial Version1256 !1257 !> @param[inout] dd_value 3D array of variable to be extrapolated1258 !> @param[in] dd_fill FillValue of variable1259 !> @param[in] cd_dim compute derivative on first (I) second (J) or third (K) dimension1260 !> @param[in] ld_discont logical to take into account east west discontinuity1261 !-------------------------------------------------------------------1262 PURE FUNCTION extrap_deriv_3D( dd_value, dd_fill, cd_dim, ld_discont )1263 1264 IMPLICIT NONE1265 ! Argument1266 REAL(dp) , DIMENSION(:,:,:), INTENT(IN) :: dd_value1267 REAL(dp) , INTENT(IN) :: dd_fill1268 CHARACTER(LEN=*) , INTENT(IN) :: cd_dim1269 LOGICAL , INTENT(IN), OPTIONAL :: ld_discont1270 1271 ! function1272 REAL(dp), DIMENSION(SIZE(dd_value,DIM=1), &1273 & SIZE(dd_value,DIM=2), &1274 & SIZE(dd_value,DIM=3)) :: extrap_deriv_3D1275 1276 ! local variable1277 INTEGER(i4) :: il_imin1278 INTEGER(i4) :: il_imax1279 INTEGER(i4) :: il_jmin1280 INTEGER(i4) :: il_jmax1281 INTEGER(i4) :: il_kmin1282 INTEGER(i4) :: il_kmax1283 INTEGER(i4), DIMENSION(3) :: il_shape1284 1285 REAL(dp) :: dl_min1286 REAL(dp) :: dl_max1287 REAL(dp) , DIMENSION(:,:,:), ALLOCATABLE :: dl_value1288 1289 LOGICAL :: ll_discont1290 1291 ! loop indices1292 INTEGER(i4) :: ji1293 INTEGER(i4) :: jj1294 INTEGER(i4) :: jk1295 1296 INTEGER(i4) :: i11297 INTEGER(i4) :: i21298 1299 INTEGER(i4) :: j11300 INTEGER(i4) :: j21301 1302 INTEGER(i4) :: k11303 INTEGER(i4) :: k21304 !----------------------------------------------------------------1305 ! init1306 extrap_deriv_3D(:,:,:)=dd_fill1307 1308 ll_discont=.FALSE.1309 IF( PRESENT(ld_discont) ) ll_discont=ld_discont1310 1311 il_shape(:)=SHAPE(dd_value(:,:,:))1312 1313 1314 SELECT CASE(TRIM(fct_upper(cd_dim)))1315 1316 CASE('I')1317 1318 ALLOCATE( dl_value(3,il_shape(2),il_shape(3)) )1319 ! compute derivative in i-direction1320 DO ji=1,il_shape(1)1321 1322 il_imin=MAX(ji-1,1)1323 il_imax=MIN(ji+1,il_shape(1))1324 1325 IF( il_imin==ji-1 .AND. il_imax==ji+1 )THEN1326 i1=1 ; i2=31327 ELSEIF( il_imin==ji .AND. il_imax==ji+1 )THEN1328 i1=1 ; i2=21329 ELSEIF( il_imin==ji-1 .AND. il_imax==ji )THEN1330 i1=2 ; i2=31331 ENDIF1332 1333 dl_value(i1:i2,:,:)=dd_value(il_imin:il_imax,:,:)1334 IF( il_imin == 1 )THEN1335 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1336 & DIM=1, &1337 & SHIFT=-1, &1338 & BOUNDARY=dl_value(1,:,:) )1339 ENDIF1340 IF( il_imax == il_shape(1) )THEN1341 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1342 & DIM=1, &1343 & SHIFT=1, &1344 & BOUNDARY=dl_value(3,:,:))1345 ENDIF1346 1347 IF( ll_discont )THEN1348 dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1349 dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1350 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1351 WHERE( dl_value(:,:,:) < 0_dp )1352 dl_value(:,:,:) = dl_value(:,:,:)+360._dp1353 END WHERE1354 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1355 WHERE( dl_value(:,:,:) > 180 )1356 dl_value(:,:,:) = dl_value(:,:,:)-180._dp1357 END WHERE1358 ENDIF1359 ENDIF1360 1361 WHERE( dl_value(2,:,:) /= dd_fill .AND. & ! ji1362 & dl_value(3,:,:) /= dd_fill .AND. & !ji+11363 & dl_value(1,:,:) /= dd_fill ) !ji-11364 1365 extrap_deriv_3D(ji,:,:)= &1366 & ( dl_value(3,:,:) - dl_value(1,:,:) ) / &1367 & REAL( il_imax-il_imin ,dp)1368 1369 END WHERE1370 1371 ENDDO1372 1373 CASE('J')1374 1375 ALLOCATE( dl_value(il_shape(1),3,il_shape(3)) )1376 ! compute derivative in j-direction1377 DO jj=1,il_shape(2)1378 1379 il_jmin=MAX(jj-1,1)1380 il_jmax=MIN(jj+1,il_shape(2))1381 1382 IF( il_jmin==jj-1 .AND. il_jmax==jj+1 )THEN1383 j1=1 ; j2=31384 ELSEIF( il_jmin==jj .AND. il_jmax==jj+1 )THEN1385 j1=1 ; j2=21386 ELSEIF( il_jmin==jj-1 .AND. il_jmax==jj )THEN1387 j1=2 ; j2=31388 ENDIF1389 1390 dl_value(:,j1:j2,:)=dd_value(:,il_jmin:il_jmax,:)1391 IF( il_jmin == 1 )THEN1392 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1393 & DIM=2, &1394 & SHIFT=-1, &1395 & BOUNDARY=dl_value(:,1,:) )1396 ENDIF1397 IF( il_jmax == il_shape(2) )THEN1398 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1399 & DIM=2, &1400 & SHIFT=1, &1401 & BOUNDARY=dl_value(:,3,:))1402 ENDIF1403 1404 IF( ll_discont )THEN1405 dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1406 dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1407 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1408 WHERE( dl_value(:,:,:) < 0_dp )1409 dl_value(:,:,:) = dl_value(:,:,:)+360._dp1410 END WHERE1411 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1412 WHERE( dl_value(:,:,:) > 180 )1413 dl_value(:,:,:) = dl_value(:,:,:)-180._dp1414 END WHERE1415 ENDIF1416 ENDIF1417 1418 WHERE( dl_value(:, 2,:) /= dd_fill .AND. & ! jj1419 & dl_value(:, 3,:) /= dd_fill .AND. & ! jj+11420 & dl_value(:, 1,:) /= dd_fill ) ! jj-11421 1422 extrap_deriv_3D(:,jj,:)=&1423 & ( dl_value(:,3,:) - dl_value(:,1,:) ) / &1424 & REAL( il_jmax - il_jmin ,dp)1425 1426 END WHERE1427 1428 ENDDO1429 1430 CASE('K')1431 ! compute derivative in k-direction1432 DO jk=1,il_shape(3)1433 1434 il_kmin=MAX(jk-1,1)1435 il_kmax=MIN(jk+1,il_shape(3))1436 1437 IF( il_kmin==jk-1 .AND. il_kmax==jk+1 )THEN1438 k1=1 ; k2=31439 ELSEIF( il_kmin==jk .AND. il_kmax==jk+1 )THEN1440 k1=1 ; k2=21441 ELSEIF( il_kmin==jk-1 .AND. il_kmax==jk )THEN1442 k1=2 ; k2=31443 ENDIF1444 1445 dl_value(:,:,k1:k2)=dd_value(:,:,il_kmin:il_kmax)1446 IF( il_kmin == 1 )THEN1447 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1448 & DIM=3, &1449 & SHIFT=-1, &1450 & BOUNDARY=dl_value(:,:,1) )1451 ENDIF1452 IF( il_kmax == il_shape(3) )THEN1453 dl_value(:,:,:)=EOSHIFT( dl_value(:,:,:), &1454 & DIM=3, &1455 & SHIFT=1, &1456 & BOUNDARY=dl_value(:,:,3))1457 ENDIF1458 1459 IF( ll_discont )THEN1460 dl_min=MINVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1461 dl_max=MAXVAL( dl_value(:,:,:), dl_value(:,:,:)/=dd_fill )1462 IF( dl_min < -170_dp .AND. dl_max > 170_dp )THEN1463 WHERE( dl_value(:,:,:) < 0_dp )1464 dl_value(:,:,:) = dl_value(:,:,:)+360._dp1465 END WHERE1466 ELSEIF( dl_min < 10_dp .AND. dl_max > 350_dp )THEN1467 WHERE( dl_value(:,:,:) > 180 )1468 dl_value(:,:,:) = dl_value(:,:,:)-180._dp1469 END WHERE1470 ENDIF1471 ENDIF1472 1473 WHERE( dl_value(:,:, 2) /= dd_fill .AND. & ! jk1474 & dl_value(:,:, 3) /= dd_fill .AND. & ! jk+11475 & dl_value(:,:, 1) /= dd_fill ) ! jk-11476 1477 extrap_deriv_3D(:,:,jk)=&1478 & ( dl_value(:,:,3) - dl_value(:,:,1) ) / &1479 & REAL( il_kmax-il_kmin,dp)1480 1481 END WHERE1482 1483 ENDDO1484 1485 END SELECT1486 1487 DEALLOCATE( dl_value )1488 1489 END FUNCTION extrap_deriv_3D1490 841 !------------------------------------------------------------------- 1491 842 !> @brief … … 1493 844 !> 1494 845 !> @details 1495 !> coefficients are "grid distance" to the center of the box choosed to compute1496 !> extrapolation.846 !> coefficients are "grid distance" to the center of the box 847 !> choosed to compute extrapolation. 1497 848 !> 1498 849 !> @author J.Paul 1499 !> - November, 2013- Initial Version 850 !> @date November, 2013 - Initial Version 851 !> @date July, 2015 852 !> - decrease weight of third dimension 1500 853 ! 1501 854 !> @param[in] dd_value 3D array of variable to be extrapolated … … 1544 897 1545 898 ! compute distance 899 ! "vertical weight" is lower than horizontal 1546 900 dl_dist(ji,jj,jk) = (ji-il_imid)**2 + & 1547 901 & (jj-il_jmid)**2 + & 1548 & 902 & 3*(jk-il_kmid)**2 1549 903 1550 904 IF( dl_dist(ji,jj,jk) /= 0 )THEN … … 1658 1012 !> 1659 1013 !> @author J.Paul 1660 !> - November, 2013- Initial Version 1014 !> @date November, 2013 - Initial Version 1015 !> @date July, 2015 1016 !> - decrease weight of third dimension 1661 1017 ! 1662 1018 !> @param[in] dd_value 3D array of variable to be extrapolated … … 1705 1061 1706 1062 ! compute distance 1063 ! "vertical weight" is lower than horizontal 1707 1064 dl_dist(ji,jj,jk) = (ji-il_imid)**2 + & 1708 1065 & (jj-il_jmid)**2 + & 1709 & 1066 & 3*(jk-il_kmid)**2 1710 1067 1711 1068 IF( dl_dist(ji,jj,jk) /= 0 )THEN … … 1732 1089 !> 1733 1090 !> @author J.Paul 1734 !> - November, 2013 - Initial Version1091 !> - November, 2013 - Initial Version 1735 1092 ! 1736 1093 !> @param[in] dd_value 3D array of variable to be extrapolated … … 1763 1120 INTEGER(i4) :: jj 1764 1121 INTEGER(i4) :: jk 1765 1766 1122 !---------------------------------------------------------------- 1767 1123 … … 1793 1149 ENDDO 1794 1150 ENDDO 1151 1795 1152 1796 1153 ! return value … … 1917 1274 !> 1918 1275 !> @author J.Paul 1919 !> - November, 2013 -Initial version1276 !> - November, 2013 - Initial version 1920 1277 !> 1921 1278 !> @param[inout] td_var variable -
trunk/NEMOGCM/TOOLS/SIREN/src/file.f90
r5037 r5609 137 137 !> J.Paul 138 138 ! REVISION HISTORY: 139 !> @date November, 2013- Initial Version 140 !> @date November, 2014 - Fix memory leaks bug 139 !> @date November, 2013 - Initial Version 140 !> @date November, 2014 141 !> - Fix memory leaks bug 141 142 !> 142 143 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 288 289 !> 289 290 !> @author J.Paul 290 !> - November, 2013- Initial Version291 !> @date November, 2013 - Initial Version 291 292 !> @date November, 2014 292 !> 293 !> - use function instead of overload assignment operator 293 294 !> (to avoid memory leak) 294 295 ! … … 409 410 !> 410 411 !> @author J.Paul 411 !> - November, 2013- Initial Version412 !> @date November, 2013 - Initial Version 412 413 !> @date November, 2014 413 !> 414 !> - use function instead of overload assignment operator 414 415 !> (to avoid memory leak) 415 416 ! … … 604 605 CHARACTER(LEN=lc) :: cl_dim 605 606 LOGICAL :: ll_error 606 607 INTEGER(i4) :: il_ind 607 LOGICAL :: ll_warn 608 609 INTEGER(i4) :: il_ind 608 610 609 611 ! loop indices … … 614 616 ! check used dimension 615 617 ll_error=.FALSE. 618 ll_warn=.FALSE. 616 619 DO ji=1,ip_maxdim 617 620 il_ind=dim_get_index( td_file%t_dim(:), & … … 619 622 & TRIM(td_var%t_dim(ji)%c_sname)) 620 623 IF( il_ind /= 0 )THEN 621 IF( td_var%t_dim(ji)%l_use .AND. & 622 & td_file%t_dim(il_ind)%l_use .AND. & 623 & td_var%t_dim(ji)%i_len /= td_file%t_dim(il_ind)%i_len )THEN 624 ll_error=.TRUE. 625 ENDIF 624 IF( td_var%t_dim(ji)%l_use .AND. & 625 & td_file%t_dim(il_ind)%l_use .AND. & 626 & td_var%t_dim(ji)%i_len /= td_file%t_dim(il_ind)%i_len )THEN 627 IF( INDEX( TRIM(td_var%c_axis), & 628 & TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN 629 ll_warn=.TRUE. 630 ELSE 631 ll_error=.TRUE. 632 ENDIF 633 ENDIF 626 634 ENDIF 627 635 ENDDO 628 636 629 637 IF( ll_error )THEN 630 631 file_check_var_dim=.FALSE.632 633 CALL logger_error( &634 & " FILE CHECK VAR DIM: variable and file dimension differ"//&635 & " for variable "//TRIM(td_var%c_name)//&636 & " and file "//TRIM(td_file%c_name))637 638 638 639 639 cl_dim='(/' … … 659 659 CALL logger_debug( " variable dimension: "//TRIM(cl_dim) ) 660 660 661 file_check_var_dim=.FALSE. 662 663 CALL logger_error( & 664 & " FILE CHECK VAR DIM: variable and file dimension differ"//& 665 & " for variable "//TRIM(td_var%c_name)//& 666 & " and file "//TRIM(td_file%c_name)) 667 668 ELSEIF( ll_warn )THEN 669 CALL logger_warn( & 670 & " FILE CHECK VAR DIM: variable and file dimension differ"//& 671 & " for variable "//TRIM(td_var%c_name)//& 672 & " and file "//TRIM(td_file%c_name)//". you should use"//& 673 & " var_check_dim to remove useless dimension.") 661 674 ELSE 662 675 … … 679 692 ! 680 693 !> @author J.Paul 681 !> - November, 2013- Initial Version694 !> @date November, 2013 - Initial Version 682 695 !> @date September, 2014 683 696 !> - add dimension to file if need be … … 707 720 IF( TRIM(td_file%c_name) == '' )THEN 708 721 709 CALL logger_error( " FILE ADD VAR: structure file unknown" )710 722 CALL logger_debug( " FILE ADD VAR: you should have used file_init before "//& 711 723 & "running file_add_var" ) 724 CALL logger_error( " FILE ADD VAR: structure file unknown" ) 712 725 713 726 ELSE … … 723 736 & td_var%c_stdname ) 724 737 ENDIF 725 738 CALL logger_debug( & 739 & " FILE ADD VAR: ind "//TRIM(fct_str(il_ind)) ) 726 740 IF( il_ind /= 0 )THEN 727 741 … … 739 753 ELSE 740 754 741 CALL logger_ trace( &755 CALL logger_debug( & 742 756 & " FILE ADD VAR: add variable "//TRIM(td_var%c_name)//& 743 757 & ", standard name "//TRIM(td_var%c_stdname)//& … … 770 784 !il_rec=td_file%t_dim(3)%i_len 771 785 END SELECT 772 CALL logger_info( &773 & " FILE ADD VAR: variable index "//TRIM(fct_str(il_ind)))774 786 775 787 IF( td_file%i_nvar > 0 )THEN … … 806 818 ENDIF 807 819 808 IF( il_ind < td_file%i_nvar )THEN820 IF( il_ind < td_file%i_nvar+1 )THEN 809 821 ! variable with more dimension than new variable 810 822 td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = & … … 893 905 ! 894 906 !> @author J.Paul 895 !> - November, 2013- Initial Version 907 !> @date November, 2013 - Initial Version 908 !> @date February, 2015 909 !> - define local variable structure to avoid mistake with pointer 896 910 ! 897 911 !> @param[inout] td_file file structure … … 907 921 ! local variable 908 922 INTEGER(i4) :: il_ind 923 TYPE(TVAR) :: tl_var 909 924 !---------------------------------------------------------------- 910 925 … … 928 943 IF( il_ind /= 0 )THEN 929 944 930 CALL file_del_var(td_file, td_file%t_var(il_ind)) 945 tl_var=var_copy(td_file%t_var(il_ind)) 946 CALL file_del_var(td_file, tl_var) 931 947 932 948 ELSE 933 949 934 CALL logger_ warn( &950 CALL logger_debug( & 935 951 & " FILE DEL VAR NAME: there is no variable with name or "//& 936 952 & "standard name "//TRIM(cd_name)//" in file "//& … … 1247 1263 ! 1248 1264 !> @author J.Paul 1249 !> - November, 2013- Initial Version 1265 !> @date November, 2013 - Initial Version 1266 !> @date February, 2015 1267 !> - define local attribute structure to avoid mistake 1268 !> with pointer 1250 1269 ! 1251 1270 !> @param[inout] td_file file structure … … 1261 1280 ! local variable 1262 1281 INTEGER(i4) :: il_ind 1282 TYPE(TATT) :: tl_att 1263 1283 !---------------------------------------------------------------- 1264 1284 … … 1282 1302 IF( il_ind /= 0 )THEN 1283 1303 1284 CALL file_del_att(td_file, td_file%t_att(il_ind)) 1304 tl_att=att_copy(td_file%t_att(il_ind)) 1305 CALL file_del_att(td_file, tl_att) 1285 1306 1286 1307 ELSE 1287 1308 1288 CALL logger_ warn( &1309 CALL logger_debug( & 1289 1310 & " FILE DEL ATT NAME: there is no attribute with name "//& 1290 1311 & TRIM(cd_name)//" in file "//TRIM(td_file%c_name)) … … 1444 1465 ! 1445 1466 !> @author J.Paul 1446 !> - November, 2013- Initial Version1467 !> @date November, 2013 - Initial Version 1447 1468 !> @date September, 2014 1448 1469 !> - do not reorder dimension, before put in file … … 1717 1738 WRITE(*,'(/a)') " File variable" 1718 1739 DO ji=1,td_file%i_nvar 1719 CALL var_print(td_file%t_var(ji) )!,.FALSE.)1740 CALL var_print(td_file%t_var(ji),.FALSE.) 1720 1741 ENDDO 1721 1742 ENDIF … … 1769 1790 ! 1770 1791 !> @author J.Paul 1771 !> - November, 2013- Initial Version 1792 !> @date November, 2013 - Initial Version 1793 !> @date February, 2015 1794 !> - add case to not return date (yyyymmdd) at the end of filename 1795 !> @date February, 2015 1796 !> - add case to not return release number 1797 !> we assume release number only on one digit (ex : file_v3.5.nc) 1772 1798 ! 1773 1799 !> @param[in] cd_file file name (without suffix) … … 1802 1828 1803 1829 IF( .NOT. fct_is_num(file__get_number(2:)) )THEN 1830 file__get_number='' 1831 ELSEIF( LEN(TRIM(file__get_number))-1 == 8 )THEN 1832 ! date case yyyymmdd 1833 file__get_number='' 1834 ELSEIF( LEN(TRIM(file__get_number))-1 == 1 )THEN 1835 ! release number case 1804 1836 file__get_number='' 1805 1837 ENDIF -
trunk/NEMOGCM/TOOLS/SIREN/src/filter.f90
r5037 r5609 18 18 !> - rad > cutoff : @f$ filter=0 @f$ 19 19 !> - 'blackman' 20 !> - rad < cutoff : @f$ filter=0.42 + 0.5*COS(\pi*\frac{rad}{cutoff}) + 0.08*COS(2\pi*\frac{rad}{cutoff}) @f$ 20 !> - rad < cutoff : @f$ filter=0.42 + 0.5*COS(\pi*\frac{rad}{cutoff}) + 21 !> 0.08*COS(2\pi*\frac{rad}{cutoff}) @f$ 21 22 !> - rad > cutoff : @f$ filter=0 @f$ 22 23 !> - 'gauss' … … 29 30 !> 30 31 !> td_var\%c_filter(2) string character is the number of turn to be done<br/> 31 !> td_var\%c_filter(3) string character is the cut-off frequency (count in number of mesh grid)<br/> 32 !> td_var\%c_filter(4) string character is the halo radius (count in number of mesh grid)<br/> 33 !> td_var\%c_filter(5) string character is the alpha parameter (for gauss and butterworth method)<br/> 32 !> td_var\%c_filter(3) string character is the cut-off frequency 33 ! > (count in number of mesh grid)<br/> 34 !> td_var\%c_filter(4) string character is the halo radius 35 !> (count in number of mesh grid)<br/> 36 !> td_var\%c_filter(5) string character is the alpha parameter 37 !> (for gauss and butterworth method)<br/> 34 38 !> 35 39 !> @note Filter method could be specify for each variable in namelist _namvar_, … … 40 44 !> The number of turn is specify using '*' separator.<br/> 41 45 !> Example: 42 !> - cn_varinfo='varname1:2*hamming(@f$cutoff@f$,@f$radius@f$)', 'varname2:gauss(@f$cutoff@f$,@f$radius@f$,@f$\alpha@f$)' 46 !> - cn_varinfo='varname1:flt=2*hamming(@f$cutoff@f$,@f$radius@f$)', 47 !> 'varname2:flt=gauss(@f$cutoff@f$,@f$radius@f$,@f$\alpha@f$)' 43 48 !> 44 49 !> to filter variable value:<br/> … … 106 111 !> 107 112 !> @author J.Paul 108 !> - November, 2013- Initial Version113 !> @date November, 2013 - Initial Version 109 114 ! 110 115 !> @param[inout] td_var variable structure … … 250 255 !> 251 256 !> @author J.Paul 252 !> - November, 2013- Initial Version257 !> @date November, 2013 - Initial Version 253 258 ! 254 259 !> @param[inout] td_var variable … … 296 301 297 302 !3-extrapolate 298 CALL extrap_fill_value( td_var , id_iext=id_radius, id_jext=id_radius )303 CALL extrap_fill_value( td_var ) !, id_iext=id_radius, id_jext=id_radius ) 299 304 300 305 !4-filtering … … 341 346 ! 342 347 !> @author J.Paul 343 !> - November, 2013- Initial Version348 !> @date November, 2013 - Initial Version 344 349 ! 345 350 !> @param[inout] dd_value array of value to be filtered … … 393 398 !> 394 399 !> @author J.Paul 395 !> - November, 2013- Initial Version400 !> @date November, 2013 - Initial Version 396 401 ! 397 402 !> @param[inout] dd_value array of value to be filtered … … 439 444 !> 440 445 !> @author J.Paul 441 !> - November, 2013- Initial Version446 !> @date November, 2013 - Initial Version 442 447 ! 443 448 !> @param[inout] dd_value array of value to be filtered … … 482 487 !> 483 488 !> @author J.Paul 484 !> - November, 2013- Initial Version489 !> @date November, 2013 - Initial Version 485 490 ! 486 491 !> @param[inout] dd_value array of value to be filtered … … 537 542 !> 538 543 !> @author J.Paul 539 !> - Nov, 2013- Initial Version544 !> @date November, 2013 - Initial Version 540 545 ! 541 546 !> @param[inout] dd_value array of value to be filtered … … 590 595 ! 591 596 !> @author J.Paul 592 !> - November, 2013- Initial Version597 !> @date November, 2013 - Initial Version 593 598 ! 594 599 !> @param[in] cd_name filter name … … 649 654 ! 650 655 !> @author J.Paul 651 !> - November, 2013- Initial Version656 !> @date November, 2013 - Initial Version 652 657 ! 653 658 !> @param[in] cd_name filter name … … 695 700 ! 696 701 !> @author J.Paul 697 !> - November, 2013- Initial Version702 !> @date November, 2013 - Initial Version 698 703 ! 699 704 !> @param[in] dd_cutoff cut-off frequency … … 749 754 ! 750 755 !> @author J.Paul 751 !> - November, 2013- Initial Version756 !> @date November, 2013 - Initial Version 752 757 ! 753 758 !> @param[in] dd_cutoff cut-off frequency … … 808 813 ! 809 814 !> @author J.Paul 810 !> - November, 2013- Initial Version815 !> @date November, 2013 - Initial Version 811 816 ! 812 817 !> @param[in] dd_cutoff cut-off frequency … … 863 868 ! 864 869 !> @author J.Paul 865 !> - November, 2013- Initial Version870 !> @date November, 2013 - Initial Version 866 871 ! 867 872 !> @param[in] dd_cutoff cut-off frequency … … 922 927 ! 923 928 !> @author J.Paul 924 !> - November, 2013- Initial Version929 !> @date November, 2013 - Initial Version 925 930 ! 926 931 !> @param[in] dd_cutoff cut-off frequency … … 978 983 !> 979 984 !> @author J.Paul 980 !> - November, 2013- Initial Version985 !> @date November, 2013 - Initial Version 981 986 !> 982 987 !> @param[in] dd_cutoff cut-off frequency … … 1038 1043 !> 1039 1044 !> @author J.Paul 1040 !> - November, 2013- Initial Version1045 !> @date November, 2013 - Initial Version 1041 1046 !> 1042 1047 !> @param[in] dd_cutoff cut-off frequency … … 1090 1095 !> 1091 1096 !> @author J.Paul 1092 !> - November, 2013- Initial Version1097 !> @date November, 2013 - Initial Version 1093 1098 !> 1094 1099 !> @param[in] dd_cutoff cut-off frequency … … 1146 1151 !> 1147 1152 !> @author J.Paul 1148 !> - November, 2013- Initial Version1153 !> @date November, 2013 - Initial Version 1149 1154 !> 1150 1155 !> @param[in] dd_cutoff cut-off frequency … … 1198 1203 !> 1199 1204 !> @author J.Paul 1200 !> - November, 2013- Initial Version1205 !> @date November, 2013 - Initial Version 1201 1206 !> 1202 1207 !> @param[in] dd_cutoff cut-off frequency -
trunk/NEMOGCM/TOOLS/SIREN/src/function.f90
r5037 r5609 51 51 !> @endcode 52 52 !> 53 !> to check if character is real 54 !> @code 55 !> ll_is_real=fct_is_real(cd_var) 56 !> @endcode 57 !> 53 58 !> to split string into substring and return one of the element:<br/> 54 59 !> @code … … 89 94 ! REVISION HISTORY: 90 95 !> @date November, 2013 - Initial Version 91 !> @date September, 2014 - add header 96 !> @date September, 2014 97 !> - add header 92 98 ! 93 99 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 106 112 PUBLIC :: fct_lower !< convert character from upper to lower case 107 113 PUBLIC :: fct_is_num !< check if character is numeric 114 PUBLIC :: fct_is_real !< check if character is real 108 115 PUBLIC :: fct_split !< split string into substring 109 116 PUBLIC :: fct_basename !< return basename (name without path) … … 153 160 ! 154 161 !> @author J.Paul 155 !> - September, 2014- Initial Version162 !> @date September, 2014 - Initial Version 156 163 ! 157 164 !> @param[in] cd_char string character … … 177 184 ! 178 185 !> @author J.Paul 179 !> - September, 2014- Initial Version186 !> @date September, 2014 - Initial Version 180 187 ! 181 188 !> @param[in] cd_char string character … … 201 208 ! 202 209 !> @author J.Paul 203 !> - Nov, 2013- Initial Version210 !> @date November, 2013 - Initial Version 204 211 ! 205 212 !> @param[in] cd_char string character … … 225 232 ! 226 233 !> @author J.Paul 227 !> - November, 2013- Initial Version234 !> @date November, 2013 - Initial Version 228 235 ! 229 236 !> @param[in] cd_char string character … … 249 256 ! 250 257 !> @author J.Paul 251 !> - November, 2013- Initial Version258 !> @date November, 2013 - Initial Version 252 259 ! 253 260 !> @param[in] cd_char string character … … 273 280 !> 274 281 !> @author J.Paul 275 !> - November, 2013- Initial Version282 !> @date November, 2013 - Initial Version 276 283 !> 277 284 !> @param[in] cd_char string character … … 297 304 !> 298 305 !> @author J.Paul 299 !> - November, 2013- Initial Version306 !> @date November, 2013 - Initial Version 300 307 !> 301 308 !> @param[in] cd_char string character … … 321 328 !> 322 329 !> @author J.Paul 323 !> - November, 2013- Initial Version330 !> @date November, 2013 - Initial Version 324 331 !> 325 332 !> @return file id … … 344 351 ! 345 352 !> @author J.Paul 346 !> - November, 2013- Initial Version353 !> @date November, 2013 - Initial Version 347 354 !> 348 355 !> @param[in] id_status … … 365 372 ! 366 373 !> @author J.Paul 367 !> - November, 2014- Initial Version374 !> @date November, 2014 - Initial Version 368 375 !> 369 376 !> @param[in] cd_msg optional message to be added … … 387 394 !> 388 395 !> @author J.Paul 389 !> - November, 2013- Initial Version396 !> @date November, 2013 - Initial Version 390 397 ! 391 398 !> @param[in] ld_var logical variable … … 409 416 !> 410 417 !> @author J.Paul 411 !> - November, 2013- Initial Version418 !> @date November, 2013 - Initial Version 412 419 ! 413 420 !> @param[in] bd_var integer(1) variable … … 431 438 !> 432 439 !> @author J.Paul 433 !> - November, 2013- Initial Version440 !> @date November, 2013 - Initial Version 434 441 ! 435 442 !> @param[in] sd_var integer(2) variable … … 453 460 !> 454 461 !> @author J.Paul 455 !> - November, 2013- Initial Version462 !> @date November, 2013 - Initial Version 456 463 ! 457 464 !> @param[in] id_var integer(4) variable … … 475 482 !> 476 483 !> @author J.Paul 477 !> - November, 2013- Initial Version484 !> @date November, 2013 - Initial Version 478 485 ! 479 486 !> @param[in] kd_var integer(8) variable … … 497 504 !> 498 505 !> @author J.Paul 499 !> - November, 2013- Initial Version506 !> @date November, 2013 - Initial Version 500 507 ! 501 508 !> @param[in] rd_var real(4) variable … … 519 526 !> 520 527 !> @author J.Paul 521 !> - November, 2013- Initial Version528 !> @date November, 2013 - Initial Version 522 529 ! 523 530 !> @param[in] dd_var real(8) variable … … 544 551 !> 545 552 !> @author J.Paul 546 !> - November, 2013- Initial Version553 !> @date November, 2013 - Initial Version 547 554 ! 548 555 !> @param[in] cd_arr array of character … … 590 597 ! 591 598 !> @author J.Paul 592 !> - November, 2013- Initial Version599 !> @date November, 2013 - Initial Version 593 600 ! 594 601 !> @param[in] cd_var character … … 647 654 ! 648 655 !> @author J.Paul 649 !> - November, 2013- Initial Version656 !> @date November, 2013 - Initial Version 650 657 ! 651 658 !> @param[in] cd_var character … … 697 704 ! 698 705 !> @author J.Paul 699 !> - November, 2013- Initial Version706 !> @date November, 2013 - Initial Version 700 707 ! 701 708 !> @param[in] cd_var character … … 723 730 END FUNCTION fct_is_num 724 731 !------------------------------------------------------------------- 732 !> @brief This function check if character is real number. 733 ! 734 !> @details 735 !> it allows exponantial and decimal number 736 !> exemple : 1e6, 2.3 737 !> 738 !> @author J.Paul 739 !> @date June, 2015 - Initial Version 740 ! 741 !> @param[in] cd_var character 742 !> @return character is numeric 743 !------------------------------------------------------------------- 744 PURE LOGICAL FUNCTION fct_is_real(cd_var) 745 IMPLICIT NONE 746 ! Argument 747 CHARACTER(LEN=*), INTENT(IN) :: cd_var 748 749 ! local variables 750 LOGICAL :: ll_exp 751 LOGICAL :: ll_dec 752 753 ! loop indices 754 INTEGER :: ji 755 !---------------------------------------------------------------- 756 757 ll_exp=.TRUE. 758 ll_dec=.FALSE. 759 DO ji=1,LEN(TRIM(cd_var)) 760 IF( IACHAR(cd_var(ji:ji)) >= IACHAR('0') .AND. & 761 & IACHAR(cd_var(ji:ji)) <= IACHAR('9') )THEN 762 763 fct_is_real=.TRUE. 764 ll_exp=.FALSE. 765 766 ELSEIF( TRIM(cd_var(ji:ji))=='e' )THEN 767 768 IF( ll_exp .OR. ji== LEN(TRIM(cd_var)) )THEN 769 fct_is_real=.FALSE. 770 EXIT 771 ELSE 772 ll_exp=.TRUE. 773 ENDIF 774 775 ELSEIF( TRIM(cd_var(ji:ji))=='.' )THEN 776 777 IF( ll_dec )THEN 778 fct_is_real=.FALSE. 779 EXIT 780 ELSE 781 fct_is_real=.TRUE. 782 ll_dec=.TRUE. 783 ENDIF 784 785 ELSE 786 787 fct_is_real=.FALSE. 788 EXIT 789 790 ENDIF 791 ENDDO 792 793 END FUNCTION fct_is_real 794 !------------------------------------------------------------------- 725 795 !> @brief This function split string of character 726 796 !> using separator character, by default '|', … … 728 798 ! 729 799 !> @author J.Paul 730 !> - November, 2013- Initial Version800 !> @date November, 2013 - Initial Version 731 801 ! 732 802 !> @param[in] cd_string string of character … … 808 878 ! 809 879 !> @author J.Paul 810 !> - November, 2013- Initial Version880 !> @date November, 2013 - Initial Version 811 881 ! 812 882 !> @param[in] cd_string string of character … … 873 943 !> Optionally you could specify another separator. 874 944 !> @author J.Paul 875 !> - November, 2013- Initial Version945 !> @date November, 2013 - Initial Version 876 946 ! 877 947 !> @param[in] cd_string filename … … 914 984 !> Optionally you could specify another separator. 915 985 !> @author J.Paul 916 !> - November, 2013- Initial Version986 !> @date November, 2013 - Initial Version 917 987 ! 918 988 !> @param[in] cd_string filename -
trunk/NEMOGCM/TOOLS/SIREN/src/grid.f90
r5037 r5609 149 149 !> CALL grid_check_coincidence(td_coord0, td_coord1, 150 150 !> id_imin0, id_imax0, id_jmin0, id_jmax0 151 !> [,id_rho])151 !> ,id_rho) 152 152 !> @endcode 153 153 !> - td_coord0 is coarse grid coordinate mpp structure … … 161 161 !> - id_jmax0 is coarse grid upper right corner j-indice of fine grid 162 162 !> domain 163 !> - id_rho is array of refinement factor (default 1)163 !> - id_rho is array of refinement factor 164 164 !> 165 165 !> to add ghost cell at boundaries:<br/> … … 213 213 !> @date October, 2014 214 214 !> - use mpp file structure instead of file 215 !> @date February, 2015 216 !> - add function grid_fill_small_msk to fill small domain inside bigger one 215 217 ! 216 218 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 255 257 PUBLIC :: grid_split_domain !< compute closed sea domain 256 258 PUBLIC :: grid_fill_small_dom !< fill small closed sea with fill value 259 PUBLIC :: grid_fill_small_msk !< fill small domain inside bigger one 257 260 258 261 ! get closest coarse grid indices of fine grid domain … … 466 469 !> - compute East West overlap 467 470 !> 468 !> @note need all processor files to be there471 !> @note need all processor files 469 472 !> @author J.Paul 470 473 !> - October, 2014- Initial Version … … 496 499 il_ew =-1 497 500 501 CALL logger_info("GRID GET INFO: look for "//TRIM(td_mpp%c_name)) 498 502 ! copy structure 499 503 tl_mpp=mpp_copy(td_mpp) … … 523 527 ENDIF 524 528 529 CALL logger_info("GRID GET INFO: perio "//TRIM(fct_str(il_perio))) 530 525 531 SELECT CASE(il_perio) 526 532 CASE(3,4) 533 il_pivot=1 534 CASE(5,6) 527 535 il_pivot=0 528 CASE(5,6)529 il_pivot=1530 536 CASE(0,1,2) 531 537 il_pivot=1 … … 534 540 IF( il_pivot < 0 .OR. il_pivot > 1 )THEN 535 541 ! get pivot 542 CALL logger_info("GRID GET INFO: look for pivot ") 536 543 il_pivot=grid_get_pivot(tl_mpp) 537 544 ENDIF … … 539 546 IF( il_perio < 0 .OR. il_perio > 6 )THEN 540 547 ! get periodicity 548 CALL logger_info("GRID GET INFO: look for perio ") 541 549 il_perio=grid_get_perio(tl_mpp, il_pivot) 542 550 ENDIF … … 544 552 IF( il_ew < 0 )THEN 545 553 ! get periodicity 554 CALL logger_info("GRID GET INFO: look for overlap ") 546 555 il_ew=grid_get_ew_overlap(tl_mpp) 547 556 ENDIF … … 595 604 !> 596 605 !> @author J.Paul 597 !> - November, 2013- Subroutine written606 !> @date November, 2013 - Initial version 598 607 !> @date September, 2014 599 608 !> - add dummy loop in case variable not over right point. … … 783 792 784 793 IF( ll_check )THEN 785 CALL logger_info("GRID GET PIVOT: T-pivot")794 CALL logger_info("GRID GET PIVOT: F-pivot") 786 795 grid__get_pivot_varT=0 787 796 ENDIF … … 876 885 877 886 IF( ll_check )THEN 878 CALL logger_info("GRID GET PIVOT: T-pivot")887 CALL logger_info("GRID GET PIVOT: F-pivot") 879 888 grid__get_pivot_varU=0 880 889 ENDIF … … 969 978 970 979 IF( ll_check )THEN 971 CALL logger_info("GRID GET PIVOT: T-pivot")980 CALL logger_info("GRID GET PIVOT: F-pivot") 972 981 grid__get_pivot_varV=0 973 982 ENDIF … … 1062 1071 1063 1072 IF( ll_check )THEN 1064 CALL logger_info("GRID GET PIVOT: T-pivot")1073 CALL logger_info("GRID GET PIVOT: F-pivot") 1065 1074 grid__get_pivot_varF=0 1066 1075 ENDIF … … 1277 1286 !> 1: cyclic east-west boundary 1278 1287 !> 2: symmetric boundary condition across the equator 1279 !> 3: North fold boundary (with a F-point pivot)1280 !> 4: North fold boundary (with a F-point pivot) and cyclic east-west boundary1281 !> 5: North fold boundary (with a T-point pivot)1282 !> 6: North fold boundary (with a T-point pivot) and cyclic east-west boundary1288 !> 3: North fold boundary (with a T-point pivot) 1289 !> 4: North fold boundary (with a T-point pivot) and cyclic east-west boundary 1290 !> 5: North fold boundary (with a F-point pivot) 1291 !> 6: North fold boundary (with a F-point pivot) and cyclic east-west boundary 1283 1292 !> 1284 1293 !> @warning pivot point should have been computed before run this script. see grid_get_pivot. 1285 1294 !> 1286 1295 !> @author J.Paul 1287 !> - November, 2013- Subroutine written1296 !> @date November, 2013 - Initial version 1288 1297 !> @date October, 2014 1289 1298 !> - work on variable structure instead of file structure … … 1537 1546 !> 1: cyclic east-west boundary 1538 1547 !> 2: symmetric boundary condition across the equator 1539 !> 3: North fold boundary (with a F-point pivot)1540 !> 4: North fold boundary (with a F-point pivot) and cyclic east-west boundary1541 !> 5: North fold boundary (with a T-point pivot)1542 !> 6: North fold boundary (with a T-point pivot) and cyclic east-west boundary1548 !> 3: North fold boundary (with a T-point pivot) 1549 !> 4: North fold boundary (with a T-point pivot) and cyclic east-west boundary 1550 !> 5: North fold boundary (with a F-point pivot) 1551 !> 6: North fold boundary (with a F-point pivot) and cyclic east-west boundary 1543 1552 !> 1544 1553 !> @warning pivot point should have been computed before run this script. see grid_get_pivot. … … 1634 1643 ! 1635 1644 !> @author J.Paul 1636 !> - November, 2013- Initial Version1645 !> @date November, 2013 - Initial Version 1637 1646 !> @date October, 2014 1638 1647 !> - work on mpp file structure instead of file structure … … 1797 1806 ! 1798 1807 !> @author J.Paul 1799 !> - November, 2013- Initial Version1808 !> @date November, 2013 - Initial Version 1800 1809 !> @date October, 2014 1801 1810 !> - work on mpp file structure instead of file structure … … 1890 1899 ! 1891 1900 !> @author J.Paul 1892 !> - November, 2013- Initial Version1901 !> @date November, 2013 - Initial Version 1893 1902 !> @date October, 2014 1894 1903 !> - work on mpp file structure instead of file structure … … 1978 1987 !> 1979 1988 !> @author J.Paul 1980 !> - November, 2013- Initial Version1989 !> @date November, 2013 - Initial Version 1981 1990 !> @date September, 2014 1982 1991 !> - use grid point to read coordinates variable. 1983 1992 !> @date October, 2014 1984 1993 !> - work on mpp file structure instead of file structure 1994 !> @date February, 2015 1995 !> - use longitude or latitude as standard name, if can not find 1996 !> longitude_T, latitude_T... 1985 1997 !> 1986 1998 !> @param[in] td_coord0 coarse grid coordinate mpp structure … … 2004 2016 2005 2017 ! local variable 2006 TYPE(TMPP) :: tl_coord0 2007 TYPE(TMPP) :: tl_coord1 2008 2009 TYPE(TVAR) :: tl_lon0 2010 TYPE(TVAR) :: tl_lat0 2011 TYPE(TVAR) :: tl_lon1 2012 TYPE(TVAR) :: tl_lat1 2013 2014 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 2015 2016 INTEGER(i4), DIMENSION(2,2) :: il_xghost0 2017 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 2018 2019 INTEGER(i4) :: il_imin0 2020 INTEGER(i4) :: il_imax0 2021 INTEGER(i4) :: il_jmin0 2022 INTEGER(i4) :: il_jmax0 2023 2024 CHARACTER(LEN= 1) :: cl_point 2025 CHARACTER(LEN=lc) :: cl_name 2018 CHARACTER(LEN= 1) :: cl_point 2019 CHARACTER(LEN=lc) :: cl_name 2020 2021 INTEGER(i4) :: il_imin0 2022 INTEGER(i4) :: il_imax0 2023 INTEGER(i4) :: il_jmin0 2024 INTEGER(i4) :: il_jmax0 2025 INTEGER(i4) :: il_ind 2026 2027 INTEGER(i4), DIMENSION(2,2) :: il_xghost0 2028 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 2029 2030 INTEGER(i4), DIMENSION(:) , ALLOCATABLE :: il_rho 2031 2032 TYPE(TVAR) :: tl_lon0 2033 TYPE(TVAR) :: tl_lat0 2034 TYPE(TVAR) :: tl_lon1 2035 TYPE(TVAR) :: tl_lat1 2036 2037 TYPE(TMPP) :: tl_coord0 2038 TYPE(TMPP) :: tl_coord1 2026 2039 2027 2040 ! loop indices … … 2057 2070 ! read coarse longitue and latitude 2058 2071 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 2072 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) 2073 IF( il_ind == 0 )THEN 2074 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2075 & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & 2076 & try to use longitude.") 2077 WRITE(cl_name,*) 'longitude' 2078 ENDIF 2059 2079 tl_lon0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 2080 2060 2081 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 2082 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) 2083 IF( il_ind == 0 )THEN 2084 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2085 & TRIM(cl_name)//" in file "//TRIM(tl_coord0%c_name)//". & 2086 & try to use latitude.") 2087 WRITE(cl_name,*) 'latitude' 2088 ENDIF 2061 2089 tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 2062 2090 … … 2077 2105 ! read fine longitue and latitude 2078 2106 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 2107 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 2108 IF( il_ind == 0 )THEN 2109 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2110 & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & 2111 & try to use longitude.") 2112 WRITE(cl_name,*) 'longitude' 2113 ENDIF 2079 2114 tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 2115 2080 2116 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 2117 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 2118 IF( il_ind == 0 )THEN 2119 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2120 & TRIM(cl_name)//" in file "//TRIM(tl_coord1%c_name)//". & 2121 & try to use latitude.") 2122 WRITE(cl_name,*) 'latitude' 2123 ENDIF 2081 2124 tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 2082 2125 … … 2127 2170 !> 2128 2171 !> @author J.Paul 2129 !> - November, 2013- Initial Version2172 !> @date November, 2013 - Initial Version 2130 2173 !> @date September, 2014 2131 2174 !> - use grid point to read coordinates variable. 2132 2175 !> @date October, 2014 2133 2176 !> - work on mpp file structure instead of file structure 2177 !> @date February, 2015 2178 !> - use longitude or latitude as standard name, if can not find 2179 !> longitude_T, latitude_T... 2134 2180 !> 2135 2181 !> @param[in] td_longitude0 coarse grid longitude … … 2154 2200 2155 2201 ! local variable 2156 TYPE(TMPP) :: tl_coord1 2157 2158 TYPE(TVAR) :: tl_lon1 2159 TYPE(TVAR) :: tl_lat1 2160 2161 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 2162 2163 INTEGER(i4), DIMENSION(2,2) :: il_xghost 2164 2165 CHARACTER(LEN= 1) :: cl_point 2166 CHARACTER(LEN=lc) :: cl_name 2202 CHARACTER(LEN= 1) :: cl_point 2203 CHARACTER(LEN=lc) :: cl_name 2204 2205 INTEGER(i4) :: il_ind 2206 2207 INTEGER(i4), DIMENSION(:) , ALLOCATABLE :: il_rho 2208 2209 INTEGER(i4), DIMENSION(2,2) :: il_xghost 2210 2211 TYPE(TVAR) :: tl_lon1 2212 TYPE(TVAR) :: tl_lat1 2213 2214 TYPE(TMPP) :: tl_coord1 2167 2215 2168 2216 ! loop indices … … 2209 2257 ! read fine longitue and latitude 2210 2258 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 2259 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 2260 IF( il_ind == 0 )THEN 2261 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2262 & TRIM(cl_name)//"in file "//TRIM(tl_coord1%c_name)//". & 2263 & try to use longitude.") 2264 WRITE(cl_name,*) 'longitude' 2265 ENDIF 2211 2266 tl_lon1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 2267 2212 2268 WRITE(cl_name,*) 'latitude_'//TRIM(cl_point) 2269 il_ind=var_get_id(tl_coord1%t_proc(1)%t_var(:), cl_name) 2270 IF( il_ind == 0 )THEN 2271 CALL logger_warn("GRID GET COARSE INDEX: no variable "//& 2272 & TRIM(cl_name)//"in file "//TRIM(tl_coord1%c_name)//". & 2273 & try to use longitude.") 2274 WRITE(cl_name,*) 'latitude' 2275 ENDIF 2213 2276 tl_lat1=iom_mpp_read_var(tl_coord1, TRIM(cl_name)) 2214 2277 … … 2244 2307 !> 2245 2308 !> @author J.Paul 2246 !> - November, 2013- Initial Version2309 !> @date November, 2013 - Initial Version 2247 2310 !> @date September, 2014 2248 2311 !> - use grid point to read coordinates variable. 2249 2312 !> @date October, 2014 2250 2313 !> - work on mpp file structure instead of file structure 2314 !> @date February, 2015 2315 !> - use longitude or latitude as standard name, if can not find 2316 !> longitude_T, latitude_T... 2251 2317 !> 2252 2318 !> @param[in] td_coord0 coarse grid coordinate mpp structure … … 2271 2337 2272 2338 ! local variable 2273 TYPE(TMPP) :: tl_coord0