- Timestamp:
- 2016-01-08T10:35:19+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4704_NOC5_MPP_BDY_UPDATE/NEMOGCM/TOOLS/SIREN/src/mpp.f90
r4213 r6225 5 5 ! MODULE: mpp 6 6 ! 7 !8 7 ! DESCRIPTION: 9 !> This module manage massively parallel processing 8 !> @brief 9 !> This module manage massively parallel processing. 10 10 ! 11 11 !> @details 12 12 !> define type TMPP:<br/> 13 !> TYPE(TMPP) :: tl_mpp<br/> 13 !> @code 14 !> TYPE(TMPP) :: tl_mpp 15 !> @endcode 14 16 !> 15 17 !> to initialise a mpp structure:<br/> 16 !> - tl_mpp=mpp_init( cd_file, id_mask, [id_niproc,] [id_njproc,] 17 !> [id_nproc] [id_preci,] [id_precj,] [cd_type]) 18 !> - tl_mpp=mpp_init( cd_file, td_var, [id_niproc,] [id_njproc,] 19 !> [id_nproc] [id_preci,] [id_precj,] [cd_type]) 20 !> - tl_mpp=mpp_init( td_file ) 18 !> @code 19 !> tl_mpp=mpp_init( cd_file, id_mask, 20 !> [id_niproc,] [id_njproc,] [id_nproc,] 21 !> [id_preci,] [id_precj,] 22 !> [cd_type,] [id_ew]) 23 !> @endcode 24 !> or 25 !> @code 26 !> tl_mpp=mpp_init( cd_file, td_var, 27 !> [id_niproc,] [id_njproc,] [id_nproc,] 28 !> [id_preci,] [id_precj,] 29 !> [cd_type] ) 30 !> @endcode 31 !> or 32 !> @code 33 !> tl_mpp=mpp_init( td_file [,id_ew] ) 34 !> @endcode 21 35 !> - cd_file is the filename of the global domain file, in which 22 36 !> MPP will be done (example: Bathymetry) 23 37 !> - td_file is the file structure of one processor file composing an MPP 24 !> - id_mask is the 2D mask of global domain 38 !> - id_mask is the 2D mask of global domain [optional] 25 39 !> - td_var is a variable structure (on T-point) from global domain file. 26 !> mask of the domain will be computed using FillValue 40 !> mask of the domain will be computed using FillValue [optional] 27 41 !> - id_niproc is the number of processor following I-direction to be used 28 !> (optional)42 !> [optional] 29 43 !> - id_njproc is the number of processor following J-direction to be used 30 !> (optional) 31 !> - id_nproc is the total number of processor to be used (optional) 32 !> - id_preci is the size of the overlap region following I-direction 33 !> - id_precj is the size of the overlap region following J-direction 34 !> - cd_type is the type of files composing MPP<br/> 44 !> [optional] 45 !> - id_nproc is the total number of processor to be used [optional] 46 !> - id_preci is the size of the overlap region following I-direction [optional] 47 !> - id_precj is the size of the overlap region following J-direction [optional] 48 !> - cd_type is the type of files composing MPP [optional] 49 !> - id_ew is east-west overlap [optional]<br/> 35 50 !> 36 51 !> to get mpp name:<br/> … … 62 77 !> - tl_mpp\%i_ndim 63 78 !> 64 !> to get the tableof dimension structure (4 elts) associated to the79 !> to get the array of dimension structure (4 elts) associated to the 65 80 !> mpp structure:<br/> 66 81 !> - tl_mpp\%t_dim(:) … … 70 85 !> 71 86 !> to clean a mpp structure:<br/> 72 !> - CALL mpp_clean(tl_mpp) 87 !> @code 88 !> CALL mpp_clean(tl_mpp) 89 !> @endcode 73 90 !> 74 91 !> to print information about mpp:<br/> 92 !> @code 75 93 !> CALL mpp_print(tl_mpp) 94 !> @endcode 76 95 !> 77 96 !> to add variable to mpp:<br/> 97 !> @code 78 98 !> CALL mpp_add_var(td_mpp, td_var) 99 !> @endcode 79 100 !> - td_var is a variable structure 80 101 !> 81 102 !> to add dimension to mpp:<br/> 103 !> @code 82 104 !> CALL mpp_add_dim(td_mpp, td_dim) 105 !> @endcode 83 106 !> - td_dim is a dimension structure 84 107 !> 85 !> to delete variable to mpp:<br/> 108 !> to add attribute to mpp:<br/> 109 !> @code 110 !> CALL mpp_add_att(td_mpp, td_att) 111 !> @endcode 112 !> - td_att is a attribute structure 113 !> 114 !> to delete variable from mpp:<br/> 115 !> @code 86 116 !> CALL mpp_del_var(td_mpp, td_var) 117 !> @endcode 118 !> or 119 !> @code 120 !> CALL mpp_del_var(td_mpp, cd_name) 121 !> @endcode 87 122 !> - td_var is a variable structure 123 !> - cd_name is variable name or standard name 88 124 !> 89 !> to delete dimension to mpp:<br/> 125 !> to delete dimension from mpp:<br/> 126 !> @code 90 127 !> CALL mpp_del_dim(td_mpp, td_dim) 128 !> @endcode 91 129 !> - td_dim is a dimension structure 92 130 !> 131 !> to delete attribute from mpp:<br/> 132 !> @code 133 !> CALL mpp_del_att(td_mpp, td_att) 134 !> @endcode 135 !> or 136 !> @code 137 !> CALL mpp_del_att(td_mpp, cd_name) 138 !> @endcode 139 !> - td_att is a attribute structure 140 !> - cd_name is attribute name 141 !> 93 142 !> to overwrite variable to mpp:<br/> 143 !> @code 94 144 !> CALL mpp_move_var(td_mpp, td_var) 145 !> @endcode 95 146 !> - td_var is a variable structure 96 147 !> 97 148 !> to overwrite dimension to mpp:<br/> 149 !> @code 98 150 !> CALL mpp_move_dim(td_mpp, td_dim) 151 !> @endcode 99 152 !> - td_dim is a dimension structure 100 153 !> 154 !> to overwrite attribute to mpp:<br/> 155 !> @code 156 !> CALL mpp_move_att(td_mpp, td_att) 157 !> @endcode 158 !> - td_att is a attribute structure 159 !> 101 160 !> to determine domain decomposition type:<br/> 161 !> @code 102 162 !> CALL mpp_get_dom(td_mpp) 163 !> @endcode 103 164 !> 104 165 !> to get processors to be used:<br/> 105 !> CALL mpp_get_use( td_mpp, td_dom ) 106 !> - td_dom is a domain structure 166 !> @code 167 !> CALL mpp_get_use( td_mpp, id_imin, id_imax, & 168 !> & id_jmin, id_jmax ) 169 !> @endcode 170 !> - id_imin 171 !> - id_imax 172 !> - id_jmin 173 !> - id_jmax 107 174 !> 108 175 !> to get sub domains which form global domain contour:<br/> 176 !> @code 109 177 !> CALL mpp_get_contour( td_mpp ) 178 !> @endcode 110 179 !> 111 180 !> to get global domain indices of one processor:<br/> 181 !> @code 112 182 !> il_ind(1:4)=mpp_get_proc_index( td_mpp, id_procid ) 183 !> @endcode 113 184 !> - il_ind(1:4) are global domain indices (i1,i2,j1,j2) 114 185 !> - id_procid is the processor id 115 186 !> 116 187 !> to get the processor domain size:<br/> 188 !> @code 117 189 !> il_size(1:2)=mpp_get_proc_size( td_mpp, id_procid ) 190 !> @endcode 118 191 !> - il_size(1:2) are the size of domain following I and J 119 192 !> - id_procid is the processor id … … 122 195 !> J.Paul 123 196 ! REVISION HISTORY: 124 !> @date Nov, 2013 - Initial Version 125 !> @todo 126 !> - add description generique de l'objet mpp 127 !> - mpp_print 128 !> - voir pour mettre cd_file systematiquement pour mpp_init 129 !> + modifier utilisation la haut 197 !> @date November, 2013 - Initial Version 198 !> @date November, 2014 - Fix memory leaks bug 130 199 ! 131 200 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 132 201 !---------------------------------------------------------------------- 133 202 MODULE mpp 203 USE global ! global parameter 134 204 USE kind ! F90 kind parameter 135 USE logger 205 USE logger ! log file manager 136 206 USE fct ! basic useful function 137 207 USE dim ! dimension manager … … 140 210 USE file ! file manager 141 211 USE iom ! I/O manager 142 ! USE proc ! proc manager143 USE dom ! domain manager144 212 IMPLICIT NONE 145 PRIVATE146 213 ! NOTE_avoid_public_variables_if_possible 147 214 148 215 ! type and variable 149 PUBLIC :: TMPP ! mpp structure216 PUBLIC :: TMPP !< mpp structure 150 217 151 218 ! function and subroutine 152 PUBLIC :: ASSIGNMENT(=)!< copy mpp structure219 PUBLIC :: mpp_copy !< copy mpp structure 153 220 PUBLIC :: mpp_init !< initialise mpp structure 154 221 PUBLIC :: mpp_clean !< clean mpp strcuture … … 163 230 PUBLIC :: mpp_move_dim !< overwrite one dimension strucutre in mpp structure 164 231 PUBLIC :: mpp_move_att !< overwrite one attribute strucutre in mpp structure 232 PUBLIC :: mpp_recombine_var !< recombine variable from mpp structure 233 PUBLIC :: mpp_get_index !< return index of mpp 165 234 166 235 PUBLIC :: mpp_get_dom !< determine domain decomposition type (full, overlap, noverlap) … … 170 239 PUBLIC :: mpp_get_proc_size !< get processor domain size 171 240 172 PRIVATE :: mpp__add_proc !< add one proc strucutre in mpp structure 173 PRIVATE :: mpp__del_proc !< delete one proc strucutre in mpp structure 174 PRIVATE :: mpp__move_proc !< overwrite proc strucutre in mpp structure 175 PRIVATE :: mpp__compute !< compute domain decomposition 176 PRIVATE :: mpp__del_land !< remove land sub domain from domain decomposition 177 PRIVATE :: mpp__optimiz !< compute optimum domain decomposition 178 PRIVATE :: mpp__land_proc !< check if processor is a land processor 179 PRIVATE :: mpp__check_dim !< check mpp structure dimension with proc or variable dimension 180 PRIVATE :: mpp__del_var_name !< delete variable in mpp structure, given variable name 181 PRIVATE :: mpp__del_var_str !< delete variable in mpp structure, given variable structure 182 PRIVATE :: mpp__del_att_name !< delete variable in mpp structure, given variable name 183 PRIVATE :: mpp__del_att_str !< delete variable in mpp structure, given variable structure 184 PRIVATE :: mpp__split_var !< extract variable part that will be written in processor 185 PRIVATE :: mpp__copy !< copy mpp structure 186 187 !> @struct TMPP 188 TYPE TMPP 241 PRIVATE :: mpp__add_proc ! add one proc strucutre in mpp structure 242 PRIVATE :: mpp__del_proc ! delete one proc strucutre in mpp structure 243 PRIVATE :: mpp__del_proc_id ! delete one proc strucutre in mpp structure, given procesor id 244 PRIVATE :: mpp__del_proc_str ! delete one proc strucutre in mpp structure, given procesor file structure 245 PRIVATE :: mpp__move_proc ! overwrite proc strucutre in mpp structure 246 PRIVATE :: mpp__compute ! compute domain decomposition 247 PRIVATE :: mpp__del_land ! remove land sub domain from domain decomposition 248 PRIVATE :: mpp__optimiz ! compute optimum domain decomposition 249 PRIVATE :: mpp__land_proc ! check if processor is a land processor 250 PRIVATE :: mpp__check_dim ! check mpp structure dimension with proc or variable dimension 251 PRIVATE :: mpp__check_proc_dim ! check if processor and mpp structure use same dimension 252 PRIVATE :: mpp__check_var_dim ! check if variable and mpp structure use same dimension 253 PRIVATE :: mpp__del_var_name ! delete variable in mpp structure, given variable name 254 PRIVATE :: mpp__del_var_mpp ! delete all variable in mpp structure 255 PRIVATE :: mpp__del_var_str ! delete variable in mpp structure, given variable structure 256 PRIVATE :: mpp__del_att_name ! delete variable in mpp structure, given variable name 257 PRIVATE :: mpp__del_att_str ! delete variable in mpp structure, given variable structure 258 PRIVATE :: mpp__split_var ! extract variable part that will be written in processor 259 PRIVATE :: mpp__copy_unit ! copy mpp structure 260 PRIVATE :: mpp__copy_arr ! copy array of mpp structure 261 PRIVATE :: mpp__get_use_unit ! get sub domains to be used (which cover "zoom domain") 262 PRIVATE :: mpp__init_mask ! initialise mpp structure, given file name 263 PRIVATE :: mpp__init_var ! initialise mpp structure, given variable strcuture 264 PRIVATE :: mpp__init_file ! initialise a mpp structure, given file structure 265 PRIVATE :: mpp__init_file_cdf ! initialise a mpp structure with cdf file 266 PRIVATE :: mpp__init_file_rstdimg ! initialise a mpp structure with rstdimg file 267 PRIVATE :: mpp__clean_unit ! clean mpp strcuture 268 PRIVATE :: mpp__clean_arr ! clean array of mpp strcuture 269 270 TYPE TMPP !< mpp structure 189 271 190 272 ! general 191 CHARACTER(LEN=lc) :: c_name = '' !< base name ??? 192 193 INTEGER(i4) :: i_niproc = 0 !< number of processors following i 194 INTEGER(i4) :: i_njproc = 0 !< number of processors following j 195 INTEGER(i4) :: i_nproc = 0 !< total number of proccessors used 196 INTEGER(i4) :: i_preci = 1 !< i-direction overlap region length 197 INTEGER(i4) :: i_precj = 1 !< j-direction overlap region length 198 199 CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg) 200 CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, overlap, nooverlap) 201 202 INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp 203 TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< global domain dimension 204 205 TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp 273 CHARACTER(LEN=lc) :: c_name = '' !< base name 274 INTEGER(i4) :: i_id = 0 !< mpp id 275 276 INTEGER(i4) :: i_niproc = 0 !< number of processors following i 277 INTEGER(i4) :: i_njproc = 0 !< number of processors following j 278 INTEGER(i4) :: i_nproc = 0 !< total number of proccessors used 279 INTEGER(i4) :: i_preci = 1 !< i-direction overlap region length 280 INTEGER(i4) :: i_precj = 1 !< j-direction overlap region length 281 INTEGER(i4) :: i_ew = -1 !< east-west overlap 282 INTEGER(i4) :: i_perio = -1 !< NEMO periodicity index 283 INTEGER(i4) :: i_pivot = -1 !< NEMO pivot point index F(0),T(1) 284 285 CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg) 286 CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, overlap, nooverlap) 287 288 INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp 289 TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< global domain dimension 290 291 TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp 206 292 207 293 END TYPE 294 295 INTERFACE mpp_get_use 296 MODULE PROCEDURE mpp__get_use_unit 297 END INTERFACE mpp_get_use 298 299 INTERFACE mpp_clean 300 MODULE PROCEDURE mpp__clean_unit 301 MODULE PROCEDURE mpp__clean_arr 302 END INTERFACE mpp_clean 208 303 209 304 INTERFACE mpp__check_dim … … 220 315 MODULE PROCEDURE mpp__del_var_name 221 316 MODULE PROCEDURE mpp__del_var_str 317 MODULE PROCEDURE mpp__del_var_mpp 222 318 END INTERFACE mpp_del_var 223 319 … … 230 326 MODULE PROCEDURE mpp__init_mask 231 327 MODULE PROCEDURE mpp__init_var 232 MODULE PROCEDURE mpp__init_ read328 MODULE PROCEDURE mpp__init_file 233 329 END INTERFACE mpp_init 234 330 235 INTERFACE ASSIGNMENT(=) 236 MODULE PROCEDURE mpp__copy ! copy mpp structure 331 INTERFACE mpp_copy 332 MODULE PROCEDURE mpp__copy_unit ! copy mpp structure 333 MODULE PROCEDURE mpp__copy_arr ! copy array of mpp structure 237 334 END INTERFACE 238 335 … … 240 337 !------------------------------------------------------------------- 241 338 !> @brief 242 !> This subroutine copy mpp structure in another mpp 243 !> structure 339 !> This subroutine copy mpp structure in another one 244 340 !> @details 245 !> mpp file are copied in a temporary table,341 !> mpp file are copied in a temporary array, 246 342 !> so input and output mpp structure do not point on the same 247 343 !> "memory cell", and so on are independant. 248 344 !> 249 !> @author J.Paul 250 !> - Nov, 2013- Initial Version 251 ! 252 !> @param[out] td_mpp1 : mpp structure 253 !> @param[in] td_mpp2 : mpp structure 254 !------------------------------------------------------------------- 255 ! @code 256 SUBROUTINE mpp__copy( td_mpp1, td_mpp2 ) 345 !> @warning do not use on the output of a function who create or read an 346 !> structure (ex: tl_file=file_copy(file_init()) is forbidden). 347 !> This will create memory leaks. 348 !> @warning to avoid infinite loop, do not use any function inside 349 !> this subroutine 350 !> 351 !> @author J.Paul 352 !> @date November, 2013 - Initial Version 353 !> @date November, 2014 354 !> - use function instead of overload assignment operator 355 !> (to avoid memory leak) 356 ! 357 !> @param[in] td_mpp mpp structure 358 !> @return copy of input mpp structure 359 !------------------------------------------------------------------- 360 FUNCTION mpp__copy_unit( td_mpp ) 257 361 IMPLICIT NONE 258 362 ! Argument 259 TYPE(TMPP), INTENT(OUT) :: td_mpp1 260 TYPE(TMPP), INTENT(IN) :: td_mpp2 363 TYPE(TMPP), INTENT(IN) :: td_mpp 364 ! function 365 TYPE(TMPP) :: mpp__copy_unit 366 367 ! local variable 368 TYPE(TFILE) :: tl_file 261 369 262 370 ! loop indices … … 264 372 !---------------------------------------------------------------- 265 373 266 CALL logger_trace("COPY: mpp "//TRIM(td_mpp2%c_name)//" in "//& 267 & TRIM(td_mpp1%c_name)) 374 CALL logger_trace("MPP COPY: "//TRIM(td_mpp%c_name)//" in "//& 375 & TRIM(mpp__copy_unit%c_name)) 376 268 377 ! copy mpp variable 269 td_mpp1%c_name = TRIM(td_mpp2%c_name) 270 td_mpp1%i_niproc = td_mpp2%i_niproc 271 td_mpp1%i_njproc = td_mpp2%i_njproc 272 td_mpp1%i_nproc = td_mpp2%i_nproc 273 td_mpp1%i_preci = td_mpp2%i_preci 274 td_mpp1%i_precj = td_mpp2%i_precj 275 td_mpp1%c_type = TRIM(td_mpp2%c_type) 276 td_mpp1%c_dom = TRIM(td_mpp2%c_dom) 277 td_mpp1%i_ndim = td_mpp2%i_ndim 378 mpp__copy_unit%c_name = TRIM(td_mpp%c_name) 379 mpp__copy_unit%i_id = td_mpp%i_id 380 mpp__copy_unit%i_niproc = td_mpp%i_niproc 381 mpp__copy_unit%i_njproc = td_mpp%i_njproc 382 mpp__copy_unit%i_nproc = td_mpp%i_nproc 383 mpp__copy_unit%i_preci = td_mpp%i_preci 384 mpp__copy_unit%i_precj = td_mpp%i_precj 385 mpp__copy_unit%c_type = TRIM(td_mpp%c_type) 386 mpp__copy_unit%c_dom = TRIM(td_mpp%c_dom) 387 mpp__copy_unit%i_ndim = td_mpp%i_ndim 388 mpp__copy_unit%i_ew = td_mpp%i_ew 389 mpp__copy_unit%i_perio = td_mpp%i_perio 390 mpp__copy_unit%i_pivot = td_mpp%i_pivot 278 391 279 392 ! copy dimension 280 td_mpp1%t_dim(:) = td_mpp2%t_dim(:)393 mpp__copy_unit%t_dim(:) = dim_copy(td_mpp%t_dim(:)) 281 394 282 395 ! copy file structure 283 IF( ASSOCIATED(td_mpp1%t_proc) ) DEALLOCATE(td_mpp1%t_proc) 284 IF( ASSOCIATED(td_mpp2%t_proc) )THEN 285 ALLOCATE( td_mpp1%t_proc(td_mpp1%i_nproc) ) 286 DO ji=1,td_mpp1%i_nproc 287 td_mpp1%t_proc(ji) = td_mpp2%t_proc(ji) 396 IF( ASSOCIATED(mpp__copy_unit%t_proc) )THEN 397 CALL file_clean(mpp__copy_unit%t_proc(:)) 398 DEALLOCATE(mpp__copy_unit%t_proc) 399 ENDIF 400 IF( ASSOCIATED(td_mpp%t_proc) .AND. mpp__copy_unit%i_nproc > 0 )THEN 401 ALLOCATE( mpp__copy_unit%t_proc(mpp__copy_unit%i_nproc) ) 402 DO ji=1,mpp__copy_unit%i_nproc 403 tl_file = file_copy(td_mpp%t_proc(ji)) 404 mpp__copy_unit%t_proc(ji) = file_copy(tl_file) 288 405 ENDDO 289 ENDIF 290 291 END SUBROUTINE mpp__copy 292 ! @endcode 406 ! clean 407 CALL file_clean(tl_file) 408 ENDIF 409 410 END FUNCTION mpp__copy_unit 411 !------------------------------------------------------------------- 412 !> @brief 413 !> This subroutine copy an array of mpp structure in another one 414 !> @details 415 !> mpp file are copied in a temporary array, 416 !> so input and output mpp structure do not point on the same 417 !> "memory cell", and so on are independant. 418 !> 419 !> @warning do not use on the output of a function who create or read an 420 !> structure (ex: tl_file=file_copy(file_init()) is forbidden). 421 !> This will create memory leaks. 422 !> @warning to avoid infinite loop, do not use any function inside 423 !> this subroutine 424 !> 425 !> @author J.Paul 426 !> @date November, 2013 - Initial Version 427 !> @date November, 2014 428 !> - use function instead of overload assignment operator 429 !> (to avoid memory leak) 430 !> 431 !> @param[in] td_mpp mpp structure 432 !> @return copy of input array of mpp structure 433 !------------------------------------------------------------------- 434 FUNCTION mpp__copy_arr( td_mpp ) 435 IMPLICIT NONE 436 ! Argument 437 TYPE(TMPP), DIMENSION(:), INTENT(IN) :: td_mpp 438 ! function 439 TYPE(TMPP), DIMENSION(SIZE(td_mpp(:))) :: mpp__copy_arr 440 441 ! local variable 442 ! loop indices 443 INTEGER(i4) :: ji 444 !---------------------------------------------------------------- 445 446 DO ji=1,SIZE(td_mpp(:)) 447 mpp__copy_arr(ji)=mpp_copy(td_mpp(ji)) 448 ENDDO 449 450 END FUNCTION mpp__copy_arr 293 451 !------------------------------------------------------------------- 294 452 !> @brief This subroutine print some information about mpp strucutre. 295 453 ! 296 454 !> @author J.Paul 297 !> - Nov, 2013- Initial Version 298 ! 299 !> @param[in] td_mpp : mpp structure 300 !------------------------------------------------------------------- 301 ! @code 455 !> @date November, 2013 - Initial Version 456 ! 457 !> @param[in] td_mpp mpp structure 458 !------------------------------------------------------------------- 302 459 SUBROUTINE mpp_print(td_mpp) 303 460 IMPLICIT NONE … … 307 464 308 465 ! local variable 309 INTEGER(i4), PARAMETER :: i p_freq = 4466 INTEGER(i4), PARAMETER :: il_freq = 4 310 467 311 468 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_proc … … 321 478 !---------------------------------------------------------------- 322 479 323 WRITE(*,'((a,a),2(/3x,a,a), 6(/3x,a,i0))')&480 WRITE(*,'((a,a),2(/3x,a,a),9(/3x,a,i0))')& 324 481 & "MPP : ",TRIM(td_mpp%c_name), & 325 482 & " type : ",TRIM(td_mpp%c_type), & … … 330 487 & " preci : ",td_mpp%i_preci, & 331 488 & " precj : ",td_mpp%i_precj, & 332 & " ndim : ",td_mpp%i_ndim 489 & " ndim : ",td_mpp%i_ndim, & 490 & " overlap: ",td_mpp%i_ew, & 491 & " perio : ",td_mpp%i_perio, & 492 & " pivot : ",td_mpp%i_pivot 333 493 334 494 ! print dimension 335 495 IF( td_mpp%i_ndim /= 0 )THEN 336 WRITE(*,'(/a)') " Filedimension"496 WRITE(*,'(/a)') " MPP dimension" 337 497 DO ji=1,ip_maxdim 338 498 IF( td_mpp%t_dim(ji)%l_use )THEN … … 363 523 & td_mpp%t_proc(ji)%i_lej 364 524 365 !! attribute366 !DO jj=1, td_mpp%t_proc(ji)%i_natt367 ! CALL att_print(td_mpp%t_proc(ji)%t_att(jj))368 !ENDDO369 370 371 525 ENDDO 526 527 IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN 528 WRITE(*,'(/a)') " Variable(s) used : " 529 DO ji=1,td_mpp%t_proc(1)%i_nvar 530 WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name) 531 ENDDO 532 ENDIF 372 533 373 534 ELSE … … 387 548 & td_mpp%t_proc(ji)%i_lej 388 549 389 !! attribute390 !DO jj=1, td_mpp%t_proc(ji)%i_natt391 ! CALL att_print(td_mpp%t_proc(ji)%t_att(jj))392 !ENDDO393 394 550 ENDDO 395 551 552 IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN 553 WRITE(*,'(/a)') " Variable(s) used : " 554 DO ji=1,td_mpp%t_proc(1)%i_nvar 555 WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name) 556 ENDDO 557 ENDIF 558 396 559 ALLOCATE( il_proc(td_mpp%i_niproc,td_mpp%i_njproc) ) 397 560 ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) ) … … 407 570 408 571 jl = 1 409 DO jk = 1,(td_mpp%i_niproc-1)/i p_freq+1410 jm = MIN(td_mpp%i_niproc, jl+i p_freq-1)572 DO jk = 1,(td_mpp%i_niproc-1)/il_freq+1 573 jm = MIN(td_mpp%i_niproc, jl+il_freq-1) 411 574 WRITE(*,*) 412 575 WRITE(*,9401) (ji, ji = jl,jm) … … 419 582 WRITE(*,9400) ('***', ji = jl,jm-1) 420 583 ENDDO 421 jl = jl+i p_freq584 jl = jl+il_freq 422 585 ENDDO 423 586 … … 439 602 440 603 END SUBROUTINE mpp_print 441 ! @endcode442 604 !------------------------------------------------------------------- 443 605 !> @brief 444 !> This function initialise d mpp structure, given file name, mask and number of445 !> processor following I and J606 !> This function initialise mpp structure, given file name, 607 !> and optionaly mask and number of processor following I and J 446 608 !> @detail 447 609 !> - If no total number of processor is defined (id_nproc), optimize … … 452 614 ! 453 615 !> @author J.Paul 454 !> @date Nov, 2013 455 ! 456 !> @param[in] cd_file : file name of one file composing mpp domain 457 !> @param[in] id_mask : domain mask 458 !> @param[in] id_niproc : number of processors following i 459 !> @param[in] id_njproc : number of processors following j 460 !> @param[in] id_nproc : total number of processors 461 !> @param[in] id_preci : i-direction overlap region 462 !> @param[in] id_precj : j-direction overlap region 463 !> @param[in] cd_type : type of the files (cdf, cdf4, dimg) 616 !> @date November, 2013 - Initial version 617 ! 618 !> @param[in] cd_file file name of one file composing mpp domain 619 !> @param[in] id_mask domain mask 620 !> @param[in] id_niproc number of processors following i 621 !> @param[in] id_njproc number of processors following j 622 !> @param[in] id_nproc total number of processors 623 !> @param[in] id_preci i-direction overlap region 624 !> @param[in] id_precj j-direction overlap region 625 !> @param[in] cd_type type of the files (cdf, cdf4, dimg) 626 !> @param[in] id_ew east-west overlap 627 !> @param[in] id_perio NEMO periodicity index 628 !> @param[in] id_pivot NEMO pivot point index F(0),T(1) 464 629 !> @return mpp structure 465 630 !------------------------------------------------------------------- 466 !> @code467 631 TYPE(TMPP) FUNCTION mpp__init_mask(cd_file, id_mask, & 468 632 & id_niproc, id_njproc, id_nproc,& 469 633 & id_preci, id_precj, & 470 cd_type )634 cd_type, id_ew, id_perio, id_pivot) 471 635 IMPLICIT NONE 472 636 ! Argument 473 637 CHARACTER(LEN=*), INTENT(IN) :: cd_file 474 INTEGER(i4), DIMENSION(:,:), INTENT(IN) , OPTIONAL:: id_mask638 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 475 639 INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc 476 640 INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc … … 479 643 INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj 480 644 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type 645 INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew 646 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 647 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 481 648 482 649 ! local variable … … 494 661 ! clean mpp 495 662 CALL mpp_clean(mpp__init_mask) 496 497 ! get mpp name498 mpp__init_mask%c_name=TRIM(file_rename(cd_file))499 663 500 664 ! check type … … 518 682 ENDIF 519 683 520 IF( PRESENT(id_mask) )THEN 521 ! get global domain dimension 522 il_shape(:)=SHAPE(id_mask) 523 524 tl_dim=dim_init('X',il_shape(1)) 525 CALL mpp_add_dim(mpp__init_mask, tl_dim) 526 527 tl_dim=dim_init('Y',il_shape(2)) 528 CALL mpp_add_dim(mpp__init_mask,tl_dim) 529 ENDIF 530 531 IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_niproc))) .OR. & 684 ! get mpp name 685 mpp__init_mask%c_name=TRIM(file_rename(cd_file)) 686 687 ! get global domain dimension 688 il_shape(:)=SHAPE(id_mask) 689 690 tl_dim=dim_init('X',il_shape(1)) 691 CALL mpp_add_dim(mpp__init_mask, tl_dim) 692 693 tl_dim=dim_init('Y',il_shape(2)) 694 CALL mpp_add_dim(mpp__init_mask, tl_dim) 695 696 ! clean 697 CALL dim_clean(tl_dim) 698 699 IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_njproc))) .OR. & 532 700 ((.NOT. PRESENT(id_niproc)) .AND. PRESENT(id_njproc) ) )THEN 533 701 CALL logger_warn( "MPP INIT: number of processors following I and J "//& … … 546 714 IF( PRESENT(id_precj) ) mpp__init_mask%i_precj= id_precj 547 715 716 ! east-west overlap 717 IF( PRESENT(id_ew) ) mpp__init_mask%i_ew= id_ew 718 ! NEMO periodicity 719 IF( PRESENT(id_perio) ) mpp__init_mask%i_perio= id_perio 720 IF( PRESENT(id_pivot) ) mpp__init_mask%i_pivot= id_pivot 721 548 722 IF( mpp__init_mask%i_nproc /= 0 .AND. & 549 723 & mpp__init_mask%i_niproc /= 0 .AND. & … … 560 734 ELSE 561 735 562 IF( mpp__init_mask%i_niproc /= 0 .AND. mpp__init_mask%i_njproc /= 0 )THEN 736 IF( mpp__init_mask%i_niproc /= 0 .AND. & 737 & mpp__init_mask%i_njproc /= 0 )THEN 563 738 ! compute domain decomposition 564 739 CALL mpp__compute( mpp__init_mask ) … … 570 745 571 746 ELSE 572 CALL logger_error("MPP INIT: can't define domain decomposition") 573 CALL logger_debug ("MPP INIT: maximum number of processor to be used "//& 574 & "or number of processor following I and J direction must "//& 575 & "be specified.") 747 CALL logger_warn("MPP INIT: number of processor to be used "//& 748 & "not specify. force to one.") 749 mpp__init_mask%i_nproc = 1 750 ! optimiz 751 CALL mpp__optimiz( mpp__init_mask, id_mask ) 576 752 ENDIF 753 CALL logger_info("MPP INIT: domain decoposition : "//& 754 & 'niproc('//TRIM(fct_str(mpp__init_mask%i_niproc))//') * '//& 755 & 'njproc('//TRIM(fct_str(mpp__init_mask%i_njproc))//') = '//& 756 & 'nproc('//TRIM(fct_str(mpp__init_mask%i_nproc))//')' ) 577 757 578 758 ! get domain type … … 593 773 mpp__init_mask%t_proc(ji)%c_type=TRIM(mpp__init_mask%c_type) 594 774 775 ! clean 776 CALL dim_clean(tl_dim) 595 777 ENDDO 596 778 … … 640 822 CALL mpp_add_att(mpp__init_mask, tl_att) 641 823 824 ! clean 825 CALL att_clean(tl_att) 642 826 ENDIF 643 827 644 828 END FUNCTION mpp__init_mask 645 !> @endcode646 829 !------------------------------------------------------------------- 647 830 !> @brief 648 !> This function initialise dmpp structure, given variable strcuture649 !> and number of processor following I and J831 !> This function initialise mpp structure, given variable strcuture 832 !> and optionaly number of processor following I and J 650 833 !> @detail 651 834 !> - If no total number of processor is defined (id_nproc), optimize … … 656 839 ! 657 840 !> @author J.Paul 658 !> @date Nov, 2013 659 ! 660 !> @param[in] cd_file : file name of one file composing mpp domain 661 !> @param[in] td_var : variable structure 662 !> @param[in] id_niproc : number of processors following i 663 !> @param[in] id_njproc : number of processors following j 664 !> @param[in] id_nproc : total number of processors 665 !> @param[in] id_preci : i-direction overlap region 666 !> @param[in] id_precj : j-direction overlap region 667 !> @param[in] cd_type : type of the files (cdf, cdf4, dimg) 841 !> @date November, 2013 - Initial version 842 ! 843 !> @param[in] cd_file file name of one file composing mpp domain 844 !> @param[in] td_var variable structure 845 !> @param[in] id_niproc number of processors following i 846 !> @param[in] id_njproc number of processors following j 847 !> @param[in] id_nproc total number of processors 848 !> @param[in] id_preci i-direction overlap region 849 !> @param[in] id_precj j-direction overlap region 850 !> @param[in] cd_type type of the files (cdf, cdf4, dimg) 851 !> @param[in] id_perio NEMO periodicity index 852 !> @param[in] id_pivot NEMO pivot point index F(0),T(1) 668 853 !> @return mpp structure 669 854 !------------------------------------------------------------------- 670 !> @code671 855 TYPE(TMPP) FUNCTION mpp__init_var( cd_file, td_var, & 672 856 & id_niproc, id_njproc, id_nproc,& 673 & id_preci, id_precj, cd_type ) 857 & id_preci, id_precj, cd_type, & 858 & id_perio, id_pivot ) 674 859 IMPLICIT NONE 675 860 ! Argument … … 682 867 INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj 683 868 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type 869 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 870 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 684 871 685 872 ! local variable 686 INTEGER(i4), DIMENSION(:,: ), ALLOCATABLE :: il_mask873 INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_mask 687 874 !---------------------------------------------------------------- 688 875 689 876 IF( ASSOCIATED(td_var%d_value) )THEN 690 ALLOCATE( il_mask(td_var%t_dim(1)%i_len, td_var%t_dim(2)%i_len) ) 691 il_mask(:,:)=var_get_mask(td_var) 877 ALLOCATE( il_mask(td_var%t_dim(1)%i_len, & 878 & td_var%t_dim(2)%i_len, & 879 & td_var%t_dim(3)%i_len) ) 880 il_mask(:,:,:)=var_get_mask(td_var) 692 881 693 mpp__init_var=mpp_init( cd_file, il_mask(:,: ),&882 mpp__init_var=mpp_init( cd_file, il_mask(:,:,1), & 694 883 & id_niproc, id_njproc, id_nproc,& 695 & id_preci, id_precj, cd_type ) 884 & id_preci, id_precj, cd_type, & 885 & id_ew=td_var%i_ew, & 886 & id_perio=id_perio, id_pivot=id_pivot) 696 887 697 888 DEALLOCATE(il_mask) … … 701 892 702 893 END FUNCTION mpp__init_var 703 !> @endcode 704 !------------------------------------------------------------------- 705 !> @brief This function initalise a mpp structure, 706 !> reading one restart dimg file, or some netcdf files. 707 ! 894 !------------------------------------------------------------------- 895 !> @brief This function initalise a mpp structure given file structure. 708 896 !> @details 709 !> 710 !> @warning td_file should be not opened 711 !> 712 !> @author J.Paul 713 !> - Nov, 2013- Initial Version 714 ! 715 !> @param[in] td_file : file strcuture 897 !> It reads restart dimg files, or some netcdf files. 898 !> 899 !> @warning 900 !> netcdf file must contains some attributes: 901 !> - DOMAIN_number_total 902 !> - DOMAIN_size_global 903 !> - DOMAIN_number 904 !> - DOMAIN_position_first 905 !> - DOMAIN_position_last 906 !> - DOMAIN_halo_size_start 907 !> - DOMAIN_halo_size_end 908 !> or the file is assume to be no mpp file. 909 !> 910 !> 911 !> 912 !> @author J.Paul 913 !> @date November, 2013 - Initial Version 914 ! 915 !> @param[in] td_file file strcuture 916 !> @param[in] id_ew east-west overlap 917 !> @param[in] id_perio NEMO periodicity index 918 !> @param[in] id_pivot NEMO pivot point index F(0),T(1) 716 919 !> @return mpp structure 717 920 !------------------------------------------------------------------- 718 ! @code 719 TYPE(TMPP) FUNCTION mpp__init_read( td_file ) 921 TYPE(TMPP) FUNCTION mpp__init_file( td_file, id_ew, id_perio, id_pivot ) 720 922 IMPLICIT NONE 721 923 722 924 ! Argument 723 925 TYPE(TFILE), INTENT(IN) :: td_file 926 INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew 927 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 928 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 724 929 725 930 ! local variable 726 931 TYPE(TMPP) :: tl_mpp 932 727 933 TYPE(TFILE) :: tl_file 934 728 935 TYPE(TDIM) :: tl_dim 936 729 937 TYPE(TATT) :: tl_att 938 730 939 INTEGER(i4) :: il_nproc 731 940 INTEGER(i4) :: il_attid … … 737 946 738 947 ! clean mpp 739 CALL mpp_clean(mpp__init_ read)948 CALL mpp_clean(mpp__init_file) 740 949 741 950 ! check file type … … 743 952 CASE('cdf') 744 953 ! need to read all file to get domain decomposition 745 746 tl_file=td_file 954 tl_file=file_copy(td_file) 747 955 748 956 ! open file … … 750 958 751 959 ! read first file domain decomposition 752 tl_mpp=mpp__init_ read_cdf(tl_file)960 tl_mpp=mpp__init_file_cdf(tl_file) 753 961 754 962 ! get number of processor/file to be read … … 779 987 780 988 ! read domain decomposition 781 tl_mpp = mpp__init_ read_cdf(tl_file)989 tl_mpp = mpp__init_file_cdf(tl_file) 782 990 IF( ji == 1 )THEN 783 mpp__init_ read=tl_mpp991 mpp__init_file=mpp_copy(tl_mpp) 784 992 ELSE 785 IF( ANY( mpp__init_ read%t_dim(1:2)%i_len /= &993 IF( ANY( mpp__init_file%t_dim(1:2)%i_len /= & 786 994 tl_mpp%t_dim(1:2)%i_len) )THEN 787 995 788 CALL logger_error(" INIT READ: dimension from file "//&996 CALL logger_error("MPP INIT READ: dimension from file "//& 789 997 & TRIM(tl_file%c_name)//" and mpp strcuture "//& 790 & TRIM(mpp__init_ read%c_name)//"differ ")998 & TRIM(mpp__init_file%c_name)//"differ ") 791 999 792 1000 ELSE 793 1001 794 1002 ! add processor to mpp strcuture 795 CALL mpp__add_proc(mpp__init_ read, tl_mpp%t_proc(1))1003 CALL mpp__add_proc(mpp__init_file, tl_mpp%t_proc(1)) 796 1004 797 1005 ENDIF … … 802 1010 803 1011 ENDDO 804 IF( mpp__init_ read%i_nproc /= il_nproc )THEN805 CALL logger_error(" INIT READ: some processors can't be added &1012 IF( mpp__init_file%i_nproc /= il_nproc )THEN 1013 CALL logger_error("MPP INIT READ: some processors can't be added & 806 1014 & to mpp structure") 807 1015 ENDIF 808 1016 809 1017 ELSE 810 mpp__init_ read=tl_mpp1018 mpp__init_file=mpp_copy(tl_mpp) 811 1019 ENDIF 812 1020 813 1021 ! mpp type 814 mpp__init_ read%c_type=TRIM(td_file%c_type)1022 mpp__init_file%c_type=TRIM(td_file%c_type) 815 1023 816 1024 ! mpp domain type 817 CALL mpp_get_dom(mpp__init_ read)1025 CALL mpp_get_dom(mpp__init_file) 818 1026 819 1027 ! create some attributes for domain decomposition (use with dimg file) 820 tl_att=att_init( "DOMAIN_number_total", mpp__init_ read%i_nproc )821 CALL mpp_ add_att(mpp__init_read, tl_att)822 823 tl_att=att_init( "DOMAIN_I_position_first", mpp__init_ read%t_proc(:)%i_impp )824 CALL mpp_ add_att(mpp__init_read, tl_att)825 826 tl_att=att_init( "DOMAIN_J_position_first", mpp__init_ read%t_proc(:)%i_jmpp )827 CALL mpp_ add_att(mpp__init_read, tl_att)828 829 tl_att=att_init( "DOMAIN_I_position_last", mpp__init_ read%t_proc(:)%i_lci )830 CALL mpp_ add_att(mpp__init_read, tl_att)831 832 tl_att=att_init( "DOMAIN_J_position_last", mpp__init_ read%t_proc(:)%i_lcj )833 CALL mpp_ add_att(mpp__init_read, tl_att)834 835 tl_att=att_init( "DOMAIN_I_halo_size_start", mpp__init_ read%t_proc(:)%i_ldi )836 CALL mpp_ add_att(mpp__init_read, tl_att)837 838 tl_att=att_init( "DOMAIN_J_halo_size_start", mpp__init_ read%t_proc(:)%i_ldj )839 CALL mpp_ add_att(mpp__init_read, tl_att)840 841 tl_att=att_init( "DOMAIN_I_halo_size_end", mpp__init_ read%t_proc(:)%i_lei )842 CALL mpp_ add_att(mpp__init_read, tl_att)843 844 tl_att=att_init( "DOMAIN_J_halo_size_end", mpp__init_ read%t_proc(:)%i_lej )845 CALL mpp_ add_att(mpp__init_read, tl_att)1028 tl_att=att_init( "DOMAIN_number_total", mpp__init_file%i_nproc ) 1029 CALL mpp_move_att(mpp__init_file, tl_att) 1030 1031 tl_att=att_init( "DOMAIN_I_position_first", mpp__init_file%t_proc(:)%i_impp ) 1032 CALL mpp_move_att(mpp__init_file, tl_att) 1033 1034 tl_att=att_init( "DOMAIN_J_position_first", mpp__init_file%t_proc(:)%i_jmpp ) 1035 CALL mpp_move_att(mpp__init_file, tl_att) 1036 1037 tl_att=att_init( "DOMAIN_I_position_last", mpp__init_file%t_proc(:)%i_lci ) 1038 CALL mpp_move_att(mpp__init_file, tl_att) 1039 1040 tl_att=att_init( "DOMAIN_J_position_last", mpp__init_file%t_proc(:)%i_lcj ) 1041 CALL mpp_move_att(mpp__init_file, tl_att) 1042 1043 tl_att=att_init( "DOMAIN_I_halo_size_start", mpp__init_file%t_proc(:)%i_ldi ) 1044 CALL mpp_move_att(mpp__init_file, tl_att) 1045 1046 tl_att=att_init( "DOMAIN_J_halo_size_start", mpp__init_file%t_proc(:)%i_ldj ) 1047 CALL mpp_move_att(mpp__init_file, tl_att) 1048 1049 tl_att=att_init( "DOMAIN_I_halo_size_end", mpp__init_file%t_proc(:)%i_lei ) 1050 CALL mpp_move_att(mpp__init_file, tl_att) 1051 1052 tl_att=att_init( "DOMAIN_J_halo_size_end", mpp__init_file%t_proc(:)%i_lej ) 1053 CALL mpp_move_att(mpp__init_file, tl_att) 846 1054 1055 ! clean 1056 CALL mpp_clean(tl_mpp) 1057 CALL att_clean(tl_att) 847 1058 848 1059 CASE('dimg') 849 1060 ! domain decomposition could be read in one file 850 1061 851 tl_file= td_file1062 tl_file=file_copy(td_file) 852 1063 ! open file 1064 CALL logger_debug("MPP INIT READ: open file "//TRIM(tl_file%c_name)) 853 1065 CALL iom_open(tl_file) 854 1066 1067 CALL logger_debug("MPP INIT READ: read mpp structure ") 855 1068 ! read mpp structure 856 mpp__init_ read=mpp__init_read_rstdimg(tl_file)1069 mpp__init_file=mpp__init_file_rstdimg(tl_file) 857 1070 858 1071 ! mpp type 859 mpp__init_ read%c_type=TRIM(td_file%c_type)1072 mpp__init_file%c_type=TRIM(td_file%c_type) 860 1073 861 1074 ! mpp domain type 862 CALL mpp_get_dom(mpp__init_read) 1075 CALL logger_debug("MPP INIT READ: mpp_get_dom ") 1076 CALL mpp_get_dom(mpp__init_file) 863 1077 864 1078 ! get processor size 865 DO ji=1,mpp__init_read%i_nproc 866 867 il_shape(:)=mpp_get_proc_size( mpp__init_read, ji ) 1079 CALL logger_debug("MPP INIT READ: get processor size ") 1080 DO ji=1,mpp__init_file%i_nproc 1081 1082 il_shape(:)=mpp_get_proc_size( mpp__init_file, ji ) 868 1083 869 1084 tl_dim=dim_init('X',il_shape(1)) 870 CALL file_add_dim(mpp__init_ read%t_proc(ji), tl_dim)1085 CALL file_add_dim(mpp__init_file%t_proc(ji), tl_dim) 871 1086 872 1087 tl_dim=dim_init('Y',il_shape(2)) 873 CALL file_add_dim(mpp__init_read%t_proc(ji), tl_dim) 1088 CALL file_add_dim(mpp__init_file%t_proc(ji), tl_dim) 1089 1090 ! clean 1091 CALL dim_clean(tl_dim) 874 1092 875 1093 ENDDO … … 879 1097 880 1098 CASE DEFAULT 881 CALL logger_error(" INIT READ: invalid type for file "//&1099 CALL logger_error("MPP INIT READ: invalid type for file "//& 882 1100 & TRIM(tl_file%c_name)) 883 1101 END SELECT 884 1102 885 END FUNCTION mpp__init_read 886 ! @endcode 1103 ! east west overlap 1104 IF( PRESENT(id_ew) ) mpp__init_file%i_ew=id_ew 1105 ! NEMO periodicity 1106 IF( PRESENT(id_perio) )THEN 1107 mpp__init_file%i_perio= id_perio 1108 SELECT CASE(id_perio) 1109 CASE(3,4) 1110 mpp__init_file%i_pivot=1 1111 CASE(5,6) 1112 mpp__init_file%i_pivot=0 1113 CASE DEFAULT 1114 mpp__init_file%i_pivot=1 1115 END SELECT 1116 ENDIF 1117 1118 IF( PRESENT(id_pivot) ) mpp__init_file%i_pivot= id_pivot 1119 1120 ! clean 1121 CALL file_clean(tl_file) 1122 1123 END FUNCTION mpp__init_file 887 1124 !------------------------------------------------------------------- 888 1125 !> @brief This function initalise a mpp structure, … … 892 1129 ! 893 1130 !> @author J.Paul 894 !> - Nov, 2013- Initial Version 895 ! 896 !> @param[in] td_file : file strcuture 1131 !> @date November, 2013 - Initial Version 1132 !> @date July, 2015 - add only use dimension in MPP structure 1133 !> 1134 !> @param[in] td_file file strcuture 897 1135 !> @return mpp structure 898 1136 !------------------------------------------------------------------- 899 ! @code 900 TYPE(TMPP) FUNCTION mpp__init_read_cdf( td_file ) 1137 TYPE(TMPP) FUNCTION mpp__init_file_cdf( td_file ) 901 1138 IMPLICIT NONE 902 1139 … … 906 1143 ! local variable 907 1144 INTEGER(i4) :: il_attid ! attribute id 1145 908 1146 LOGICAL :: ll_exist 909 1147 LOGICAL :: ll_open 910 1148 911 1149 TYPE(TATT) :: tl_att 1150 1151 TYPE(TDIM) :: tl_dim 1152 912 1153 TYPE(TFILE) :: tl_proc 913 1154 !---------------------------------------------------------------- 914 1155 915 CALL logger_trace(" INIT READ: netcdf file "//TRIM(td_file%c_name))1156 CALL logger_trace("MPP INIT READ: netcdf file "//TRIM(td_file%c_name)) 916 1157 917 1158 INQUIRE( FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open ) … … 921 1162 IF( td_file%i_id == 0 )THEN 922 1163 CALL logger_info(" id "//TRIM(fct_str(td_file%i_id))) 923 CALL logger_error(" INIT READ: netcdf file "//TRIM(td_file%c_name)//&924 &" not opened")1164 CALL logger_error("MPP INIT READ: netcdf file "//& 1165 & TRIM(td_file%c_name)//" not opened") 925 1166 ELSE 926 1167 927 1168 ! get mpp name 928 mpp__init_ read_cdf%c_name=TRIM( file_rename(td_file%c_name) )1169 mpp__init_file_cdf%c_name=TRIM( file_rename(td_file%c_name) ) 929 1170 930 1171 ! add type 931 mpp__init_ read_cdf%c_type="cdf"1172 mpp__init_file_cdf%c_type="cdf" 932 1173 933 1174 ! global domain size … … 937 1178 ENDIF 938 1179 IF( il_attid /= 0 )THEN 939 mpp__init_read_cdf%t_dim(1)= & 940 & dim_init('X',INT(td_file%t_att(il_attid)%d_value(1))) 941 mpp__init_read_cdf%t_dim(2)= & 942 & dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2))) 943 ELSE 944 mpp__init_read_cdf%t_dim(1)= & 945 & dim_init( td_file%t_dim(1)%c_name, td_file%t_dim(1)%i_len) 946 mpp__init_read_cdf%t_dim(2)= & 947 & dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len) 948 949 ENDIF 950 mpp__init_read_cdf%t_dim(3)= & 951 & dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(1)%i_len) 952 mpp__init_read_cdf%t_dim(4)= & 953 & dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(2)%i_len) 1180 tl_dim=dim_init('X',INT(td_file%t_att(il_attid)%d_value(1))) 1181 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1182 1183 tl_dim=dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2))) 1184 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1185 ELSE ! assume only one file (not mpp) 1186 tl_dim=dim_init( td_file%t_dim(1)%c_name, td_file%t_dim(1)%i_len) 1187 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1188 1189 tl_dim=dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len) 1190 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1191 ENDIF 1192 1193 IF( td_file%t_dim(3)%l_use )THEN 1194 tl_dim=dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(3)%i_len) 1195 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1196 ENDIF 1197 1198 IF( td_file%t_dim(4)%l_use )THEN 1199 tl_dim=dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(4)%i_len) 1200 CALL mpp_add_dim(mpp__init_file_cdf,tl_dim) 1201 ENDIF 954 1202 955 1203 ! initialise file/processor 956 tl_proc= td_file1204 tl_proc=file_copy(td_file) 957 1205 958 1206 ! processor id … … 968 1216 969 1217 ! processor dimension 970 tl_proc%t_dim(:)= td_file%t_dim(:)1218 tl_proc%t_dim(:)=dim_copy(td_file%t_dim(:)) 971 1219 972 1220 ! DOMAIN_position_first … … 992 1240 tl_proc%i_lcj = INT(td_file%t_att(il_attid)%d_value(2)) + tl_proc%i_jmpp 993 1241 ELSE 994 tl_proc%i_lci = mpp__init_ read_cdf%t_dim(1)%i_len995 tl_proc%i_lcj = mpp__init_ read_cdf%t_dim(2)%i_len1242 tl_proc%i_lci = mpp__init_file_cdf%t_dim(1)%i_len 1243 tl_proc%i_lcj = mpp__init_file_cdf%t_dim(2)%i_len 996 1244 ENDIF 997 1245 … … 1018 1266 tl_proc%i_lej = INT(td_file%t_att(il_attid)%d_value(2)) 1019 1267 ELSE 1020 tl_proc%i_lei = mpp__init_ read_cdf%t_dim(1)%i_len1021 tl_proc%i_lej = mpp__init_ read_cdf%t_dim(2)%i_len1268 tl_proc%i_lei = mpp__init_file_cdf%t_dim(1)%i_len 1269 tl_proc%i_lej = mpp__init_file_cdf%t_dim(2)%i_len 1022 1270 ENDIF 1023 1271 1024 1272 ! add attributes 1025 1273 tl_att=att_init( "DOMAIN_size_global", & 1026 & mpp__init_ read_cdf%t_dim(:)%i_len)1274 & mpp__init_file_cdf%t_dim(:)%i_len) 1027 1275 CALL file_move_att(tl_proc, tl_att) 1028 1276 … … 1047 1295 1048 1296 ! add processor to mpp structure 1049 CALL mpp__add_proc(mpp__init_read_cdf, tl_proc) 1050 1297 CALL mpp__add_proc(mpp__init_file_cdf, tl_proc) 1298 1299 ! clean 1300 CALL file_clean(tl_proc) 1301 CALL att_clean(tl_att) 1051 1302 ENDIF 1052 1303 1053 1304 ELSE 1054 1305 1055 CALL logger_error(" INIT READ: netcdf file "//TRIM(td_file%c_name)//&1306 CALL logger_error("MPP INIT READ: netcdf file "//TRIM(td_file%c_name)//& 1056 1307 & " do not exist") 1057 1308 1058 1309 ENDIF 1059 END FUNCTION mpp__init_read_cdf 1060 ! @endcode 1310 END FUNCTION mpp__init_file_cdf 1061 1311 !------------------------------------------------------------------- 1062 1312 !> @brief This function initalise a mpp structure, … … 1066 1316 ! 1067 1317 !> @author J.Paul 1068 !> - Nov, 2013- Initial Version1069 ! 1070 !> @param[in] td_file :file strcuture1318 !> @date November, 2013 - Initial Version 1319 ! 1320 !> @param[in] td_file file strcuture 1071 1321 !> @return mpp structure 1072 1322 !------------------------------------------------------------------- 1073 ! @code 1074 TYPE(TMPP) FUNCTION mpp__init_read_rstdimg( td_file ) 1323 TYPE(TMPP) FUNCTION mpp__init_file_rstdimg( td_file ) 1075 1324 IMPLICIT NONE 1076 1325 … … 1079 1328 1080 1329 ! local variable 1081 INTEGER(i4) :: il_status1082 INTEGER(i4) :: il_recl ! record length1083 INTEGER(i4) :: il_nx, il_ny, il_nz ! x,y,z dimension1084 INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d ! number of 0/1/2/3D variables1085 INTEGER(i4) :: il_iglo, il_jglo ! domain global size1086 INTEGER(i4) :: il_rhd ! record of the header infos1087 INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition1088 INTEGER(i4) :: il_area ! domain index1089 1090 LOGICAL :: ll_exist1091 LOGICAL :: ll_open1330 INTEGER(i4) :: il_status 1331 INTEGER(i4) :: il_recl ! record length 1332 INTEGER(i4) :: il_nx, il_ny, il_nz ! x,y,z dimension 1333 INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d ! number of 0/1/2/3D variables 1334 INTEGER(i4) :: il_iglo, il_jglo ! domain global size 1335 INTEGER(i4) :: il_rhd ! record of the header infos 1336 INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition 1337 INTEGER(i4) :: il_area ! domain index 1338 1339 LOGICAL :: ll_exist 1340 LOGICAL :: ll_open 1092 1341 1093 1342 CHARACTER(LEN=lc) :: cl_file 1094 1343 1095 TYPE(TDIM) :: tl_dim ! dimension structure 1096 TYPE(TATT) :: tl_att 1344 TYPE(TDIM) :: tl_dim ! dimension structure 1345 TYPE(TATT) :: tl_att 1346 TYPE(TFILE) :: tl_proc 1097 1347 1098 1348 ! loop indices … … 1104 1354 1105 1355 IF( .NOT. ll_open )THEN 1106 CALL logger_error(" INIT READ: dimg file "//TRIM(td_file%c_name)//&1356 CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//& 1107 1357 & " not opened") 1108 1358 ELSE … … 1118 1368 CALL fct_err(il_status) 1119 1369 IF( il_status /= 0 )THEN 1120 CALL logger_error(" INIT READ: read first line header of "//&1370 CALL logger_error("MPP INIT READ: read first line header of "//& 1121 1371 & TRIM(td_file%c_name)) 1122 1372 ENDIF 1123 1373 1124 1374 ! get mpp name 1125 mpp__init_read_rstdimg%c_name=TRIM( file_rename(td_file%c_name) ) 1375 mpp__init_file_rstdimg%c_name=TRIM( file_rename(td_file%c_name) ) 1376 1377 ! add type 1378 mpp__init_file_rstdimg%c_type="dimg" 1126 1379 1127 1380 ! number of processors to be read 1128 mpp__init_read_rstdimg%i_nproc = il_pnij 1129 mpp__init_read_rstdimg%i_niproc = il_pni 1130 mpp__init_read_rstdimg%i_njproc = il_pnj 1131 1132 IF( ASSOCIATED(mpp__init_read_rstdimg%t_proc) )THEN 1133 DEALLOCATE(mpp__init_read_rstdimg%t_proc) 1134 ENDIF 1135 ALLOCATE( mpp__init_read_rstdimg%t_proc(il_pnij) , stat=il_status ) 1381 mpp__init_file_rstdimg%i_nproc = il_pnij 1382 mpp__init_file_rstdimg%i_niproc = il_pni 1383 mpp__init_file_rstdimg%i_njproc = il_pnj 1384 1385 IF( ASSOCIATED(mpp__init_file_rstdimg%t_proc) )THEN 1386 CALL file_clean(mpp__init_file_rstdimg%t_proc(:)) 1387 DEALLOCATE(mpp__init_file_rstdimg%t_proc) 1388 ENDIF 1389 ALLOCATE( mpp__init_file_rstdimg%t_proc(il_pnij) , stat=il_status ) 1390 1391 tl_proc=file_copy(td_file) 1392 ! remove dimension from file 1393 CALL dim_clean(tl_proc%t_dim(:)) 1394 ! initialise file/processors 1395 DO ji=1,mpp__init_file_rstdimg%i_nproc 1396 mpp__init_file_rstdimg%t_proc(ji)=file_copy(tl_proc) 1397 ENDDO 1398 1136 1399 IF( il_status /= 0 )THEN 1137 CALL logger_error(" INIT READ: not enough space to read domain &1400 CALL logger_error("MPP INIT READ: not enough space to read domain & 1138 1401 & decomposition in file "//TRIM(td_file%c_name)) 1139 1402 ENDIF … … 1148 1411 & il_area, & 1149 1412 & il_iglo, il_jglo, & 1150 & mpp__init_ read_rstdimg%t_proc(:)%i_lci, &1151 & mpp__init_ read_rstdimg%t_proc(:)%i_lcj, &1152 & mpp__init_ read_rstdimg%t_proc(:)%i_ldi, &1153 & mpp__init_ read_rstdimg%t_proc(:)%i_ldj, &1154 & mpp__init_ read_rstdimg%t_proc(:)%i_lei, &1155 & mpp__init_ read_rstdimg%t_proc(:)%i_lej, &1156 & mpp__init_ read_rstdimg%t_proc(:)%i_impp, &1157 & mpp__init_ read_rstdimg%t_proc(:)%i_jmpp1413 & mpp__init_file_rstdimg%t_proc(:)%i_lci, & 1414 & mpp__init_file_rstdimg%t_proc(:)%i_lcj, & 1415 & mpp__init_file_rstdimg%t_proc(:)%i_ldi, & 1416 & mpp__init_file_rstdimg%t_proc(:)%i_ldj, & 1417 & mpp__init_file_rstdimg%t_proc(:)%i_lei, & 1418 & mpp__init_file_rstdimg%t_proc(:)%i_lej, & 1419 & mpp__init_file_rstdimg%t_proc(:)%i_impp, & 1420 & mpp__init_file_rstdimg%t_proc(:)%i_jmpp 1158 1421 CALL fct_err(il_status) 1159 1422 IF( il_status /= 0 )THEN 1160 CALL logger_error(" INIT READ: read first line of "//&1423 CALL logger_error("MPP INIT READ: read first line of "//& 1161 1424 & TRIM(td_file%c_name)) 1162 1425 ENDIF 1163 1426 1164 ! mpp dimension1427 ! global domain size 1165 1428 tl_dim=dim_init('X',il_iglo) 1166 CALL mpp_add_dim(mpp__init_ read_rstdimg,tl_dim)1429 CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim) 1167 1430 tl_dim=dim_init('Y',il_jglo) 1168 CALL mpp_add_dim(mpp__init_read_rstdimg,tl_dim) 1169 1170 DO ji=1,mpp__init_read_rstdimg%i_nproc 1431 CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim) 1432 1433 tl_dim=dim_init('Z',il_nz) 1434 CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim) 1435 1436 DO ji=1,mpp__init_file_rstdimg%i_nproc 1171 1437 ! get file name 1172 1438 cl_file = file_rename(td_file%c_name,ji) 1173 mpp__init_ read_rstdimg%t_proc(ji)%c_name = TRIM(cl_file)1439 mpp__init_file_rstdimg%t_proc(ji)%c_name = TRIM(cl_file) 1174 1440 ! update processor id 1175 mpp__init_ read_rstdimg%t_proc(ji)%i_pid=ji1441 mpp__init_file_rstdimg%t_proc(ji)%i_pid=ji 1176 1442 1177 1443 ! add attributes 1178 1444 tl_att=att_init( "DOMAIN_number", ji ) 1179 CALL file_move_att(mpp__init_ read_rstdimg%t_proc(ji), tl_att)1445 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att) 1180 1446 1181 1447 tl_att=att_init( "DOMAIN_position_first", & 1182 & (/mpp__init_ read_rstdimg%t_proc(ji)%i_impp, &1183 & mpp__init_ read_rstdimg%t_proc(ji)%i_jmpp /) )1184 CALL file_move_att(mpp__init_ read_rstdimg%t_proc(ji), tl_att)1448 & (/mpp__init_file_rstdimg%t_proc(ji)%i_impp, & 1449 & mpp__init_file_rstdimg%t_proc(ji)%i_jmpp /) ) 1450 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att) 1185 1451 1186 1452 tl_att=att_init( "DOMAIN_position_last", & 1187 & (/mpp__init_ read_rstdimg%t_proc(ji)%i_lci, &1188 & mpp__init_ read_rstdimg%t_proc(ji)%i_lcj /) )1189 CALL file_move_att(mpp__init_ read_rstdimg%t_proc(ji), tl_att)1453 & (/mpp__init_file_rstdimg%t_proc(ji)%i_lci, & 1454 & mpp__init_file_rstdimg%t_proc(ji)%i_lcj /) ) 1455 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att) 1190 1456 1191 1457 tl_att=att_init( "DOMAIN_halo_size_start", & 1192 & (/mpp__init_ read_rstdimg%t_proc(ji)%i_ldi, &1193 & mpp__init_ read_rstdimg%t_proc(ji)%i_ldj /) )1194 CALL file_move_att(mpp__init_ read_rstdimg%t_proc(ji), tl_att)1458 & (/mpp__init_file_rstdimg%t_proc(ji)%i_ldi, & 1459 & mpp__init_file_rstdimg%t_proc(ji)%i_ldj /) ) 1460 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att) 1195 1461 1196 1462 tl_att=att_init( "DOMAIN_halo_size_end", & 1197 & (/mpp__init_ read_rstdimg%t_proc(ji)%i_lei, &1198 & mpp__init_ read_rstdimg%t_proc(ji)%i_lej /) )1199 CALL file_move_att(mpp__init_ read_rstdimg%t_proc(ji), tl_att)1463 & (/mpp__init_file_rstdimg%t_proc(ji)%i_lei, & 1464 & mpp__init_file_rstdimg%t_proc(ji)%i_lej /) ) 1465 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att) 1200 1466 ENDDO 1201 1467 1202 1468 ! add type 1203 mpp__init_ read_rstdimg%t_proc(:)%c_type="dimg"1469 mpp__init_file_rstdimg%t_proc(:)%c_type="dimg" 1204 1470 1205 1471 ! add attributes 1206 1472 tl_att=att_init( "DOMAIN_size_global", & 1207 & mpp__init_ read_rstdimg%t_dim(:)%i_len)1208 CALL mpp_move_att(mpp__init_ read_rstdimg, tl_att)1473 & mpp__init_file_rstdimg%t_dim(:)%i_len) 1474 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1209 1475 1210 1476 tl_att=att_init( "DOMAIN_number_total", & 1211 & mpp__init_ read_rstdimg%i_nproc )1212 CALL mpp_ add_att(mpp__init_read_rstdimg, tl_att)1477 & mpp__init_file_rstdimg%i_nproc ) 1478 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1213 1479 1214 1480 tl_att=att_init( "DOMAIN_I_number_total", & 1215 & mpp__init_ read_rstdimg%i_niproc )1216 CALL mpp_ add_att(mpp__init_read_rstdimg, tl_att)1481 & mpp__init_file_rstdimg%i_niproc ) 1482 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1217 1483 1218 1484 tl_att=att_init( "DOMAIN_J_number_total", & 1219 & mpp__init_ read_rstdimg%i_njproc )1220 CALL mpp_ add_att(mpp__init_read_rstdimg, tl_att)1485 & mpp__init_file_rstdimg%i_njproc ) 1486 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1221 1487 1222 1488 tl_att=att_init( "DOMAIN_I_position_first", & 1223 & mpp__init_ read_rstdimg%t_proc(:)%i_impp )1224 CALL mpp_ add_att(mpp__init_read_rstdimg, tl_att)1489 & mpp__init_file_rstdimg%t_proc(:)%i_impp ) 1490 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1225 1491 1226 1492 tl_att=att_init( "DOMAIN_J_position_first", & 1227 & mpp__init_ read_rstdimg%t_proc(:)%i_jmpp )1228 CALL mpp_ add_att(mpp__init_read_rstdimg, tl_att)1493 & mpp__init_file_rstdimg%t_proc(:)%i_jmpp ) 1494 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1229 1495 1230 1496 tl_att=att_init( "DOMAIN_I_position_last", & 1231 & mpp__init_ read_rstdimg%t_proc(:)%i_lci )1232 CALL mpp_ add_att(mpp__init_read_rstdimg, tl_att)1497 & mpp__init_file_rstdimg%t_proc(:)%i_lci ) 1498 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1233 1499 1234 1500 tl_att=att_init( "DOMAIN_J_position_last", & 1235 & mpp__init_ read_rstdimg%t_proc(:)%i_lcj )1236 CALL mpp_ add_att(mpp__init_read_rstdimg, tl_att)1501 & mpp__init_file_rstdimg%t_proc(:)%i_lcj ) 1502 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1237 1503 1238 1504 tl_att=att_init( "DOMAIN_I_halo_size_start", & 1239 & mpp__init_ read_rstdimg%t_proc(:)%i_ldi )1240 CALL mpp_ add_att(mpp__init_read_rstdimg, tl_att)1505 & mpp__init_file_rstdimg%t_proc(:)%i_ldi ) 1506 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1241 1507 1242 1508 tl_att=att_init( "DOMAIN_J_halo_size_start", & 1243 & mpp__init_ read_rstdimg%t_proc(:)%i_ldj )1244 CALL mpp_ add_att(mpp__init_read_rstdimg, tl_att)1509 & mpp__init_file_rstdimg%t_proc(:)%i_ldj ) 1510 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1245 1511 1246 1512 tl_att=att_init( "DOMAIN_I_halo_size_end", & 1247 & mpp__init_ read_rstdimg%t_proc(:)%i_lei )1248 CALL mpp_ add_att(mpp__init_read_rstdimg, tl_att)1513 & mpp__init_file_rstdimg%t_proc(:)%i_lei ) 1514 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1249 1515 1250 1516 tl_att=att_init( "DOMAIN_J_halo_size_end", & 1251 & mpp__init_read_rstdimg%t_proc(:)%i_lej ) 1252 CALL mpp_add_att(mpp__init_read_rstdimg, tl_att) 1517 & mpp__init_file_rstdimg%t_proc(:)%i_lej ) 1518 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1519 1520 ! clean 1521 CALL dim_clean(tl_dim) 1522 CALL att_clean(tl_att) 1253 1523 ENDIF 1254 1524 1255 1525 ELSE 1256 1526 1257 CALL logger_error(" INIT READ: dimg file "//TRIM(td_file%c_name)//&1527 CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//& 1258 1528 & " do not exist") 1259 1529 1260 1530 ENDIF 1261 1531 1262 END FUNCTION mpp__init_read_rstdimg 1263 ! @endcode 1532 END FUNCTION mpp__init_file_rstdimg 1264 1533 !------------------------------------------------------------------- 1265 1534 !> @brief This function check if variable and mpp structure use same 1266 1535 !> dimension. 1267 1536 ! 1268 !> @details 1269 ! 1270 !> @author J.Paul 1271 !> - Nov, 2013- Initial Version 1272 ! 1273 !> @param[in] td_mpp : mpp structure 1274 !> @param[in] td_proc : processor structure 1537 !> @author J.Paul 1538 !> @date November, 2013 - Initial Version 1539 ! 1540 !> @param[in] td_mpp mpp structure 1541 !> @param[in] td_proc processor structure 1275 1542 !> @return dimension of processor and mpp structure agree (or not) 1276 1543 !------------------------------------------------------------------- 1277 ! @code1278 1544 LOGICAL FUNCTION mpp__check_proc_dim(td_mpp, td_proc) 1279 1545 IMPLICIT NONE … … 1301 1567 mpp__check_proc_dim=.FALSE. 1302 1568 1303 CALL logger_error( " CHECK DIM: processor and mpp dimension differ" )1569 CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" ) 1304 1570 1305 1571 ENDIF … … 1312 1578 mpp__check_proc_dim=.FALSE. 1313 1579 1314 CALL logger_error( " CHECK DIM: processor and mpp dimension differ" )1580 CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" ) 1315 1581 1316 1582 ENDIF … … 1318 1584 1319 1585 END FUNCTION mpp__check_proc_dim 1320 ! @endcode1321 1586 !------------------------------------------------------------------- 1322 1587 !> @brief 1323 !> This subroutine add variable to mpp structure. 1324 !> 1325 !> @detail 1326 ! 1327 !> @author J.Paul 1328 !> @date Nov, 2013 1329 ! 1330 !> @param[inout] td_mpp : mpp strcuture 1331 !> @param[in] td_var : variable strcuture 1332 ! 1333 !> @todo 1334 !------------------------------------------------------------------- 1335 !> @code 1588 !> This subroutine add variable in all files of mpp structure. 1589 !> 1590 !> @author J.Paul 1591 !> @date November, 2013 - Initial version 1592 ! 1593 !> @param[inout] td_mpp mpp strcuture 1594 !> @param[in] td_var variable strcuture 1595 !------------------------------------------------------------------- 1336 1596 SUBROUTINE mpp_add_var( td_mpp, td_var ) 1337 1597 IMPLICIT NONE … … 1350 1610 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN 1351 1611 1352 CALL logger_error( "MPP ADD VAR: domain decomposition not define "//& 1353 & "for mpp "//TRIM(td_mpp%c_name)) 1354 1355 ELSEIF( td_mpp%i_ndim == 0 )THEN 1356 1357 CALL logger_error( " MPP ADD VAR: no dimension define for "//& 1358 & " mpp strcuture "//TRIM(td_mpp%c_name)) 1612 CALL logger_error( "MPP ADD VAR: processor decomposition not "//& 1613 & "define for mpp "//TRIM(td_mpp%c_name)) 1359 1614 1360 1615 ELSE … … 1367 1622 il_varid=0 1368 1623 IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN 1369 il_varid=var_get_i d( td_mpp%t_proc(1)%t_var(:), &1370 & td_var%c_name, td_var%c_stdname )1624 il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), & 1625 & td_var%c_name, td_var%c_stdname ) 1371 1626 ENDIF 1372 1627 1373 1628 IF( il_varid /= 0 )THEN 1374 1375 CALL logger_error( " MPP ADD VAR: variable "//TRIM(td_var%c_name)//&1376 & ", standard name "//TRIM(td_var%c_stdname)//&1377 & ", already in mpp "//TRIM(td_mpp%c_name) )1378 1629 1379 1630 DO ji=1,td_mpp%t_proc(1)%i_nvar … … 1383 1634 & TRIM(td_mpp%t_proc(1)%t_var(ji)%c_stdname) ) 1384 1635 ENDDO 1636 CALL logger_error( " MPP ADD VAR: variable "//TRIM(td_var%c_name)//& 1637 & ", standard name "//TRIM(td_var%c_stdname)//& 1638 & ", already in mpp "//TRIM(td_mpp%c_name) ) 1385 1639 1386 1640 ELSE … … 1393 1647 IF( mpp__check_dim(td_mpp, td_var) )THEN 1394 1648 1649 ! update dimension if need be 1650 DO ji=1,ip_maxdim 1651 IF( td_var%t_dim(ji)%l_use .AND. & 1652 & .NOT. td_mpp%t_dim(ji)%l_use )THEN 1653 CALL mpp_add_dim(td_mpp,td_var%t_dim(ji)) 1654 ENDIF 1655 ENDDO 1656 1395 1657 ! add variable in each processor 1396 1658 DO ji=1,td_mpp%i_nproc … … 1401 1663 CALL file_add_var(td_mpp%t_proc(ji), tl_var) 1402 1664 1665 ! clean 1666 CALL var_clean(tl_var) 1403 1667 ENDDO 1404 1668 … … 1409 1673 1410 1674 END SUBROUTINE mpp_add_var 1411 !> @endcode 1412 !------------------------------------------------------------------- 1413 !> @brief This function extract from variable structure, part that will 1675 !------------------------------------------------------------------- 1676 !> @brief This function extract, from variable structure, part that will 1414 1677 !> be written in processor id_procid.<br/> 1415 1678 ! 1416 !> @details 1417 ! 1418 !> @author J.Paul 1419 !> - Nov, 2013- Initial Version 1420 ! 1421 !> @param[in] td_mpp : mpp structure 1422 !> @param[in] td_var : variable structure 1423 !> @param[in] id_procid : processor id 1679 !> @author J.Paul 1680 !> @date November, 2013 - Initial Version 1681 ! 1682 !> @param[in] td_mpp mpp structure 1683 !> @param[in] td_var variable structure 1684 !> @param[in] id_procid processor id 1424 1685 !> @return variable structure 1425 1686 !------------------------------------------------------------------- 1426 ! @code1427 1687 TYPE(TVAR) FUNCTION mpp__split_var(td_mpp, td_var, id_procid) 1428 1688 IMPLICIT NONE … … 1444 1704 1445 1705 ! copy mpp 1446 mpp__split_var=td_var 1447 1448 ! remove value over global domain from pointer 1449 CALL var_del_value( mpp__split_var ) 1450 1451 ! get processor dimension 1452 il_size(:)=mpp_get_proc_size( td_mpp, id_procid ) 1453 1454 ! define new dimension in variable structure 1455 IF( td_var%t_dim(1)%l_use )THEN 1456 tl_dim=dim_init( TRIM(td_var%t_dim(1)%c_name), il_size(1) ) 1457 CALL var_move_dim( mpp__split_var, tl_dim ) 1458 ENDIF 1459 IF( td_var%t_dim(2)%l_use )THEN 1460 tl_dim=dim_init( TRIM(td_var%t_dim(2)%c_name), il_size(2) ) 1461 CALL var_move_dim( mpp__split_var, tl_dim ) 1462 ENDIF 1463 1464 ! get processor indices 1465 il_ind(:)=mpp_get_proc_index( td_mpp, id_procid ) 1466 il_i1 = il_ind(1) 1467 il_i2 = il_ind(2) 1468 il_j1 = il_ind(3) 1469 il_j2 = il_ind(4) 1470 1471 IF( .NOT. td_var%t_dim(1)%l_use )THEN 1472 il_i1=1 1473 il_i2=1 1474 ENDIF 1475 1476 IF( .NOT. td_var%t_dim(2)%l_use )THEN 1477 il_j1=1 1478 il_j2=1 1479 ENDIF 1480 1481 ! add variable value on processor 1482 CALL var_add_value( mpp__split_var, & 1483 & td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) ) 1706 mpp__split_var=var_copy(td_var) 1707 1708 IF( ASSOCIATED(td_var%d_value) )THEN 1709 ! remove value over global domain from pointer 1710 CALL var_del_value( mpp__split_var ) 1711 1712 ! get processor dimension 1713 il_size(:)=mpp_get_proc_size( td_mpp, id_procid ) 1714 1715 ! define new dimension in variable structure 1716 IF( td_var%t_dim(1)%l_use )THEN 1717 tl_dim=dim_init( TRIM(td_var%t_dim(1)%c_name), il_size(1) ) 1718 CALL var_move_dim( mpp__split_var, tl_dim ) 1719 ENDIF 1720 IF( td_var%t_dim(2)%l_use )THEN 1721 tl_dim=dim_init( TRIM(td_var%t_dim(2)%c_name), il_size(2) ) 1722 CALL var_move_dim( mpp__split_var, tl_dim ) 1723 ENDIF 1724 1725 ! get processor indices 1726 il_ind(:)=mpp_get_proc_index( td_mpp, id_procid ) 1727 il_i1 = il_ind(1) 1728 il_i2 = il_ind(2) 1729 il_j1 = il_ind(3) 1730 il_j2 = il_ind(4) 1731 1732 IF( .NOT. td_var%t_dim(1)%l_use )THEN 1733 il_i1=1 1734 il_i2=1 1735 ENDIF 1736 1737 IF( .NOT. td_var%t_dim(2)%l_use )THEN 1738 il_j1=1 1739 il_j2=1 1740 ENDIF 1741 1742 ! add variable value on processor 1743 CALL var_add_value( mpp__split_var, & 1744 & td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) ) 1745 ENDIF 1484 1746 1485 1747 END FUNCTION mpp__split_var 1486 !> @endcode 1748 !------------------------------------------------------------------- 1749 !> @brief 1750 !> This subroutine delete all variable in mpp strcuture. 1751 !> 1752 !> @author J.Paul 1753 !> @date October, 2014 - Initial version 1754 !> 1755 !> @param[inout] td_mpp mpp strcuture 1756 !------------------------------------------------------------------- 1757 SUBROUTINE mpp__del_var_mpp( td_mpp ) 1758 IMPLICIT NONE 1759 ! Argument 1760 TYPE(TMPP), INTENT(INOUT) :: td_mpp 1761 1762 ! local variable 1763 ! loop indices 1764 INTEGER(i4) :: ji 1765 !---------------------------------------------------------------- 1766 1767 CALL logger_info( & 1768 & "MPP CLEAN VAR: reset all variable "//& 1769 & "in mpp strcuture "//TRIM(td_mpp%c_name) ) 1770 1771 IF( ASSOCIATED(td_mpp%t_proc) )THEN 1772 DO ji=td_mpp%t_proc(1)%i_nvar,1,-1 1773 CALL mpp_del_var(td_mpp, td_mpp%t_proc(1)%t_var(ji)) 1774 ENDDO 1775 ENDIF 1776 1777 END SUBROUTINE mpp__del_var_mpp 1487 1778 !------------------------------------------------------------------- 1488 1779 !> @brief … … 1490 1781 !> structure. 1491 1782 !> 1492 !> @detail 1493 ! 1494 !> @author J.Paul 1495 !> @date Nov, 2013 1496 ! 1497 !> @param[inout] td_mpp : mpp strcuture 1498 !> @param[in] td_var : variable strcuture 1499 ! 1500 !> @todo 1501 !------------------------------------------------------------------- 1502 !> @code 1783 !> @author J.Paul 1784 !> @date November, 2013 - Initial version 1785 ! 1786 !> @param[inout] td_mpp mpp strcuture 1787 !> @param[in] td_var variable strcuture 1788 !------------------------------------------------------------------- 1503 1789 SUBROUTINE mpp__del_var_str( td_mpp, td_var ) 1504 1790 IMPLICIT NONE … … 1517 1803 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN 1518 1804 1519 CALL logger_error( " DEL VAR: domain decomposition not define "//&1805 CALL logger_error( "MPP DEL VAR: domain decomposition not define "//& 1520 1806 & " in mpp strcuture "//TRIM(td_mpp%c_name)) 1521 1807 … … 1525 1811 il_varid = 0 1526 1812 IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN 1527 il_varid=var_get_i d( td_mpp%t_proc(1)%t_var(:), &1528 & td_var%c_name, td_var%c_stdname )1813 il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), & 1814 & td_var%c_name, td_var%c_stdname ) 1529 1815 ENDIF 1530 1816 IF( il_varid == 0 )THEN 1531 1817 CALL logger_error( & 1532 & " DEL VAR: no variable "//TRIM(td_var%c_name)//&1818 & "MPP DEL VAR: no variable "//TRIM(td_var%c_name)//& 1533 1819 & ", in mpp structure "//TRIM(td_mpp%c_name) ) 1534 1820 1535 1821 DO ji=1,td_mpp%t_proc(1)%i_nvar 1536 CALL logger_debug( " DEL VAR: in mpp structure : &1822 CALL logger_debug( "MPP DEL VAR: in mpp structure : & 1537 1823 & variable : "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)//& 1538 1824 & ", standard name "//& … … 1551 1837 ENDIF 1552 1838 END SUBROUTINE mpp__del_var_str 1553 !> @endcode1554 1839 !------------------------------------------------------------------- 1555 1840 !> @brief 1556 1841 !> This subroutine delete variable in mpp structure, given variable name. 1557 1842 !> 1558 !> @detail 1559 ! 1560 !> @author J.Paul 1561 !> @date Nov, 2013 1562 ! 1563 !> @param[inout] td_mpp : mpp strcuture 1564 !> @param[in] cd_name: variable name 1565 ! 1566 !> @todo 1567 !------------------------------------------------------------------- 1568 !> @code 1843 !> @author J.Paul 1844 !> @date November, 2013 - Initial version 1845 !> @date February, 2015 1846 !> - define local variable structure to avoid mistake with pointer 1847 ! 1848 !> @param[inout] td_mpp mpp strcuture 1849 !> @param[in] cd_name variable name 1850 !------------------------------------------------------------------- 1569 1851 SUBROUTINE mpp__del_var_name( td_mpp, cd_name ) 1570 1852 IMPLICIT NONE … … 1575 1857 ! local variable 1576 1858 INTEGER(i4) :: il_varid 1859 TYPE(TVAR) :: tl_var 1577 1860 !---------------------------------------------------------------- 1578 1861 ! check if mpp exist 1579 1862 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN 1580 1863 1581 CALL logger_error( " DEL VAR: domain decomposition not define "//&1864 CALL logger_error( "MPP DEL VAR: domain decomposition not define "//& 1582 1865 & " in mpp strcuture "//TRIM(td_mpp%c_name)) 1583 1866 … … 1585 1868 1586 1869 IF( td_mpp%t_proc(1)%i_nvar == 0 )THEN 1587 CALL logger_debug( " DEL VAR NAME: no variable associated to mpp &1870 CALL logger_debug( "MPP DEL VAR NAME: no variable associated to mpp & 1588 1871 & structure "//TRIM(td_mpp%c_name) ) 1589 1872 ELSE … … 1592 1875 il_varid=0 1593 1876 IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN 1594 il_varid=var_get_id( td_mpp%t_proc(1)%t_var(:), & 1595 & cd_name ) 1596 ENDIF 1877 il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), & 1878 & cd_name ) 1879 ENDIF 1880 1597 1881 IF( il_varid == 0 )THEN 1598 1882 1599 1883 CALL logger_warn( & 1600 & " DEL VAR : there is no variable with name "//&1884 & "MPP DEL VAR : there is no variable with name "//& 1601 1885 & "or standard name "//TRIM(ADJUSTL(cd_name))//& 1602 1886 & " in mpp structure "//TRIM(td_mpp%c_name)) … … 1604 1888 ELSE 1605 1889 1606 CALL mpp_del_var(td_mpp, td_mpp%t_proc(1)%t_var(il_varid)) 1890 tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid)) 1891 CALL mpp_del_var(td_mpp, tl_var) 1607 1892 1608 1893 ENDIF … … 1611 1896 ENDIF 1612 1897 END SUBROUTINE mpp__del_var_name 1613 !> @endcode1614 1898 !------------------------------------------------------------------- 1615 1899 !> @brief 1616 1900 !> This subroutine overwrite variable in mpp structure. 1617 1901 !> 1618 !> @detail 1619 ! 1620 !> @author J.Paul 1621 !> @date Nov, 2013 1622 ! 1623 !> @param[inout] td_mpp : mpp strcuture 1624 !> @param[in] td_var : variable structure 1625 !> @todo 1626 !> - voir si il ne faut pas redefinir (__copy) variable si elle vient de mpp 1627 !> exemple CALL mpp_move_var( td_mpp, td_mpp%t_proc()%t_var ) 1628 !> remarque cas probabelement impossible puisque td_var doit avoir dim de td_mpp 1629 !------------------------------------------------------------------- 1630 !> @code 1902 !> @author J.Paul 1903 !> @date November, 2013 - Initial version 1904 ! 1905 !> @param[inout] td_mpp mpp strcuture 1906 !> @param[in] td_var variable structure 1907 !------------------------------------------------------------------- 1631 1908 SUBROUTINE mpp_move_var( td_mpp, td_var ) 1632 1909 IMPLICIT NONE … … 1639 1916 !---------------------------------------------------------------- 1640 1917 ! copy variable 1641 tl_var= td_var1918 tl_var=var_copy(td_var) 1642 1919 1643 1920 ! remove processor … … 1647 1924 CALL mpp_add_var(td_mpp, tl_var) 1648 1925 1926 ! clean 1927 CALL var_clean(tl_var) 1928 1649 1929 END SUBROUTINE mpp_move_var 1650 1930 !> @endcode … … 1653 1933 !> This subroutine add processor to mpp structure. 1654 1934 !> 1655 !> @detail 1656 ! 1657 !> @author J.Paul 1658 !> @date Nov, 2013 1659 ! 1660 !> @param[inout] td_mpp : mpp strcuture 1661 !> @param[in] td_proc : processor strcuture 1935 !> @author J.Paul 1936 !> @date November, 2013 - Initial version 1937 ! 1938 !> @param[inout] td_mpp mpp strcuture 1939 !> @param[in] td_proc processor strcuture 1662 1940 ! 1663 1941 !> @todo 1664 1942 !> - check proc type 1665 1943 !------------------------------------------------------------------- 1666 !> @code1667 1944 SUBROUTINE mpp__add_proc( td_mpp, td_proc ) 1668 1945 IMPLICIT NONE … … 1698 1975 1699 1976 CALL logger_error( & 1700 & " ADD PROC: processor "//TRIM(fct_str(td_proc%i_pid))//&1977 & "MPP ADD PROC: processor "//TRIM(fct_str(td_proc%i_pid))//& 1701 1978 & ", already in mpp structure " ) 1702 1979 1703 1980 ELSE 1704 1705 CALL logger_trace(" ADD PROC: add processor "//&1981 1982 CALL logger_trace("MPP ADD PROC: add processor "//& 1706 1983 & TRIM(fct_str(td_mpp%i_nproc+1))//" in mpp structure") 1707 1984 … … 1716 1993 IF(il_status /= 0 )THEN 1717 1994 1718 CALL logger_error( " ADD PROC: not enough space to put processor &1995 CALL logger_error( "MPP ADD PROC: not enough space to put processor & 1719 1996 & in mpp structure") 1720 1997 1721 1998 ELSE 1722 1999 ! save temporary mpp structure 1723 tl_proc(:)=td_mpp%t_proc(:) 1724 1725 DEALLOCATE( td_mpp%t_proc ) 2000 tl_proc(:)=file_copy(td_mpp%t_proc(:)) 2001 2002 CALL file_clean( td_mpp%t_proc(:) ) 2003 DEALLOCATE(td_mpp%t_proc) 1726 2004 ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc+1), stat=il_status) 1727 2005 IF(il_status /= 0 )THEN 1728 2006 1729 CALL logger_error( " ADD PROC: not enough space to put "//&2007 CALL logger_error( "MPP ADD PROC: not enough space to put "//& 1730 2008 & "processor in mpp structure ") 1731 2009 … … 1733 2011 1734 2012 ! copy processor in mpp before 1735 ! processor with l esser id than new processor1736 td_mpp%t_proc( 1:il_procid ) = tl_proc( 1:il_procid)2013 ! processor with lower id than new processor 2014 td_mpp%t_proc( 1:il_procid ) = file_copy(tl_proc( 1:il_procid )) 1737 2015 1738 2016 ! processor with greater id than new processor 1739 2017 td_mpp%t_proc( il_procid+1 : td_mpp%i_nproc+1 ) = & 1740 & tl_proc( il_procid : td_mpp%i_nproc ) 1741 2018 & file_copy(tl_proc( il_procid : td_mpp%i_nproc )) 2019 2020 ! clean 2021 CALL file_clean(tl_proc(:)) 1742 2022 DEALLOCATE(tl_proc) 1743 2023 ENDIF … … 1746 2026 ! no processor in mpp structure 1747 2027 IF( ASSOCIATED(td_mpp%t_proc) )THEN 2028 CALL file_clean(td_mpp%t_proc(:)) 1748 2029 DEALLOCATE(td_mpp%t_proc) 1749 2030 ENDIF … … 1751 2032 IF(il_status /= 0 )THEN 1752 2033 1753 CALL logger_error( " ADD PROC: not enough space to put "//&2034 CALL logger_error( "MPP ADD PROC: not enough space to put "//& 1754 2035 & "processor in mpp structure " ) 1755 2036 … … 1759 2040 ! check dimension 1760 2041 IF( ANY(td_mpp%t_dim(1:2)%i_len < td_proc%t_dim(1:2)%i_len) )THEN 1761 CALL logger_error( " ADD PROC: mpp structure and new processor "//&2042 CALL logger_error( "MPP ADD PROC: mpp structure and new processor "//& 1762 2043 & " dimension differ. ") 1763 CALL logger_debug(" ADD PROC: mpp dimension ("//&2044 CALL logger_debug("MPP ADD PROC: mpp dimension ("//& 1764 2045 & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//& 1765 2046 & TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")" ) 1766 CALL logger_debug(" ADD PROC: processor dimension ("//&2047 CALL logger_debug("MPP ADD PROC: processor dimension ("//& 1767 2048 & TRIM(fct_str(td_proc%t_dim(1)%i_len))//","//& 1768 2049 & TRIM(fct_str(td_proc%t_dim(2)%i_len))//")" ) … … 1771 2052 1772 2053 ! add new processor 1773 td_mpp%t_proc(td_mpp%i_nproc)= td_proc2054 td_mpp%t_proc(td_mpp%i_nproc)=file_copy(td_proc) 1774 2055 ENDIF 1775 2056 1776 2057 ENDIF 1777 2058 END SUBROUTINE mpp__add_proc 1778 !> @endcode1779 2059 !------------------------------------------------------------------- 1780 2060 !> @brief 1781 2061 !> This subroutine delete processor in mpp structure, given processor id. 1782 2062 !> 1783 !> @detail 1784 ! 1785 !> @author J.Paul 1786 !> @date Nov, 2013 1787 ! 1788 !> @param[inout] td_mpp : mpp strcuture 1789 !> @param[in] id_procid : processor id 1790 ! 1791 !> @todo check proc id exist 1792 !------------------------------------------------------------------- 1793 !> @code 2063 !> @author J.Paul 2064 !> @date November, 2013 - Initial version 2065 !> 2066 !> @param[inout] td_mpp mpp strcuture 2067 !> @param[in] id_procid processor id 2068 !------------------------------------------------------------------- 1794 2069 SUBROUTINE mpp__del_proc_id( td_mpp, id_procid ) 1795 2070 IMPLICIT NONE … … 1803 2078 INTEGER(i4), DIMENSION(1) :: il_ind 1804 2079 TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc 2080 2081 ! loop indices 1805 2082 !---------------------------------------------------------------- 1806 2083 … … 1808 2085 il_procid=il_ind(1) 1809 2086 IF( il_procid == 0 )THEN 1810 CALL logger_error("DEL PROC: no processor "//TRIM(fct_str(id_procid))//& 1811 & " associated to mpp structure") 2087 CALL logger_error("MPP DEL PROC: no processor "//& 2088 & TRIM(fct_str(id_procid))//& 2089 & " associated to mpp structure") 1812 2090 ELSE 1813 CALL logger_trace("DEL PROC: remove processor "//TRIM(fct_str(id_procid))) 2091 CALL logger_trace("DEL PROC: remove processor "//& 2092 & TRIM(fct_str(id_procid))) 1814 2093 1815 2094 IF( td_mpp%i_nproc > 1 )THEN 1816 2095 ALLOCATE( tl_proc(td_mpp%i_nproc-1), stat=il_status ) 1817 2096 IF(il_status /= 0 )THEN 1818 CALL logger_error( " DEL PROC: not enough space to put processor&1819 & 2097 CALL logger_error( "MPP DEL PROC: not enough space to put & 2098 & processor in temporary mpp structure") 1820 2099 1821 2100 ELSE … … 1823 2102 ! save temporary processor's mpp structure 1824 2103 IF( il_procid > 1 )THEN 1825 tl_proc(1:il_procid-1)= td_mpp%t_proc(1:il_procid-1)2104 tl_proc(1:il_procid-1)=file_copy(td_mpp%t_proc(1:il_procid-1)) 1826 2105 ENDIF 1827 tl_proc(il_procid:)=td_mpp%t_proc(il_procid+1:) 2106 2107 IF( il_procid < td_mpp%i_nproc )THEN 2108 tl_proc(il_procid:)=file_copy(td_mpp%t_proc(il_procid+1:)) 2109 ENDIF 1828 2110 1829 2111 ! new number of processor in mpp 1830 2112 td_mpp%i_nproc=td_mpp%i_nproc-1 1831 2113 1832 DEALLOCATE( td_mpp%t_proc ) 2114 CALL file_clean( td_mpp%t_proc(:) ) 2115 DEALLOCATE(td_mpp%t_proc) 1833 2116 ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc), stat=il_status ) 1834 2117 IF(il_status /= 0 )THEN 1835 2118 1836 CALL logger_error( " DEL PROC: not enough space to put processors&1837 & 2119 CALL logger_error( "MPP DEL PROC: not enough space & 2120 & to put processors in mpp structure " ) 1838 2121 1839 2122 ELSE 1840 2123 1841 2124 ! copy processor in mpp before 1842 td_mpp%t_proc(:)= tl_proc(:)2125 td_mpp%t_proc(:)=file_copy(tl_proc(:)) 1843 2126 1844 2127 ! update processor id … … 1848 2131 ENDIF 1849 2132 ENDIF 2133 ! clean 2134 CALL file_clean( tl_proc(:) ) 2135 DEALLOCATE(tl_proc) 1850 2136 ELSE 1851 DEALLOCATE( td_mpp%t_proc ) 2137 CALL file_clean( td_mpp%t_proc(:) ) 2138 DEALLOCATE(td_mpp%t_proc) 1852 2139 1853 2140 ! new number of processor in mpp … … 1856 2143 ENDIF 1857 2144 END SUBROUTINE mpp__del_proc_id 1858 !> @endcode1859 2145 !------------------------------------------------------------------- 1860 2146 !> @brief … … 1862 2148 !> structure. 1863 2149 !> 1864 !> @detail 1865 ! 1866 !> @author J.Paul 1867 !> @date Nov, 2013 2150 !> @author J.Paul 2151 !> @date November, 2013 - Initial version 1868 2152 ! 1869 2153 !> @param[inout] td_mpp : mpp strcuture 1870 2154 !> @param[in] td_proc : file/processor structure 1871 ! 1872 !> @todo check proc id exist 1873 !------------------------------------------------------------------- 1874 !> @code 2155 !------------------------------------------------------------------- 1875 2156 SUBROUTINE mpp__del_proc_str( td_mpp, td_proc ) 1876 2157 IMPLICIT NONE … … 1883 2164 CALL mpp__del_proc( td_mpp, td_proc%i_pid ) 1884 2165 ELSE 1885 CALL logger_error(" DEL PROC: processor not defined")2166 CALL logger_error("MPP DEL PROC: processor not defined") 1886 2167 ENDIF 1887 2168 1888 2169 END SUBROUTINE mpp__del_proc_str 1889 !> @endcode1890 2170 !------------------------------------------------------------------- 1891 2171 !> @brief … … 1895 2175 ! 1896 2176 !> @author J.Paul 1897 !> @date Nov, 2013 1898 ! 1899 !> @param[inout] td_mpp : mpp strcuture 1900 !> @param[in] id_procid : processor id 1901 !> @todo 1902 !> - voir si il ne faut pas redefinir (__copy) proc si il vient de mpp 1903 !> exemple CALL mpp_move_proc( td_mpp, td_mpp%t_proc ) 1904 !------------------------------------------------------------------- 1905 !> @code 2177 !> @date Nov, 2013 - Initial version 2178 ! 2179 !> @param[inout] td_mpp mpp strcuture 2180 !> @param[in] id_procid processor id 2181 !------------------------------------------------------------------- 1906 2182 SUBROUTINE mpp__move_proc( td_mpp, td_proc ) 1907 2183 IMPLICIT NONE … … 1918 2194 1919 2195 END SUBROUTINE mpp__move_proc 1920 !> @endcode1921 2196 !------------------------------------------------------------------- 1922 2197 !> @brief This subroutine add a dimension structure in a mpp 1923 2198 !> structure. 1924 2199 !> Do not overwrite, if dimension already in mpp structure. 1925 ! 1926 !> @details 1927 ! 1928 !> @author J.Paul 1929 !> - Nov, 2013- Initial Version 1930 ! 1931 !> @param[inout] td_mpp : mpp structure 1932 !> @param[in] td_dim : dimension structure 1933 ! 1934 !> @todo 1935 !------------------------------------------------------------------- 1936 ! @code 2200 !> 2201 !> @author J.Paul 2202 !> @date November, 2013 - Initial Version 2203 !> @date July, 2015 2204 !> - rewrite the same as way var_add_dim 2205 !> 2206 !> @param[inout] td_mpp mpp structure 2207 !> @param[in] td_dim dimension structure 2208 !------------------------------------------------------------------- 1937 2209 SUBROUTINE mpp_add_dim(td_mpp, td_dim) 1938 2210 IMPLICIT NONE … … 1942 2214 1943 2215 ! local variable 1944 INTEGER(i4) :: il_ dimid2216 INTEGER(i4) :: il_ind 1945 2217 1946 2218 ! loop indices 1947 2219 !---------------------------------------------------------------- 1948 IF( td_mpp%i_ndim <= 4 )THEN 1949 1950 ! check if dimension already in mpp structure 1951 il_dimid=dim_get_id(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname) 1952 IF( il_dimid /= 0 )THEN 1953 2220 IF( td_mpp%i_ndim <= ip_maxdim )THEN 2221 2222 ! check if dimension already used in mpp structure 2223 il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname)) 2224 IF( il_ind == 0 )THEN 2225 CALL logger_warn( & 2226 & " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//& 2227 & ", short name "//TRIM(td_dim%c_sname)//& 2228 & ", will not be added in mpp "//TRIM(td_mpp%c_name) ) 2229 ELSEIF( td_mpp%t_dim(il_ind)%l_use )THEN 1954 2230 CALL logger_error( & 1955 & " ADD DIM: dimension "//TRIM(td_dim%c_name)//&2231 & " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//& 1956 2232 & ", short name "//TRIM(td_dim%c_sname)//& 1957 & ", already in mpp "//TRIM(td_mpp%c_name) ) 1958 2233 & ", already used in mpp "//TRIM(td_mpp%c_name) ) 1959 2234 ELSE 1960 2235 1961 CALL logger_debug( & 1962 & " ADD DIM: add dimension "//TRIM(td_dim%c_name)//& 1963 & ", short name "//TRIM(td_dim%c_sname)//& 1964 & ", in mpp "//TRIM(td_mpp%c_name) ) 1965 1966 IF( td_mpp%i_ndim == 4 )THEN 1967 ! search empty dimension 1968 il_dimid=dim_get_void_id(td_mpp%t_dim(:),TRIM(td_dim%c_name), & 1969 & TRIM(td_dim%c_sname)) 1970 ! replace empty dimension 1971 td_mpp%t_dim(il_dimid)=td_dim 1972 td_mpp%t_dim(il_dimid)%i_id=il_dimid 1973 td_mpp%t_dim(il_dimid)%l_use=.TRUE. 1974 ELSE 1975 il_dimid=dim_get_void_id(td_mpp%t_dim(:),TRIM(td_dim%c_name), & 1976 & TRIM(td_dim%c_sname)) 1977 ! add new dimension 1978 td_mpp%t_dim(il_dimid)=td_dim 1979 td_mpp%t_dim(il_dimid)%i_id=td_mpp%i_ndim+1 1980 td_mpp%t_dim(il_dimid)%l_use=.TRUE. 1981 ! update number of attribute 1982 td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use) 1983 ENDIF 1984 1985 ! reorder dimension to ('x','y','z','t') 1986 CALL dim_reorder(td_mpp%t_dim) 2236 ! back to disorder dimension array 2237 CALL dim_disorder(td_mpp%t_dim(:)) 2238 2239 ! add new dimension 2240 td_mpp%t_dim(td_mpp%i_ndim+1)=dim_copy(td_dim) 2241 2242 ! update number of attribute 2243 td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use) 1987 2244 1988 2245 ENDIF 2246 ! reorder dimension to ('x','y','z','t') 2247 CALL dim_reorder(td_mpp%t_dim(:)) 1989 2248 1990 2249 ELSE 1991 2250 CALL logger_error( & 1992 & " ADD DIM: too much dimension in mpp "//&2251 & "MPP ADD DIM: too much dimension in mpp "//& 1993 2252 & TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")") 1994 2253 ENDIF 1995 2254 1996 2255 END SUBROUTINE mpp_add_dim 1997 ! @endcode1998 2256 !------------------------------------------------------------------- 1999 2257 !> @brief This subroutine delete a dimension structure in a mpp 2000 2258 !> structure.<br/> 2001 ! 2002 !> @details 2003 ! 2004 !> @author J.Paul 2005 !> - Nov, 2013- Initial Version 2006 ! 2007 !> @param[inout] td_mpp : mpp structure 2008 !> @param[in] td_dim : dimension structure 2009 ! 2010 !> @todo 2011 !------------------------------------------------------------------- 2012 ! @code 2259 !> 2260 !> @author J.Paul 2261 !> @date November, 2013 - Initial Version 2262 !> @date July, 2015 2263 !> - rewrite the same as way var_del_dim 2264 !> 2265 !> @param[inout] td_mpp mpp structure 2266 !> @param[in] td_dim dimension structure 2267 !------------------------------------------------------------------- 2013 2268 SUBROUTINE mpp_del_dim(td_mpp, td_dim) 2014 2269 IMPLICIT NONE … … 2018 2273 2019 2274 ! local variable 2020 INTEGER(i4) :: il_status 2021 INTEGER(i4) :: il_dimid 2022 TYPE(TDIM), DIMENSION(:), ALLOCATABLE :: tl_dim 2275 INTEGER(i4) :: il_ind 2276 TYPE(TDIM) :: tl_dim 2023 2277 2024 2278 ! loop indices 2025 2279 !---------------------------------------------------------------- 2026 IF( td_mpp%i_ndim <= 4 )THEN 2027 2028 ! check if dimension already in mpp structure 2029 il_dimid=dim_get_id(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname) 2030 IF( il_dimid == 0 )THEN 2031 2032 CALL logger_error( & 2033 & " DEL DIM: no dimension "//TRIM(td_dim%c_name)//& 2034 & ", short name "//TRIM(td_dim%c_sname)//& 2035 & ", in mpp "//TRIM(td_mpp%c_name) ) 2036 2037 ELSE 2038 2039 CALL logger_debug( & 2040 & " DEL DIM: delete dimension "//TRIM(td_dim%c_name)//& 2041 & ", short name "//TRIM(td_dim%c_sname)//& 2042 & ", in mpp "//TRIM(td_mpp%c_name) ) 2043 2044 IF( td_mpp%i_ndim == 4 )THEN 2045 ALLOCATE( tl_dim(1), stat=il_status ) 2046 IF(il_status /= 0 )THEN 2047 CALL logger_error( & 2048 & " DEL DIM: not enough space to put dimensions from "//& 2049 & TRIM(td_mpp%c_name)//" in temporary dimension structure") 2050 ELSE 2051 ! replace dimension by empty one 2052 td_mpp%t_dim(il_dimid)=tl_dim(1) 2053 ENDIF 2054 DEALLOCATE(tl_dim) 2055 ELSE 2056 ! 2057 ALLOCATE( tl_dim(td_mpp%i_ndim), stat=il_status ) 2058 IF(il_status /= 0 )THEN 2059 2060 CALL logger_error( & 2061 & " DEL DIM: not enough space to put dimensions from "//& 2062 & TRIM(td_mpp%c_name)//" in temporary dimension structure") 2063 2064 ELSE 2065 2066 ! save temporary dimension's mpp structure 2067 tl_dim( 1 : il_dimid-1 ) = td_mpp%t_dim( 1 : il_dimid-1 ) 2068 tl_dim( il_dimid : td_mpp%i_ndim-1 ) = & 2069 & td_mpp%t_dim( il_dimid+1 : td_mpp%i_ndim ) 2070 2071 ! copy dimension in file, except one 2072 td_mpp%t_dim(1:td_mpp%i_ndim)=tl_dim(:) 2073 2074 ! update number of dimension 2075 td_mpp%i_ndim=td_mpp%i_ndim-1 2076 2077 ENDIF 2078 ENDIF 2079 2080 ! reorder dimension to ('x','y','z','t') 2081 CALL dim_reorder(td_mpp%t_dim) 2082 2083 !IF( ASSOCIATED(td_mpp%t_proc) )THEN 2084 ! ! del dimension of processor 2085 ! DO ji=1,td_mpp%i_nproc 2086 ! CALL file_del_dim(td_mpp%t_proc(ji), td_dim) 2087 ! ENDDO 2088 !ENDIF 2089 2090 ENDIF 2280 2281 2282 IF( td_mpp%i_ndim <= ip_maxdim )THEN 2283 2284 CALL logger_trace( & 2285 & " MPP DEL DIM: delete dimension "//TRIM(td_dim%c_name)//& 2286 & ", short name "//TRIM(td_dim%c_sname)//& 2287 & ", in mpp "//TRIM(td_mpp%c_name) ) 2288 2289 ! check if dimension already in variable structure 2290 il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname)) 2291 2292 ! replace dimension by empty one 2293 td_mpp%t_dim(il_ind)=dim_copy(tl_dim) 2294 2295 ! update number of dimension 2296 td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use) 2297 2298 ! reorder dimension to ('x','y','z','t') 2299 CALL dim_reorder(td_mpp%t_dim) 2300 2091 2301 ELSE 2092 2302 CALL logger_error( & 2093 & " DEL DIM: too much dimension in mpp "//&2303 & " MPP DEL DIM: too much dimension in mpp "//& 2094 2304 & TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")") 2095 2305 ENDIF 2096 2306 2097 2307 END SUBROUTINE mpp_del_dim 2098 ! @endcode2099 2308 !------------------------------------------------------------------- 2100 2309 !> @brief This subroutine move a dimension structure 2101 2310 !> in mpp structure. 2102 2311 !> @warning dimension order may have changed 2103 ! 2104 !> @details 2105 ! 2106 !> @author J.Paul 2107 !> - Nov, 2013- Initial Version 2108 ! 2109 !> @param[inout] td_mpp : mpp structure 2110 !> @param[in] td_dim : dimension structure 2111 !> @todo 2112 !------------------------------------------------------------------- 2113 ! @code 2312 !> 2313 !> @author J.Paul 2314 !> @date November, 2013 - Initial Version 2315 !> 2316 !> @param[inout] td_mpp mpp structure 2317 !> @param[in] td_dim dimension structure 2318 !------------------------------------------------------------------- 2114 2319 SUBROUTINE mpp_move_dim(td_mpp, td_dim) 2115 2320 IMPLICIT NONE … … 2119 2324 2120 2325 ! local variable 2326 INTEGER(i4) :: il_ind 2121 2327 INTEGER(i4) :: il_dimid 2122 2123 !---------------------------------------------------------------- 2124 2125 il_dimid=dim_get_id(td_mpp%t_dim(:), TRIM(td_dim%c_name), & 2126 & TRIM(td_dim%c_sname)) 2127 IF( il_dimid /= 0 )THEN 2128 ! remove dimension with same name 2129 CALL mpp_del_dim(td_mpp, td_dim) 2130 ENDIF 2131 2132 ! add new dimension 2133 CALL mpp_add_dim(td_mpp, td_dim) 2134 2328 !---------------------------------------------------------------- 2329 IF( td_mpp%i_ndim <= ip_maxdim )THEN 2330 2331 ! check if dimension already in mpp structure 2332 il_ind=dim_get_index(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname) 2333 IF( il_ind /= 0 )THEN 2334 2335 il_dimid=td_mpp%t_dim(il_ind)%i_id 2336 ! replace dimension 2337 td_mpp%t_dim(il_ind)=dim_copy(td_dim) 2338 td_mpp%t_dim(il_ind)%i_id=il_dimid 2339 td_mpp%t_dim(il_ind)%l_use=.TRUE. 2340 2341 ELSE 2342 CALL mpp_add_dim(td_mpp, td_dim) 2343 ENDIF 2344 2345 ELSE 2346 CALL logger_error( & 2347 & "MPP MOVE DIM: too much dimension in mpp "//& 2348 & TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")") 2349 ENDIF 2135 2350 END SUBROUTINE mpp_move_dim 2136 ! @endcode2137 2351 !------------------------------------------------------------------- 2138 2352 !> @brief 2139 2353 !> This subroutine add global attribute to mpp structure. 2140 2354 !> 2141 !> @detail 2142 ! 2143 !> @author J.Paul 2144 !> @date Nov, 2013 2145 ! 2146 !> @param[inout] td_mpp : mpp strcuture 2147 !> @param[in] td_att : attribute strcuture 2148 ! 2149 !> @todo 2150 !------------------------------------------------------------------- 2151 !> @code 2355 !> @author J.Paul 2356 !> @date November, 2013 - Initial version 2357 !> 2358 !> @param[inout] td_mpp mpp strcuture 2359 !> @param[in] td_att attribute strcuture 2360 !------------------------------------------------------------------- 2152 2361 SUBROUTINE mpp_add_att( td_mpp, td_att ) 2153 2362 IMPLICIT NONE … … 2176 2385 il_attid=0 2177 2386 IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN 2178 il_attid=att_get_i d( td_mpp%t_proc(1)%t_att(:), &2387 il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), & 2179 2388 & td_att%c_name ) 2180 2389 ENDIF 2181 2390 IF( il_attid /= 0 )THEN 2182 2391 2183 CALL logger_error( " MPP ADD ATT: attribute "//TRIM(td_att%c_name)//& 2184 & ", already in mpp "//TRIM(td_mpp%c_name) ) 2392 CALL logger_error( " MPP ADD ATT: attribute "//& 2393 & TRIM(td_att%c_name)//& 2394 & ", already in mpp "//TRIM(td_mpp%c_name) ) 2185 2395 2186 2396 DO ji=1,td_mpp%t_proc(1)%i_natt … … 2192 2402 2193 2403 CALL logger_info( & 2194 & " MPP ADD VAR: add attribute "//TRIM(td_att%c_name)//&2404 & " MPP ADD ATT: add attribute "//TRIM(td_att%c_name)//& 2195 2405 & ", in mpp "//TRIM(td_mpp%c_name) ) 2196 2406 … … 2207 2417 2208 2418 END SUBROUTINE mpp_add_att 2209 !> @endcode2210 2419 !------------------------------------------------------------------- 2211 2420 !> @brief … … 2213 2422 !> structure. 2214 2423 !> 2215 !> @detail 2216 ! 2217 !> @author J.Paul 2218 !> @date Nov, 2013 2219 ! 2220 !> @param[inout] td_mpp : mpp strcuture 2221 !> @param[in] td_att : attribute strcuture 2222 ! 2223 !> @todo 2224 !> - check proc id exist 2225 !> - check proc dimension 2226 !> - check proc file name 2227 !> - check proc type 2228 !------------------------------------------------------------------- 2229 !> @code 2424 !> @author J.Paul 2425 !> @date November, 2013 - Initial version 2426 !> 2427 !> @param[inout] td_mpp mpp strcuture 2428 !> @param[in] td_att attribute strcuture 2429 !------------------------------------------------------------------- 2230 2430 SUBROUTINE mpp__del_att_str( td_mpp, td_att ) 2231 2431 IMPLICIT NONE … … 2244 2444 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN 2245 2445 2246 CALL logger_ error( "DEL VAR: domain decomposition not define "//&2446 CALL logger_warn( "MPP DEL VAR: domain decomposition not define "//& 2247 2447 & " in mpp strcuture "//TRIM(td_mpp%c_name)) 2248 2448 … … 2252 2452 il_attid=0 2253 2453 IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN 2254 il_attid=att_get_i d( td_mpp%t_proc(1)%t_att(:), &2454 il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), & 2255 2455 & td_att%c_name ) 2256 2456 ENDIF 2257 2457 IF( il_attid == 0 )THEN 2258 CALL logger_ error( &2259 & " DEL VAR: no attribute "//TRIM(td_att%c_name)//&2458 CALL logger_warn( & 2459 & "MPP DEL VAR: no attribute "//TRIM(td_att%c_name)//& 2260 2460 & ", in mpp structure "//TRIM(td_mpp%c_name) ) 2261 2461 2262 DO ji=1,td_mpp%t_proc(1)%i_natt 2263 CALL logger_debug( " DEL ATT: in mpp structure : & 2264 & attribute : "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name) ) 2265 ENDDO 2462 IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN 2463 DO ji=1,td_mpp%t_proc(1)%i_natt 2464 CALL logger_debug( "MPP DEL ATT: in mpp structure : & 2465 & attribute : "//TRIM(td_mpp%t_proc(1)%t_att(ji)%c_name) ) 2466 ENDDO 2467 ENDIF 2266 2468 2267 2469 ELSE 2268 2470 2269 2471 cl_name=TRIM(td_att%c_name) 2472 CALL logger_debug( "MPP DEL ATT: delete in mpp structure : & 2473 & attribute : "//TRIM(cl_name) ) 2270 2474 DO ji=1,td_mpp%i_nproc 2271 2475 CALL file_del_att(td_mpp%t_proc(ji), TRIM(cl_name)) … … 2276 2480 ENDIF 2277 2481 END SUBROUTINE mpp__del_att_str 2278 !> @endcode2279 2482 !------------------------------------------------------------------- 2280 2483 !> @brief … … 2284 2487 ! 2285 2488 !> @author J.Paul 2286 !> @date Nov, 2013 2287 ! 2288 !> @param[inout] td_mpp : mpp strcuture 2289 !> @param[in] cd_name: attribute name 2290 ! 2291 !> @todo 2292 !> - check proc id exist 2293 !> - check proc dimension 2294 !> - check proc file name 2295 !> - check proc type 2296 !------------------------------------------------------------------- 2297 !> @code 2489 !> @date November, 2013 - Initial version 2490 !> @date February, 2015 2491 !> - define local attribute structure to avoid mistake with pointer 2492 ! 2493 !> @param[inout] td_mpp mpp strcuture 2494 !> @param[in] cd_name attribute name 2495 !------------------------------------------------------------------- 2298 2496 SUBROUTINE mpp__del_att_name( td_mpp, cd_name ) 2299 2497 IMPLICIT NONE … … 2303 2501 2304 2502 ! local variable 2305 INTEGER(i4) :: il_attid 2503 INTEGER(i4) :: il_attid 2504 TYPE(TATT) :: tl_att 2306 2505 !---------------------------------------------------------------- 2307 2506 ! check if mpp exist 2308 2507 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN 2309 2508 2310 CALL logger_ error( "DEL ATT: domain decomposition not define "//&2509 CALL logger_warn( "MPP DEL ATT: domain decomposition not define "//& 2311 2510 & " in mpp strcuture "//TRIM(td_mpp%c_name)) 2312 2511 … … 2314 2513 2315 2514 IF( td_mpp%t_proc(1)%i_natt == 0 )THEN 2316 CALL logger_debug( " DEL ATT NAME: no attribute associated to mpp &2515 CALL logger_debug( "MPP DEL ATT NAME: no attribute associated to mpp & 2317 2516 & structure "//TRIM(td_mpp%c_name) ) 2318 2517 ELSE … … 2327 2526 IF( il_attid == 0 )THEN 2328 2527 2329 CALL logger_ warn( &2330 & " DEL ATT : there is no attribute with "//&2528 CALL logger_debug( & 2529 & "MPP DEL ATT : there is no attribute with "//& 2331 2530 & "name "//TRIM(cd_name)//" in mpp structure "//& 2332 2531 & TRIM(td_mpp%c_name)) … … 2334 2533 ELSE 2335 2534 2336 CALL mpp_del_att(td_mpp, td_mpp%t_proc(1)%t_att(il_attid)) 2535 tl_att=att_copy(td_mpp%t_proc(1)%t_att(il_attid)) 2536 CALL mpp_del_att(td_mpp, tl_att) 2337 2537 2338 2538 ENDIF … … 2341 2541 ENDIF 2342 2542 END SUBROUTINE mpp__del_att_name 2343 !> @endcode2344 2543 !------------------------------------------------------------------- 2345 2544 !> @brief 2346 2545 !> This subroutine overwrite attribute in mpp structure. 2347 2546 !> 2348 !> @detail 2349 ! 2350 !> @author J.Paul 2351 !> @date Nov, 2013 2352 ! 2353 !> @param[inout] td_mpp : mpp strcuture 2354 !> @param[in] td_att : attribute structure 2355 !> @todo 2356 !------------------------------------------------------------------- 2357 !> @code 2547 !> @author J.Paul 2548 !> @date November, 2013 - Initial version 2549 ! 2550 !> @param[inout] td_mpp mpp strcuture 2551 !> @param[in] td_att attribute structure 2552 !------------------------------------------------------------------- 2358 2553 SUBROUTINE mpp_move_att( td_mpp, td_att ) 2359 2554 IMPLICIT NONE … … 2363 2558 2364 2559 !local variable 2365 TYPE(TATT) :: tl_att2560 TYPE(TATT) :: tl_att 2366 2561 !---------------------------------------------------------------- 2367 2562 ! copy variable 2368 tl_att= td_att2563 tl_att=att_copy(td_att) 2369 2564 2370 2565 ! remove processor … … 2374 2569 CALL mpp_add_att(td_mpp, tl_att) 2375 2570 2571 ! clean 2572 CALL att_clean(tl_att) 2573 2376 2574 END SUBROUTINE mpp_move_att 2377 !> @endcode2378 2575 !------------------------------------------------------------------- 2379 2576 !> @brief … … 2388 2585 ! 2389 2586 !> @author J.Paul 2390 !> @date Nov, 2013 2391 ! 2392 !> @param[inout] td_mpp : mpp strcuture 2393 !------------------------------------------------------------------- 2394 !> @code 2587 !> @date November, 2013 - Initial version 2588 ! 2589 !> @param[inout] td_mpp mpp strcuture 2590 !------------------------------------------------------------------- 2395 2591 SUBROUTINE mpp__compute( td_mpp ) 2396 2592 IMPLICIT NONE … … 2410 2606 CHARACTER(LEN=lc) :: cl_file 2411 2607 TYPE(TFILE) :: tl_proc 2412 TYPE(TATT) :: tl_att2608 TYPE(TATT) :: tl_att 2413 2609 2414 2610 ! loop indices … … 2421 2617 td_mpp%i_nproc=0 2422 2618 2423 CALL logger_trace( " COMPUTE: compute domain decomposition with "//&2619 CALL logger_trace( "MPP COMPUTE: compute domain decomposition with "//& 2424 2620 & TRIM(fct_str(td_mpp%i_niproc))//" x "//& 2425 2621 & TRIM(fct_str(td_mpp%i_njproc))//" processors") … … 2498 2694 & (/tl_proc%i_lci, tl_proc%i_lcj/) ) 2499 2695 CALL file_add_att(tl_proc, tl_att) 2500 2501 2696 2502 2697 ! compute first and last indoor indices … … 2544 2739 CALL mpp__add_proc(td_mpp, tl_proc) 2545 2740 2741 ! clean 2742 CALL att_clean(tl_att) 2743 CALL file_clean(tl_proc) 2744 2546 2745 ENDDO 2547 2746 ENDDO … … 2551 2750 2552 2751 END SUBROUTINE mpp__compute 2553 !> @endcode2554 2752 !------------------------------------------------------------------- 2555 2753 !> @brief 2556 2754 !> This subroutine remove land processor from domain decomposition. 2557 ! 2558 !> @author J.Paul 2559 !> @date Nov, 2013 2560 ! 2561 !> @param[inout] td_mpp : mpp strcuture 2562 !> @param[in] id_mask : sub domain mask (sea=1, land=0) 2563 !------------------------------------------------------------------- 2564 !> @code 2755 !> 2756 !> @author J.Paul 2757 !> @date November, 2013 - Initial version 2758 !> 2759 !> @param[inout] td_mpp mpp strcuture 2760 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2761 !------------------------------------------------------------------- 2565 2762 SUBROUTINE mpp__del_land( td_mpp, id_mask ) 2566 2763 IMPLICIT NONE … … 2583 2780 ENDDO 2584 2781 ELSE 2585 CALL logger_error(" DEL LAND: domain decomposition not define.")2782 CALL logger_error("MPP DEL LAND: domain decomposition not define.") 2586 2783 ENDIF 2587 2784 2588 2785 END SUBROUTINE mpp__del_land 2589 !> @endcode2590 2786 !------------------------------------------------------------------- 2591 2787 !> @brief … … 2596 2792 ! 2597 2793 !> @author J.Paul 2598 !> @date Nov , 20132599 ! 2600 !> @param[inout] td_mpp :mpp strcuture2601 ! -------------------------------------------------------------------2602 ! > @code2794 !> @date November, 2013 - Initial version 2795 ! 2796 !> @param[inout] td_mpp mpp strcuture 2797 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2798 !------------------------------------------------------------------- 2603 2799 SUBROUTINE mpp__optimiz( td_mpp, id_mask ) 2604 2800 IMPLICIT NONE … … 2617 2813 !---------------------------------------------------------------- 2618 2814 2619 CALL logger_trace(" OPTIMIZ: look for best domain decomposition")2620 tl_mpp= td_mpp2815 CALL logger_trace("MPP OPTIMIZ: look for best domain decomposition") 2816 tl_mpp=mpp_copy(td_mpp) 2621 2817 2622 2818 ! save maximum number of processor to be used … … 2629 2825 ! clean mpp processor 2630 2826 IF( ASSOCIATED(tl_mpp%t_proc) )THEN 2827 CALL file_clean(tl_mpp%t_proc(:)) 2631 2828 DEALLOCATE(tl_mpp%t_proc) 2632 2829 ENDIF … … 2641 2838 CALL mpp__del_land( tl_mpp, id_mask ) 2642 2839 2643 CALL logger_info("OPTIMIZ: number of processor "//& 2644 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2840 CALL logger_info("MPP OPTIMIZ: number of processor "//& 2841 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 2842 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2645 2843 IF( tl_mpp%i_nproc > td_mpp%i_nproc .AND. & 2646 2844 & tl_mpp%i_nproc <= il_maxproc )THEN 2647 2845 ! save optimiz decomposition 2648 2846 2847 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 2848 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 2849 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2850 2649 2851 ! clean mpp 2650 2852 CALL mpp_clean(td_mpp) 2651 2853 2652 ! save processor table2854 ! save processor array 2653 2855 ALLOCATE( tl_proc(tl_mpp%i_nproc) ) 2654 tl_proc(:)=tl_mpp%t_proc(:) 2655 2656 ! remove pointer on processor table 2856 tl_proc(:)=file_copy(tl_mpp%t_proc(:)) 2857 2858 ! remove pointer on processor array 2859 CALL file_clean(tl_mpp%t_proc(:)) 2657 2860 DEALLOCATE(tl_mpp%t_proc) 2658 2861 2659 ! save data except processor table 2660 td_mpp=tl_mpp 2661 ! save processor table 2862 ! save data except processor array 2863 td_mpp=mpp_copy(tl_mpp) 2864 2865 ! save processor array 2662 2866 ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc) ) 2663 td_mpp%t_proc(:)=tl_proc(:) 2664 2665 DEALLOCATE( tl_proc ) 2867 td_mpp%t_proc(:)=file_copy(tl_proc(:)) 2868 2869 ! clean 2870 CALL file_clean( tl_proc(:) ) 2871 DEALLOCATE(tl_proc) 2666 2872 2667 2873 ENDIF … … 2670 2876 ENDDO 2671 2877 2878 ! clean 2879 CALL mpp_clean(tl_mpp) 2880 2672 2881 END SUBROUTINE mpp__optimiz 2673 !> @endcode2674 2882 !------------------------------------------------------------------- 2675 2883 !> @brief 2676 2884 !> This function check if processor is a land processor. 2677 ! 2678 !> @author J.Paul 2679 !> @date Nov, 2013 2680 ! 2681 !> @param[in] td_mpp : mpp strcuture 2682 !> @param[in] id_proc : processor id 2683 !> @param[in] id_mask : sub domain mask (sea=1, land=0) 2684 !------------------------------------------------------------------- 2685 !> @code 2885 !> 2886 !> @author J.Paul 2887 !> @date November, 2013 - Initial version 2888 !> 2889 !> @param[in] td_mpp mpp strcuture 2890 !> @param[in] id_proc processor id 2891 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2892 !------------------------------------------------------------------- 2686 2893 LOGICAL FUNCTION mpp__land_proc( td_mpp , id_proc, id_mask ) 2687 2894 IMPLICIT NONE … … 2695 2902 !---------------------------------------------------------------- 2696 2903 2697 CALL logger_trace(" LAND PROC: check processor "//TRIM(fct_str(id_proc))//&2904 CALL logger_trace("MPP LAND PROC: check processor "//TRIM(fct_str(id_proc))//& 2698 2905 & " of mpp "//TRIM(td_mpp%c_name) ) 2699 2906 mpp__land_proc=.FALSE. … … 2703 2910 IF( il_shape(1) /= td_mpp%t_dim(1)%i_len .OR. & 2704 2911 & il_shape(2) /= td_mpp%t_dim(2)%i_len )THEN 2705 CALL logger_error("LAND PROC: mask and domain size differ") 2912 CALL logger_debug("MPP LAND PROC: mask size ("//& 2913 & TRIM(fct_str(il_shape(1)))//","//& 2914 & TRIM(fct_str(il_shape(2)))//")") 2915 CALL logger_debug("MPP LAND PROC: domain size ("//& 2916 & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//& 2917 & TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")") 2918 CALL logger_error("MPP LAND PROC: mask and domain size differ") 2706 2919 ELSE 2707 2920 IF( ALL(id_mask( td_mpp%t_proc(id_proc)%i_impp + & … … 2715 2928 & /= 1 ) )THEN 2716 2929 ! land domain 2717 CALL logger_info(" LAND PROC: processor "//TRIM(fct_str(id_proc))//&2930 CALL logger_info("MPP LAND PROC: processor "//TRIM(fct_str(id_proc))//& 2718 2931 & " is land processor") 2719 2932 mpp__land_proc=.TRUE. … … 2722 2935 2723 2936 ELSE 2724 CALL logger_error(" LAND PROC: domain decomposition not define.")2937 CALL logger_error("MPP LAND PROC: domain decomposition not define.") 2725 2938 ENDIF 2726 2939 2727 2940 END FUNCTION mpp__land_proc 2728 !> @endcode2729 2941 !------------------------------------------------------------------- 2730 2942 !> @brief 2731 2943 !> This subroutine clean mpp strcuture. 2732 ! 2733 !> @author J.Paul 2734 !> @date Nov, 2013 2735 ! 2736 !> @param[inout] td_mpp : mpp strcuture 2737 !------------------------------------------------------------------- 2738 !> @code 2739 SUBROUTINE mpp_clean( td_mpp ) 2944 !> 2945 !> @author J.Paul 2946 !> @date November, 2013 - Initial version 2947 !> 2948 !> @param[inout] td_mpp mpp strcuture 2949 !------------------------------------------------------------------- 2950 SUBROUTINE mpp__clean_unit( td_mpp ) 2740 2951 IMPLICIT NONE 2741 2952 ! Argument … … 2746 2957 2747 2958 ! loop indices 2748 INTEGER(i4) :: ji2749 2959 !---------------------------------------------------------------- 2750 2960 2751 2961 CALL logger_info( & 2752 & " CLEAN: reset mpp "//TRIM(td_mpp%c_name) )2962 & "MPP CLEAN: reset mpp "//TRIM(td_mpp%c_name) ) 2753 2963 2754 2964 ! del dimension 2755 2965 IF( td_mpp%i_ndim /= 0 )THEN 2756 DO ji=td_mpp%i_ndim,1,-1 2757 CALL dim_clean( td_mpp%t_dim(ji) ) 2758 ENDDO 2966 CALL dim_clean( td_mpp%t_dim(:) ) 2759 2967 ENDIF 2760 2968 2761 2969 IF( ASSOCIATED(td_mpp%t_proc) )THEN 2762 ! clean each proc 2763 DO ji=1,td_mpp%i_nproc 2764 CALL file_clean( td_mpp%t_proc(ji) ) 2765 ENDDO 2970 ! clean array of file processor 2971 CALL file_clean( td_mpp%t_proc(:) ) 2766 2972 DEALLOCATE(td_mpp%t_proc) 2767 2973 ENDIF 2768 2974 2769 2975 ! replace by empty structure 2770 td_mpp=tl_mpp 2771 2772 END SUBROUTINE mpp_clean 2773 !> @endcode 2976 td_mpp=mpp_copy(tl_mpp) 2977 2978 END SUBROUTINE mpp__clean_unit 2979 !------------------------------------------------------------------- 2980 !> @brief 2981 !> This subroutine clean mpp strcuture. 2982 !> 2983 !> @author J.Paul 2984 !> @date November, 2013 - Initial version 2985 !> 2986 !> @param[inout] td_mpp mpp strcuture 2987 !------------------------------------------------------------------- 2988 SUBROUTINE mpp__clean_arr( td_mpp ) 2989 IMPLICIT NONE 2990 ! Argument 2991 TYPE(TMPP), DIMENSION(:), INTENT(INOUT) :: td_mpp 2992 2993 ! local variable 2994 ! loop indices 2995 INTEGER(i4) :: ji 2996 !---------------------------------------------------------------- 2997 2998 DO ji=SIZE(td_mpp(:)),1,-1 2999 CALL mpp_clean(td_mpp(ji)) 3000 ENDDO 3001 3002 END SUBROUTINE mpp__clean_arr 2774 3003 !------------------------------------------------------------------- 2775 3004 !> @brief 2776 3005 !> This subroutine get sub domains which cover "zoom domain". 2777 ! 2778 !> @author J.Paul 2779 !> @date Nov, 2013 2780 ! 2781 !> @param[inout] td_mpp : mpp strcuture 2782 !> @param[in] td_dom : domain strcuture 2783 !------------------------------------------------------------------- 2784 !> @code 2785 SUBROUTINE mpp_get_use( td_mpp, td_dom ) 3006 !> 3007 !> @author J.Paul 3008 !> @date November, 2013 - Initial version 3009 !> 3010 !> @param[inout] td_mpp mpp strcuture 3011 !> @param[in] id_imin i-direction lower indice 3012 !> @param[in] id_imax i-direction upper indice 3013 !> @param[in] id_jmin j-direction lower indice 3014 !> @param[in] id_jmax j-direction upper indice 3015 !------------------------------------------------------------------- 3016 SUBROUTINE mpp__get_use_unit( td_mpp, id_imin, id_imax, & 3017 & id_jmin, id_jmax ) 2786 3018 IMPLICIT NONE 2787 3019 ! Argument 2788 TYPE(TMPP), INTENT(INOUT) :: td_mpp 2789 TYPE(TDOM), INTENT(IN) :: td_dom 3020 TYPE(TMPP) , INTENT(INOUT) :: td_mpp 3021 INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin 3022 INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax 3023 INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin 3024 INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax 2790 3025 2791 3026 ! local variable 2792 INTEGER(i4) :: il_jmin2793 3027 LOGICAL :: ll_iuse 2794 3028 LOGICAL :: ll_juse 2795 3029 3030 INTEGER(i4) :: il_imin 3031 INTEGER(i4) :: il_imax 3032 INTEGER(i4) :: il_jmin 3033 INTEGER(i4) :: il_jmax 3034 2796 3035 ! loop indices 2797 3036 INTEGER(i4) :: jk … … 2799 3038 IF( ASSOCIATED(td_mpp%t_proc) )THEN 2800 3039 3040 il_imin=1 3041 il_imax=td_mpp%t_dim(1)%i_len 3042 IF( PRESENT(id_imin) ) il_imin=id_imin 3043 IF( PRESENT(id_imax) ) il_imax=id_imax 3044 il_jmin=1 3045 il_jmax=td_mpp%t_dim(2)%i_len 3046 IF( PRESENT(id_jmin) ) il_jmin=id_jmin 3047 IF( PRESENT(id_jmax) ) il_jmax=id_jmax 3048 2801 3049 ! check domain 2802 IF( td_mpp%t_dim(1)%i_len == td_dom%t_dim0(1)%i_len .AND. & 2803 & td_mpp%t_dim(2)%i_len == td_dom%t_dim0(2)%i_len )THEN 2804 3050 IF( il_imin < 1 .OR. il_imin > td_mpp%t_dim(1)%i_len .OR. & 3051 & il_imax < 1 .OR. il_imax > td_mpp%t_dim(1)%i_len .OR. & 3052 & il_jmin < 1 .OR. il_jmin > td_mpp%t_dim(2)%i_len .OR. & 3053 & il_jmax < 1 .OR. il_jmax > td_mpp%t_dim(2)%i_len )THEN 3054 CALL logger_debug("MPP GET USE: mpp gloabl size "//& 3055 & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//& 3056 & TRIM(fct_str(td_mpp%t_dim(2)%i_len))) 3057 CALL logger_debug("MPP GET USE: i-indices "//& 3058 & TRIM(fct_str(il_imin))//","//TRIM(fct_str(il_imax))) 3059 CALL logger_debug("MPP GET USE: j-indices "//& 3060 & TRIM(fct_str(il_jmin))//","//TRIM(fct_str(il_jmax))) 3061 CALL logger_error("MPP GET USE: invalid indices ") 3062 ELSE 2805 3063 td_mpp%t_proc(:)%l_use=.FALSE. 2806 3064 DO jk=1,td_mpp%i_nproc … … 2808 3066 ! check i-direction 2809 3067 ll_iuse=.FALSE. 2810 IF( td_dom%i_imin < td_dom%i_imax )THEN3068 IF( il_imin < il_imax )THEN 2811 3069 2812 3070 ! not overlap east west boundary 2813 3071 IF( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > & 2814 & td_dom%i_imin .AND. &2815 & td_mpp%t_proc(jk)%i_impp < td_dom%i_imax )THEN3072 & il_imin .AND. & 3073 & td_mpp%t_proc(jk)%i_impp < il_imax )THEN 2816 3074 ll_iuse=.TRUE. 2817 3075 ENDIF 2818 3076 2819 ELSEIF( td_dom%i_imin == td_dom%i_imax )THEN3077 ELSEIF( il_imin == il_imax )THEN 2820 3078 2821 3079 ! east west cyclic 2822 3080 ll_iuse=.TRUE. 2823 3081 2824 ELSE ! td_dom%i_imin > td_dom%i_imax3082 ELSE ! il_imin > id_imax 2825 3083 2826 3084 ! overlap east west boundary 2827 3085 IF( ( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > & 2828 & td_dom%i_imin .AND. & 2829 & td_mpp%t_proc(jk)%i_impp < td_dom%t_dim0(1)%i_len ) & 3086 & il_imin ) & 2830 3087 & .OR. & 2831 & ( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > & 2832 & 1 .AND. & 2833 & td_mpp%t_proc(jk)%i_impp < td_dom%i_imax) )THEN 3088 & ( td_mpp%t_proc(jk)%i_impp < il_imax) )THEN 2834 3089 ll_iuse=.TRUE. 2835 3090 ENDIF … … 2839 3094 ! check j-direction 2840 3095 ll_juse=.FALSE. 2841 IF( td_dom%i_jmin < td_dom%i_jmax )THEN3096 IF( il_jmin < il_jmax )THEN 2842 3097 2843 3098 ! not overlap north fold 2844 3099 IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > & 2845 & td_dom%i_jmin .AND. &2846 & td_mpp%t_proc(jk)%i_jmpp < td_dom%i_jmax )THEN3100 & il_jmin .AND. & 3101 & td_mpp%t_proc(jk)%i_jmpp < il_jmax )THEN 2847 3102 ll_juse=.TRUE. 2848 3103 ENDIF 2849 3104 2850 ELSE ! td_dom%i_jmin >= td_dom%i_jmax 2851 2852 il_jmin=MIN(td_dom%i_jmin,td_dom%i_jmax) 3105 ELSE ! id_jmin >= id_jmax 3106 2853 3107 IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > & 2854 3108 & il_jmin )THEN … … 2861 3115 2862 3116 ENDDO 2863 ELSE2864 CALL logger_error("GET USE: domain differ")2865 3117 ENDIF 2866 3118 2867 3119 ELSE 2868 CALL logger_error("GET USE: domain decomposition not define.") 2869 ENDIF 2870 2871 END SUBROUTINE mpp_get_use 2872 !> @endcode 3120 CALL logger_error("MPP GET USE: mpp decomposition not define.") 3121 ENDIF 3122 3123 END SUBROUTINE mpp__get_use_unit 2873 3124 !------------------------------------------------------------------- 2874 3125 !> @brief 2875 3126 !> This subroutine get sub domains which form global domain border. 2876 ! 2877 !> @author J.Paul 2878 !> @date Nov, 2013 2879 ! 2880 !> @param[inout] td_mpp : mpp strcuture 2881 !------------------------------------------------------------------- 2882 !> @code 3127 !> 3128 !> @author J.Paul 3129 !> @date November, 2013 - Initial version 3130 !> 3131 !> @param[inout] td_mpp mpp strcuture 3132 !------------------------------------------------------------------- 2883 3133 SUBROUTINE mpp_get_contour( td_mpp ) 2884 3134 IMPLICIT NONE … … 2892 3142 IF( ASSOCIATED(td_mpp%t_proc) )THEN 2893 3143 2894 td_mpp%t_proc(:)%l_ ctr= .FALSE.3144 td_mpp%t_proc(:)%l_use = .FALSE. 2895 3145 DO jk=1,td_mpp%i_nproc 2896 3146 IF( td_mpp%t_proc(jk)%i_ldi == 1 .OR. & … … 2899 3149 & td_mpp%t_proc(jk)%i_lej == td_mpp%t_proc(jk)%i_lcj )THEN 2900 3150 2901 td_mpp%t_proc(jk)%l_ ctr= .TRUE.2902 3151 td_mpp%t_proc(jk)%l_use = .TRUE. 3152 2903 3153 ENDIF 2904 3154 ENDDO 2905 3155 2906 3156 ELSE 2907 CALL logger_error(" GET CONTOUR: domain decomposition not define.")3157 CALL logger_error("MPP GET CONTOUR: domain decomposition not define.") 2908 3158 ENDIF 2909 3159 2910 3160 END SUBROUTINE mpp_get_contour 2911 !> @endcode2912 3161 !------------------------------------------------------------------- 2913 3162 !> @brief 2914 3163 !> This function return processor indices, without overlap boundary, 2915 !> given processor id. This depends of domain decompisition type. 2916 ! 2917 !> @author J.Paul 2918 !> @date Nov, 2013 2919 ! 2920 !> @param[in] td_mpp : mpp strcuture 2921 !> @param[in] id_procid : processor id 2922 !> @return table of index (/ i1, i2, j1, j2 /) 2923 !------------------------------------------------------------------- 2924 !> @code 3164 !> given processor id. 3165 !> 3166 !> @author J.Paul 3167 !> @date November, 2013 - Initial version 3168 !> 3169 !> @param[in] td_mpp mpp strcuture 3170 !> @param[in] id_procid processor id 3171 !> @return array of index (/ i1, i2, j1, j2 /) 3172 !------------------------------------------------------------------- 2925 3173 FUNCTION mpp_get_proc_index( td_mpp, id_procid ) 2926 3174 IMPLICIT NONE 2927 3175 2928 3176 ! Argument 2929 TYPE(TMPP) ,INTENT(IN) :: td_mpp3177 TYPE(TMPP) , INTENT(IN) :: td_mpp 2930 3178 INTEGER(i4), INTENT(IN) :: id_procid 2931 3179 … … 2936 3184 INTEGER(i4) :: il_i1, il_i2 2937 3185 INTEGER(i4) :: il_j1, il_j2 2938 TYPE(TMPP) :: tl_mpp2939 3186 !---------------------------------------------------------------- 2940 3187 2941 3188 IF( ASSOCIATED(td_mpp%t_proc) )THEN 2942 3189 2943 tl_mpp=td_mpp2944 !IF( TRIM(td_mpp%c_dom) == "unknown" )THEN2945 3190 IF( TRIM(td_mpp%c_dom) == '' )THEN 2946 CALL logger_warn("GET PROC INDEX: decomposition type unknown. "//& 2947 & "look for it") 2948 CALL mpp_get_dom( tl_mpp ) 3191 CALL logger_fatal("MPP GET PROC INDEX: decomposition type unknown. "//& 3192 & "you should ahve run mpp_get_dom before.") 2949 3193 ENDIF 2950 3194 2951 SELECT CASE(TRIM(t l_mpp%c_dom))3195 SELECT CASE(TRIM(td_mpp%c_dom)) 2952 3196 CASE('full') 2953 3197 il_i1 = 1 ; il_i2 = td_mpp%t_dim(1)%i_len … … 2957 3201 il_j1 = td_mpp%t_proc(id_procid)%i_jmpp 2958 3202 2959 il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1 ! attention lei dans ioRestartDimg3203 il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1 2960 3204 il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1 2961 3205 CASE('nooverlap') … … 2970 3214 & td_mpp%t_proc(id_procid)%i_lej - 1 2971 3215 CASE DEFAULT 2972 CALL logger_error(" GET PROC INDEX: invalid decomposition type.")3216 CALL logger_error("MPP GET PROC INDEX: invalid decomposition type.") 2973 3217 END SELECT 2974 3218 … … 2976 3220 2977 3221 ELSE 2978 CALL logger_error(" GET PROC INDEX: domain decomposition not define.")3222 CALL logger_error("MPP GET PROC INDEX: domain decomposition not define.") 2979 3223 ENDIF 2980 3224 2981 3225 END FUNCTION mpp_get_proc_index 2982 !> @endcode2983 3226 !------------------------------------------------------------------- 2984 3227 !> @brief … … 2987 3230 ! 2988 3231 !> @author J.Paul 2989 !> @date Nov, 2013 2990 ! 2991 !> @param[in] td_mpp : mpp strcuture 2992 !> @param[in] id_procid : sub domain id 2993 !> @return table of index (/ isize, jsize /) 2994 !------------------------------------------------------------------- 2995 !> @code 3232 !> @date November, 2013 - Initial version 3233 ! 3234 !> @param[in] td_mpp mpp strcuture 3235 !> @param[in] id_procid sub domain id 3236 !> @return array of index (/ isize, jsize /) 3237 !------------------------------------------------------------------- 2996 3238 FUNCTION mpp_get_proc_size( td_mpp, id_procid ) 2997 3239 IMPLICIT NONE … … 3007 3249 INTEGER(i4) :: il_isize 3008 3250 INTEGER(i4) :: il_jsize 3009 TYPE(TMPP) :: tl_mpp3010 3251 !---------------------------------------------------------------- 3011 3252 3012 3253 IF( ASSOCIATED(td_mpp%t_proc) )THEN 3013 3254 3014 tl_mpp=td_mpp3015 !IF( TRIM(td_mpp%c_dom) == "unknown" )THEN3016 3255 IF( TRIM(td_mpp%c_dom) == '' )THEN 3017 CALL logger_warn("GET PROC SIZE: decomposition type unknown. "//& 3018 & "look for it") 3019 CALL mpp_get_dom( tl_mpp ) 3256 CALL logger_fatal("MPP GET PROC SIZE: decomposition type unknown. "//& 3257 & "you should ahve run mpp_get_dom before.") 3020 3258 ENDIF 3021 3259 3022 SELECT CASE(TRIM(t l_mpp%c_dom))3260 SELECT CASE(TRIM(td_mpp%c_dom)) 3023 3261 CASE('full') 3024 3262 … … 3037 3275 & td_mpp%t_proc(id_procid)%i_ldj + 1 3038 3276 CASE DEFAULT 3039 CALL logger_error(" GET PROC SIZE: invalid decomposition type : "//&3040 & TRIM(t l_mpp%c_dom) )3277 CALL logger_error("MPP GET PROC SIZE: invalid decomposition type : "//& 3278 & TRIM(td_mpp%c_dom) ) 3041 3279 END SELECT 3042 3280 … … 3044 3282 3045 3283 ELSE 3046 CALL logger_error(" GET PROC SIZE: domain decomposition not define.")3284 CALL logger_error("MPP GET PROC SIZE: domain decomposition not define.") 3047 3285 ENDIF 3048 3286 3049 3287 END FUNCTION mpp_get_proc_size 3050 !> @endcode3051 3288 !------------------------------------------------------------------- 3052 3289 !> @brief 3053 3290 !> This subroutine determine domain decomposition type. 3054 3291 !> (full, overlap, noverlap) 3055 ! 3056 !> @author J.Paul 3057 !> @date Nov, 2013 3058 ! 3059 !> @param[inout] td_mpp : mpp strcuture 3060 !> @todo 3061 !> - change name, confusing with domain.f90 3062 !------------------------------------------------------------------- 3063 !> @code 3292 !> 3293 !> @author J.Paul 3294 !> @date November, 2013 - Initial version 3295 !> 3296 !> @param[inout] td_mpp mpp strcuture 3297 !------------------------------------------------------------------- 3064 3298 SUBROUTINE mpp_get_dom( td_mpp ) 3065 3299 IMPLICIT NONE … … 3075 3309 3076 3310 IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_niproc == 0 )THEN 3077 CALL logger_info(" GET DOM: use indoor indices to get domain "//&3311 CALL logger_info("MPP GET DOM: use indoor indices to get domain "//& 3078 3312 & "decomposition type.") 3079 3313 IF((td_mpp%t_proc(1)%t_dim(1)%i_len == & … … 3100 3334 ELSE 3101 3335 3102 CALL logger_error(" GET DOM: should have been an impossible case")3336 CALL logger_error("MPP GET DOM: should have been an impossible case") 3103 3337 3104 3338 il_isize=td_mpp%t_proc(1)%t_dim(1)%i_len 3105 3339 il_jsize=td_mpp%t_proc(1)%t_dim(2)%i_len 3106 CALL logger_debug(" GET DOM: proc size "//&3340 CALL logger_debug("MPP GET DOM: proc size "//& 3107 3341 & TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) ) 3108 3342 3109 3343 il_isize=td_mpp%t_proc(1)%i_lei - td_mpp%t_proc(1)%i_ldi + 1 3110 3344 il_jsize=td_mpp%t_proc(1)%i_lej - td_mpp%t_proc(1)%i_ldj + 1 3111 CALL logger_debug(" GET DOM: no overlap size "//&3345 CALL logger_debug("MPP GET DOM: no overlap size "//& 3112 3346 & TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) ) 3113 3347 3114 3348 il_isize=td_mpp%t_proc(1)%i_lci 3115 3349 il_jsize=td_mpp%t_proc(1)%i_lcj 3116 CALL logger_debug(" GET DOM: overlap size "//&3350 CALL logger_debug("MPP GET DOM: overlap size "//& 3117 3351 & TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) ) 3118 3352 3119 3353 il_isize=td_mpp%t_dim(1)%i_len 3120 3354 il_jsize=td_mpp%t_dim(2)%i_len 3121 CALL logger_debug(" GET DOM: full size "//&3355 CALL logger_debug("MPP GET DOM: full size "//& 3122 3356 & TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) ) 3123 3357 … … 3126 3360 ELSE 3127 3361 3128 CALL logger_info(" GET DOM: use number of processors following "//&3362 CALL logger_info("MPP GET DOM: use number of processors following "//& 3129 3363 & "I and J to get domain decomposition type.") 3130 3364 IF( td_mpp%i_niproc*td_mpp%i_njproc==td_mpp%i_nproc )THEN … … 3140 3374 3141 3375 ELSE 3142 CALL logger_error(" GET DOM: domain decomposition not define.")3376 CALL logger_error("MPP GET DOM: domain decomposition not define.") 3143 3377 ENDIF 3144 3378 3145 3379 END SUBROUTINE mpp_get_dom 3146 !> @endcode3147 3380 !------------------------------------------------------------------- 3148 3381 !> @brief This function check if variable and mpp structure use same 3149 3382 !> dimension. 3150 ! 3383 !> 3151 3384 !> @details 3152 ! 3153 !> @author J.Paul 3154 !> - Nov, 2013- Initial Version3155 ! 3156 !> @param[in] td_mpp :mpp structure3157 !> @param[in] td_var :variable structure3385 !> 3386 !> @author J.Paul 3387 !> @date November, 2013 - Initial Version 3388 !> 3389 !> @param[in] td_mpp mpp structure 3390 !> @param[in] td_var variable structure 3158 3391 !> @return dimension of variable and mpp structure agree (or not) 3159 3392 !------------------------------------------------------------------- 3160 ! @code3161 3393 LOGICAL FUNCTION mpp__check_var_dim(td_mpp, td_var) 3162 3394 IMPLICIT NONE … … 3166 3398 3167 3399 ! local variable 3168 INTEGER(i4) :: il_ndim3169 3400 3170 3401 ! loop indices … … 3178 3409 mpp__check_var_dim=.FALSE. 3179 3410 3180 CALL logger_error( &3181 & " CHECK DIM: variable and mpp dimension differ"//&3182 & " for variable "//TRIM(td_var%c_name)//&3183 & " and mpp "//TRIM(td_mpp%c_name))3184 3185 3411 CALL logger_debug( & 3186 3412 & " mpp dimension: "//TRIM(fct_str(td_mpp%i_ndim))//& 3187 3413 & " variable dimension: "//TRIM(fct_str(td_var%i_ndim)) ) 3188 il_ndim=MIN(td_var%i_ndim, td_mpp%i_ndim ) 3189 DO ji = 1, il_ndim 3414 DO ji = 1, ip_maxdim 3190 3415 CALL logger_debug( & 3191 & " CHECK DIM: for dimension "//&3416 & "MPP CHECK DIM: for dimension "//& 3192 3417 & TRIM(td_mpp%t_dim(ji)%c_name)//& 3193 3418 & ", mpp length: "//& … … 3197 3422 & ", variable used "//TRIM(fct_str(td_var%t_dim(ji)%l_use))) 3198 3423 ENDDO 3424 3425 CALL logger_error( & 3426 & "MPP CHECK DIM: variable and mpp dimension differ"//& 3427 & " for variable "//TRIM(td_var%c_name)//& 3428 & " and mpp "//TRIM(td_mpp%c_name)) 3429 3199 3430 ENDIF 3200 3431 3201 3432 END FUNCTION mpp__check_var_dim 3202 ! @endcode 3433 !------------------------------------------------------------------- 3434 !> @brief This function return the mpp id, in a array of mpp 3435 !> structure, given mpp base name. 3436 ! 3437 !> @author J.Paul 3438 !> @date November, 2013 - Initial Version 3439 ! 3440 !> @param[in] td_file array of file structure 3441 !> @param[in] cd_name file name 3442 !> @return file id in array of file structure (0 if not found) 3443 !------------------------------------------------------------------- 3444 INTEGER(i4) FUNCTION mpp_get_index(td_mpp, cd_name) 3445 IMPLICIT NONE 3446 ! Argument 3447 TYPE(TMPP) , DIMENSION(:), INTENT(IN) :: td_mpp 3448 CHARACTER(LEN=*), INTENT(IN) :: cd_name 3449 3450 ! local variable 3451 CHARACTER(LEN=lc) :: cl_name 3452 INTEGER(i4) :: il_size 3453 3454 ! loop indices 3455 INTEGER(i4) :: ji 3456 !---------------------------------------------------------------- 3457 mpp_get_index=0 3458 il_size=SIZE(td_mpp(:)) 3459 3460 cl_name=TRIM( file_rename(cd_name) ) 3461 3462 ! check if mpp is in array of mpp structure 3463 DO ji=1,il_size 3464 ! look for file name 3465 IF( TRIM(fct_lower(td_mpp(ji)%c_name)) == TRIM(fct_lower(cd_name)) )THEN 3466 3467 mpp_get_index=ji 3468 EXIT 3469 3470 ENDIF 3471 ENDDO 3472 3473 END FUNCTION mpp_get_index 3474 !------------------------------------------------------------------- 3475 !> @brief This function recombine variable splitted mpp structure. 3476 ! 3477 !> @author J.Paul 3478 !> @date Ocotber, 2014 - Initial Version 3479 ! 3480 !> @param[in] td_mpp mpp file structure 3481 !> @param[in] cd_name variable name 3482 !> @return variable strucutre 3483 !------------------------------------------------------------------- 3484 TYPE(TVAR) FUNCTION mpp_recombine_var(td_mpp, cd_name) 3485 IMPLICIT NONE 3486 ! Argument 3487 TYPE(TMPP) , INTENT(IN) :: td_mpp 3488 CHARACTER(LEN=*), INTENT(IN) :: cd_name 3489 3490 ! local variable 3491 INTEGER(i4) :: il_varid 3492 INTEGER(i4) :: il_status 3493 INTEGER(i4) :: il_i1p 3494 INTEGER(i4) :: il_i2p 3495 INTEGER(i4) :: il_j1p 3496 INTEGER(i4) :: il_j2p 3497 INTEGER(i4), DIMENSION(4) :: il_ind 3498 3499 INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt 3500 INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt 3501 3502 TYPE(TVAR) :: tl_tmp 3503 TYPE(TVAR) :: tl_var 3504 3505 ! loop indices 3506 INTEGER(i4) :: ji 3507 INTEGER(i4) :: jk 3508 !---------------------------------------------------------------- 3509 3510 il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name) 3511 IF( il_varid /= 0 )THEN 3512 3513 tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid)) 3514 ! Allocate space to hold variable value in structure 3515 IF( ASSOCIATED(tl_var%d_value) )THEN 3516 DEALLOCATE(tl_var%d_value) 3517 ENDIF 3518 ! 3519 DO ji=1,ip_maxdim 3520 IF( tl_var%t_dim(ji)%l_use )THEN 3521 tl_var%t_dim(ji)%i_len=td_mpp%t_dim(ji)%i_len 3522 ENDIF 3523 ENDDO 3524 3525 ALLOCATE(tl_var%d_value( tl_var%t_dim(1)%i_len, & 3526 & tl_var%t_dim(2)%i_len, & 3527 & tl_var%t_dim(3)%i_len, & 3528 & tl_var%t_dim(4)%i_len),& 3529 & stat=il_status) 3530 IF(il_status /= 0 )THEN 3531 3532 CALL logger_error( & 3533 & " MPP RECOMBINE VAR: not enough space to put variable "//& 3534 & TRIM(tl_var%c_name)//" in variable structure") 3535 3536 ENDIF 3537 3538 ! FillValue by default 3539 tl_var%d_value(:,:,:,:)=tl_var%d_fill 3540 3541 ! read processor 3542 DO jk=1,td_mpp%i_nproc 3543 IF( td_mpp%t_proc(jk)%l_use )THEN 3544 ! get processor indices 3545 il_ind(:)=mpp_get_proc_index( td_mpp, jk ) 3546 il_i1p = il_ind(1) 3547 il_i2p = il_ind(2) 3548 il_j1p = il_ind(3) 3549 il_j2p = il_ind(4) 3550 3551 il_strt(:)=(/ 1,1,1,1 /) 3552 3553 il_cnt(:)=(/ il_i2p-il_i1p+1, & 3554 & il_j2p-il_j1p+1, & 3555 & tl_var%t_dim(3)%i_len, & 3556 & tl_var%t_dim(4)%i_len /) 3557 3558 tl_tmp=iom_read_var( td_mpp%t_proc(jk), tl_var%c_name,& 3559 & il_strt(:), il_cnt(:) ) 3560 3561 ! replace value in output variable structure 3562 tl_var%d_value( il_i1p : il_i2p, & 3563 & il_j1p : il_j2p, & 3564 & :,:) = tl_tmp%d_value(:,:,:,:) 3565 3566 ! clean 3567 CALL var_clean(tl_tmp) 3568 3569 ENDIF 3570 ENDDO 3571 3572 mpp_recombine_var=var_copy(tl_var) 3573 3574 ! clean 3575 CALL var_clean(tl_var) 3576 3577 ELSE 3578 3579 CALL logger_error( & 3580 & " MPP RECOMBINE VAR: there is no variable with "//& 3581 & "name or standard name"//TRIM(cd_name)//& 3582 & " in mpp file "//TRIM(td_mpp%c_name)) 3583 ENDIF 3584 END FUNCTION mpp_recombine_var 3203 3585 END MODULE mpp 3204 3586
Note: See TracChangeset
for help on using the changeset viewer.
