- Timestamp:
- 2015-04-29T12:17:12+02:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5021_nn_etau_revision/NEMOGCM/TOOLS/SIREN/src/iom_mpp.f90
r4213 r5240 6 6 ! 7 7 ! DESCRIPTION: 8 !> @brief massively parallel processing Input/Output manager :9 !> Library to read/write mpp files <br/>8 !> @brief This module manage massively parallel processing Input/Output manager. 9 !> Library to read/write mpp files. 10 10 !> 11 11 !> @details 12 !>13 12 !> to open mpp files (only file to be used (see mpp_get_use) 14 13 !> will be open):<br/> 14 !> @code 15 15 !> CALL iom_mpp_open(td_mpp) 16 !> @endcode 16 17 !> - td_mpp is a mpp structure 17 18 !> 18 19 !> to creates mpp files:<br/> 20 !> @code 19 21 !> CALL iom_mpp_create(td_mpp) 22 !> @endcode 20 23 !> - td_mpp is a mpp structure 21 24 !> 22 25 !> to write in mpp files :<br/> 26 !> @code 23 27 !> CALL iom_mpp_write_file(td_mpp) 28 !> @endcode 24 29 !> - td_mpp is a mpp structure 25 30 !> 26 31 !> to close mpp files:<br/> 32 !> @code 27 33 !> CALL iom_mpp_close(td_mpp) 34 !> @endcode 28 35 !> 29 36 !> to read one variable in an mpp files:<br/> 30 !> - tl_var=iom_mpp_read_var( td_mpp, id_varid, [td_dom,] [ld_border] ) 31 !> - tl_var=iom_mpp_read_var( td_mpp, [cd_name,] [td_dom,] [ld_border,] [cd_stdname] ) 37 !> @code 38 !> tl_var=iom_mpp_read_var( td_mpp, id_varid, [id_start, id_count] [,id_ew] ) 39 !> @endcode 40 !> or 41 !> @code 42 !> tl_var=iom_mpp_read_var( td_mpp, cd_name, [id_start, id_count] [,id_ew] ) 43 !> @endcode 32 44 !> - td_mpp is a mpp structure 33 45 !> - id_varid is a variable id 34 !> - td_dom is a domain structure (optional, can't be used with ld_border) 35 !> - ld_border is true if we want to read border of global domain only 36 !> (optional, can't be used with td_dom) 37 !> - cd_name is variable name (optional, cd_name and/or cd_stdname should be specify.) 38 !> - cd_stdname is variable standard name (optional, cd_name and/or cd_stdname should be specify.) 39 !> 46 !> - cd_name is variable name or standard name 47 !> - id_start is a integer(4) 1D array of index from which the data 48 !> values will be read [optional] 49 !> - id_count is a integer(4) 1D array of the number of indices selected 50 !> along each dimension [optional] 51 !> - id_ew East West overlap [optional] 52 !> 53 !> to fill variable value in mpp structure:<br/> 54 !> @code 55 !> CALL iom_mpp_fill_var(td_mpp, id_varid, [id_start, id_count] [,id_ew] ) 56 !> @endcode 57 !> or<br/> 58 !> @code 59 !> CALL iom_mpp_fill_var(td_mpp, cd_name, [id_start, id_count] [,id_ew] ) 60 !> @endcode 61 !> - td_mpp is mpp structure 62 !> - id_varid is variable id 63 !> - cd_name is variable name or standard name 64 !> - id_start is a integer(4) 1D array of index from which the data 65 !> values will be read [optional] 66 !> - id_count is a integer(4) 1D array of the number of indices selected 67 !> along each dimension [optional] 68 !> - id_ew East West overlap [optional] 69 !> 70 !> to fill all variable in mpp structure:<br/> 71 !> @code 72 !> CALL iom_mpp_fill_var(td_mpp, [id_start, id_count] [,id_ew] ) 73 !> @endcode 74 !> - td_mpp is mpp structure 75 !> - id_start is a integer(4) 1D array of index from which the data 76 !> values will be read [optional] 77 !> - id_count is a integer(4) 1D array of the number of indices selected 78 !> along each dimension [optional] 79 !> - id_ew East West overlap 80 !> 81 !> to write files composong mpp strucutre:<br/> 82 !> @code 83 !> CALL iom_mpp_write_file(td_mpp) 84 !> @endcode 40 85 !> 41 86 !> @author … … 43 88 ! REVISION HISTORY: 44 89 !> @date Nov, 2013 - Initial Version 45 ! 90 !> 46 91 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 47 !> @todo48 !> - add read var with start and count as in iom49 !> - add iom_mpp_fill_var_value : cf iom_fill_var_value50 !> - not so easy to use that it should be, have to work on it51 !> - improve mpp init52 !> - improve mpp_get_use53 !> - imporve dom_init54 92 !---------------------------------------------------------------------- 55 93 MODULE iom_mpp 56 94 USE netcdf ! nf90 library 95 USE global ! global parameter 57 96 USE kind ! F90 kind parameter 58 97 USE fct ! basic useful function 59 USE logger 98 USE logger ! log file manager 60 99 USE dim ! dimension manager 61 100 USE att ! attribute manager … … 64 103 USE iom ! I/O manager 65 104 USE mpp ! mpp manager 66 USE dom ! domain manager67 105 IMPLICIT NONE 68 PRIVATE69 106 ! NOTE_avoid_public_variables_if_possible 70 107 71 108 ! function and subroutine 72 PUBLIC :: iom_mpp_open !< open files composing mpp structure to be used73 PUBLIC :: iom_mpp_create !< creates files composing mpp structure to be used109 PUBLIC :: iom_mpp_open !< open all files composing mpp structure 110 PUBLIC :: iom_mpp_create !< creates files composing mpp structure 74 111 PUBLIC :: iom_mpp_close !< close file composing mpp structure 75 112 PUBLIC :: iom_mpp_read_var !< read one variable in an mpp structure 76 PUBLIC :: iom_mpp_fill_var !< fill variable value in mpp structure77 113 PUBLIC :: iom_mpp_write_file !< write mpp structure in files 78 114 79 PRIVATE :: iom_mpp__read_var_id !< read one variable in an mpp structure, given variable id 80 PRIVATE :: iom_mpp__read_var_name !< read one variable in an mpp structure, given variable name 81 PRIVATE :: iom_mpp__read_var_value !< read variable value in an mpp structure 82 PRIVATE :: iom_mpp__no_pole_no_overlap !< do not overlap north fold boundary or east-west boundary 83 PRIVATE :: iom_mpp__no_pole_cyclic !< do not overlap north fold boundary. However uses cyclic east-west boundary 84 PRIVATE :: iom_mpp__no_pole_overlap !< do not overlap north fold boundary. However overlaps east-west boundary 85 ! PRIVATE :: iom_mpp__pole_no_overlap !< overlaps north fold boundary. However do not overlap east-west boundary 86 ! PRIVATE :: iom_mpp__pole_cyclic !< overlaps north fold boundary and uses cyclic east-west boundary 87 ! PRIVATE :: iom_mpp__pole_overlap !< overlaps north fold boundary and east-west boundary 88 89 INTERFACE iom_mpp_read_var !< read one variable in an mpp structure 90 MODULE PROCEDURE iom_mpp__read_var_id !< given variable id 91 MODULE PROCEDURE iom_mpp__read_var_name !< given variable name 115 PRIVATE :: iom_mpp__read_var_id ! read one variable in an mpp structure, given variable id 116 PRIVATE :: iom_mpp__read_var_name ! read one variable in an mpp structure, given variable name 117 PRIVATE :: iom_mpp__read_var_value ! read variable value in an mpp structure 118 119 INTERFACE iom_mpp_read_var ! read one variable in an mpp structure 120 MODULE PROCEDURE iom_mpp__read_var_id ! given variable id 121 MODULE PROCEDURE iom_mpp__read_var_name ! given variable name 92 122 END INTERFACE iom_mpp_read_var 93 123 94 INTERFACE iom_mpp_fill_var !< fill variable value in an mpp structure95 MODULE PROCEDURE iom_mpp__fill_var_id !< given variable id96 MODULE PROCEDURE iom_mpp__fill_var_name !< given variable name97 MODULE PROCEDURE iom_mpp__fill_var_all !< fill all variable98 END INTERFACE iom_mpp_fill_var99 100 124 CONTAINS 101 125 !------------------------------------------------------------------- 102 !> @brief This subroutine open files composing mpp structure to be used<br/> 126 !> @brief This subroutine open files composing mpp structure to be used. 127 !> @details 103 128 !> If try to open a file in write mode that did not exist, create it.<br/> 104 129 !> … … 112 137 !> 113 138 !> @author J.Paul 114 !> - Nov, 2013- Initial Version 115 ! 116 !> @param[inout] td_mpp : mpp structure 117 !------------------------------------------------------------------- 118 !> @code 119 SUBROUTINE iom_mpp_open(td_mpp) 139 !> - November, 2013- Initial Version 140 ! 141 !> @param[inout] td_mpp mpp structure 142 !------------------------------------------------------------------- 143 SUBROUTINE iom_mpp_open(td_mpp, id_perio, id_ew) 120 144 IMPLICIT NONE 121 145 ! Argument 122 TYPE(TMPP), INTENT(INOUT) :: td_mpp 146 TYPE(TMPP) , INTENT(INOUT) :: td_mpp 147 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 148 INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew 123 149 124 150 ! local variable … … 135 161 136 162 ELSE 137 IF( ANY(td_mpp%t_proc(:)%l_use) )THEN 138 139 ! add suffix to mpp name 140 td_mpp%c_name=file_add_suffix( TRIM(td_mpp%c_name), & 141 & TRIM(td_mpp%c_type) ) 142 143 td_mpp%t_proc(:)%c_type=TRIM(td_mpp%c_type) 144 IF( td_mpp%i_nproc > 1 )THEN 145 DO ji=1,td_mpp%i_nproc 146 IF( td_mpp%t_proc(ji)%l_use )THEN 147 163 ! if no processor file selected 164 ! force to open all files 165 IF( .NOT. ANY( td_mpp%t_proc(:)%l_use ) )THEN 166 td_mpp%t_proc(:)%l_use=.TRUE. 167 ENDIF 168 169 ! add suffix to mpp name 170 td_mpp%c_name=file_add_suffix( TRIM(td_mpp%c_name), & 171 & TRIM(td_mpp%c_type) ) 172 173 td_mpp%t_proc(:)%c_type=TRIM(td_mpp%c_type) 174 IF( td_mpp%i_nproc > 1 )THEN 175 DO ji=1,td_mpp%i_nproc 176 IF( td_mpp%t_proc(ji)%l_use )THEN 177 178 SELECT CASE(TRIM(td_mpp%c_type)) 179 CASE('cdf') 180 cl_name=TRIM( file_rename(td_mpp%c_name, ji-1) ) 181 CASE('dimg') 148 182 cl_name=TRIM( file_rename(td_mpp%c_name, ji) ) 149 td_mpp%t_proc(ji)%c_name=TRIM(cl_name) 150 151 CALL iom_open(td_mpp%t_proc(ji)) 152 153 ENDIF 154 ENDDO 155 ELSE ! td_mpp%i_nproc == 1 156 cl_name=TRIM( file_rename(td_mpp%c_name) ) 157 td_mpp%t_proc(1)%c_name=TRIM(cl_name) 158 159 CALL iom_open(td_mpp%t_proc(1)) 160 ENDIF 161 162 ELSE 163 164 IF( ANY(td_mpp%t_proc(:)%l_ctr) )THEN 165 166 CALL logger_warn("IOM MPP OPEN: open file on border") 167 DO ji=1,td_mpp%i_nproc 168 IF( td_mpp%t_proc(ji)%l_ctr )THEN 169 CALL iom_open(td_mpp%t_proc(ji)) 170 ENDIF 171 ENDDO 172 173 ELSE 174 CALL logger_error( " IOM MPP OPEN: no processor to be used.") 175 CALL logger_debug( " use mpp_get_use before running iom_mpp_open") 176 ENDIF 177 ENDIF 183 CASE DEFAULT 184 CALL logger_fatal("IOM MPP OPEN: can not open file "//& 185 & "of type "//TRIM(td_mpp%c_type)) 186 END SELECT 187 188 td_mpp%t_proc(ji)%c_name=TRIM(cl_name) 189 190 CALL iom_open(td_mpp%t_proc(ji)) 191 192 ENDIF 193 ENDDO 194 ELSE ! td_mpp%i_nproc == 1 195 cl_name=TRIM( file_rename(td_mpp%c_name) ) 196 td_mpp%t_proc(1)%c_name=TRIM(cl_name) 197 198 CALL iom_open(td_mpp%t_proc(1)) 199 ENDIF 200 201 IF( PRESENT(id_ew) )THEN 202 td_mpp%i_ew=id_ew 203 ! add east west overlap to each variable 204 DO ji=1,td_mpp%i_nproc 205 WHERE(td_mpp%t_proc(ji)%t_var(:)%t_dim(1)%l_use) 206 td_mpp%t_proc(ji)%t_var(:)%i_ew=td_mpp%i_ew 207 ENDWHERE 208 ENDDO 209 ENDIF 210 211 IF( PRESENT(id_perio) )THEN 212 td_mpp%i_perio=id_perio 213 ENDIF 214 178 215 ENDIF 179 216 180 217 END SUBROUTINE iom_mpp_open 181 !> @endcode182 218 !------------------------------------------------------------------- 183 219 !> @brief This subroutine create files, composing mpp structure to be used, 184 !> in write mode <br/>220 !> in write mode. 185 221 !> 186 222 !> @author J.Paul 187 !> - Nov, 2013- Initial Version 188 ! 189 !> @param[inout] td_mpp : mpp structure 190 !------------------------------------------------------------------- 191 !> @code 223 !> - November, 2013- Initial Version 224 ! 225 !> @param[inout] td_mpp mpp structure 226 !------------------------------------------------------------------- 192 227 SUBROUTINE iom_mpp_create(td_mpp) 193 228 IMPLICIT NONE … … 209 244 210 245 END SUBROUTINE iom_mpp_create 211 !> @endcode212 246 !------------------------------------------------------------------- 213 247 !> @brief This subroutine close files composing mpp structure. 214 248 !> 215 249 !> @author J.Paul 216 !> - Nov, 2013- Initial Version 217 ! 218 !> @param[in] td_mpp : mpp structure 219 !------------------------------------------------------------------- 220 !> @code 250 !> - November, 2013- Initial Version 251 ! 252 !> @param[in] td_mpp mpp structure 253 !------------------------------------------------------------------- 221 254 SUBROUTINE iom_mpp_close(td_mpp) 222 255 IMPLICIT NONE … … 239 272 ENDIF 240 273 ENDDO 274 td_mpp%t_proc(:)%l_use=.FALSE. 241 275 ENDIF 242 276 243 277 END SUBROUTINE iom_mpp_close 244 !> @endcode245 278 !------------------------------------------------------------------- 246 279 !> @brief This function read variable value in opened mpp files, 247 !> given variable id. </br/>280 !> given variable id. 248 281 !> 249 282 !> @details 250 !> If domain is given, read only domain. 251 !> If border is .TRUE., read only border processor 252 !> 253 ! 283 !> Optionally start indices and number of point to be read could be specify. 284 !> as well as East West ovelap of the global domain. 285 !> 254 286 !> @author J.Paul 255 !> - Nov, 2013- Initial Version 256 ! 257 !> @param[in] td_mpp : mpp structure 258 !> @param[in] id_varid : variable id 259 !> @param[in] td_dom : domain structure 260 !> @param[in] ld_border : read only border 287 !> - November, 2013- Initial Version 288 !> @date October, 2014 289 !> - use start and count array instead of domain structure. 290 !> 291 !> @param[in] td_mpp mpp structure 292 !> @param[in] id_varid variable id 293 !> @param[in] id_start index in the variable from which the data values 294 !> will be read 295 !> @param[in] id_count number of indices selected along each dimension 261 296 !> @return variable structure 262 297 !------------------------------------------------------------------- 263 !> @code264 298 TYPE(TVAR) FUNCTION iom_mpp__read_var_id(td_mpp, id_varid,& 265 & td_dom, ld_border)299 & id_start, id_count) 266 300 IMPLICIT NONE 267 301 ! Argument 268 TYPE(TMPP), INTENT(IN) :: td_mpp269 INTEGER(i4), INTENT(IN) :: id_varid270 TYPE(TDOM) , INTENT(IN), OPTIONAL :: td_dom271 LOGICAL, INTENT(IN), OPTIONAL :: ld_border302 TYPE(TMPP), INTENT(IN) :: td_mpp 303 INTEGER(i4), INTENT(IN) :: id_varid 304 INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start 305 INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count 272 306 273 307 ! local variable … … 288 322 IF( il_ind(1) /= 0 )THEN 289 323 290 iom_mpp__read_var_id= td_mpp%t_proc(1)%t_var(il_ind(1))324 iom_mpp__read_var_id=var_copy(td_mpp%t_proc(1)%t_var(il_ind(1))) 291 325 292 326 !!! read variable value 293 327 CALL iom_mpp__read_var_value(td_mpp, iom_mpp__read_var_id, & 294 & td_dom, ld_border)328 & id_start, id_count) 295 329 296 330 ELSE … … 308 342 309 343 END FUNCTION iom_mpp__read_var_id 310 !> @endcode311 344 !------------------------------------------------------------------- 312 345 !> @brief This function read variable value in opened mpp files, 313 !> given variable name or standard name.</br/> 346 !> given variable name or standard name. 347 !> 314 348 !> @details 315 !> If domain is given, read only domain. 316 !> If border is .TRUE., read only border processor 317 ! 318 !> @details 349 !> Optionally start indices and number of point to be read could be specify. 350 !> as well as East West ovelap of the global domain. 351 !> 319 352 !> look first for variable name. If it doesn't 320 353 !> exist in file, look for variable standard name.<br/> … … 322 355 ! 323 356 !> @author J.Paul 324 !> - Nov, 2013- Initial Version 325 ! 326 !> @param[in] td_mpp : mpp structure 327 !> @param[in] cd_name : variable name 328 !> @param[in] td_dom : domain structure 329 !> @param[in] ld_border : read only border 357 !> - November, 2013- Initial Version 358 !> @date October, 2014 359 !> - use start and count array instead of domain structure. 360 ! 361 !> @param[in] td_mpp mpp structure 362 !> @param[in] cd_name variable name 363 !> @param[in] id_start index in the variable from which the data values 364 !> will be read 365 !> @param[in] id_count number of indices selected along each dimension 330 366 !> @return variable structure 331 367 !------------------------------------------------------------------- 332 !> @code333 368 TYPE(TVAR) FUNCTION iom_mpp__read_var_name(td_mpp, cd_name, & 334 & td_dom, ld_border)369 & id_start, id_count ) 335 370 IMPLICIT NONE 336 371 ! Argument 337 TYPE(TMPP), INTENT(IN) :: td_mpp338 CHARACTER(LEN=*), INTENT(IN) :: cd_name339 TYPE(TDOM) , INTENT(IN), OPTIONAL :: td_dom340 LOGICAL, INTENT(IN), OPTIONAL :: ld_border372 TYPE(TMPP), INTENT(IN) :: td_mpp 373 CHARACTER(LEN=*), INTENT(IN) :: cd_name 374 INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start 375 INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count 341 376 342 377 ! local variable 343 INTEGER(i4) :: il_ varid378 INTEGER(i4) :: il_ind 344 379 !---------------------------------------------------------------- 345 380 ! check if mpp exist … … 351 386 ELSE 352 387 353 il_ varid=var_get_id( td_mpp%t_proc(1)%t_var(:), cd_name)354 IF( il_ varid /= 0 )THEN355 356 iom_mpp__read_var_name= td_mpp%t_proc(1)%t_var(il_varid)388 il_ind=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name) 389 IF( il_ind /= 0 )THEN 390 391 iom_mpp__read_var_name=var_copy(td_mpp%t_proc(1)%t_var(il_ind)) 357 392 358 393 !!! read variable value 359 394 CALL iom_mpp__read_var_value( td_mpp, & 360 395 & iom_mpp__read_var_name, & 361 & td_dom, ld_border)396 & id_start, id_count) 362 397 363 398 ELSE … … 372 407 373 408 END FUNCTION iom_mpp__read_var_name 374 !> @endcode375 !-------------------------------------------------------------------376 !> @brief This subroutine fill all variable value in opened mpp files,377 !> given variable id.</br/>378 !>379 !> @details380 !> If domain is given, read only domain.381 !> If border is .TRUE., read only border processor382 !>383 !384 !> @author J.Paul385 !> - Nov, 2013- Initial Version386 !387 !> @param[inout] td_mpp : mpp structure388 !> @param[in] td_dom : domain structure389 !> @param[in] ld_border : read only border390 !-------------------------------------------------------------------391 !> @code392 SUBROUTINE iom_mpp__fill_var_all(td_mpp, td_dom, ld_border)393 IMPLICIT NONE394 ! Argument395 TYPE(TMPP), INTENT(INOUT) :: td_mpp396 TYPE(TDOM) , INTENT(IN), OPTIONAL :: td_dom397 LOGICAL, INTENT(IN), OPTIONAL :: ld_border398 399 ! local variable400 401 ! loop indices402 INTEGER(i4) :: ji403 !----------------------------------------------------------------404 ! check if mpp exist405 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN406 407 CALL logger_error( " IOM MPP FILL VAR : domain decomposition not define "//&408 & " in mpp strcuture "//TRIM(td_mpp%c_name))409 410 ELSE411 412 DO ji=1,td_mpp%t_proc(1)%i_nvar413 CALL iom_mpp_fill_var(td_mpp, ji, td_dom, ld_border )414 ENDDO415 416 ENDIF417 418 END SUBROUTINE iom_mpp__fill_var_all419 !> @endcode420 !-------------------------------------------------------------------421 !> @brief This subroutine fill variable value in opened mpp files,422 !> given variable id.</br/>423 !>424 !> @details425 !> If domain is given, read only domain.426 !> If border is .TRUE., read only border processor427 !>428 !429 !> @author J.Paul430 !> - Nov, 2013- Initial Version431 !432 !> @param[inout] td_mpp : mpp structure433 !> @param[in] id_varid : variable id434 !> @param[in] td_dom : domain structure435 !> @param[in] ld_border : read only border436 !-------------------------------------------------------------------437 !> @code438 SUBROUTINE iom_mpp__fill_var_id(td_mpp, id_varid, td_dom, ld_border)439 IMPLICIT NONE440 ! Argument441 TYPE(TMPP), INTENT(INOUT) :: td_mpp442 INTEGER(i4), INTENT(IN) :: id_varid443 TYPE(TDOM) , INTENT(IN), OPTIONAL :: td_dom444 LOGICAL, INTENT(IN), OPTIONAL :: ld_border445 446 ! local variable447 INTEGER(i4), DIMENSION(1) :: il_ind448 !----------------------------------------------------------------449 ! check if mpp exist450 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN451 452 CALL logger_error( " IOM MPP FILL VAR: domain decomposition not define "//&453 & " in mpp strcuture "//TRIM(td_mpp%c_name))454 455 ELSE456 457 IF( ANY(td_mpp%t_proc(:)%i_id /= 0) )THEN458 ! look for variable id459 il_ind(:)=MINLOC( td_mpp%t_proc(1)%t_var(:)%i_id, &460 & mask=(td_mpp%t_proc(1)%t_var(:)%i_id==id_varid))461 IF( il_ind(1) /= 0 )THEN462 463 !!! read variable value464 CALL iom_mpp__read_var_value( td_mpp, &465 & td_mpp%t_proc(1)%t_var(il_ind(1)), &466 & td_dom, ld_border)467 468 ELSE469 CALL logger_error( &470 & " IOM MPP FILL VAR : there is no variable with id "//&471 & TRIM(fct_str(id_varid))//" in processor/file "//&472 & TRIM(td_mpp%t_proc(1)%c_name))473 ENDIF474 ELSE475 CALL logger_error(" IOM MPP FILL VAR : can't read variable, mpp "//&476 & TRIM(td_mpp%c_name)//" not opened")477 ENDIF478 479 ENDIF480 481 END SUBROUTINE iom_mpp__fill_var_id482 !> @endcode483 !-------------------------------------------------------------------484 !> @brief This subroutine fill variable value in opened mpp files,485 !> given variable name or standard name.</br/>486 !> @details487 !> If domain is given, read only domain.488 !> If border is .TRUE., read only border processor489 !490 !> @details491 !> look first for variable name. If it doesn't492 !> exist in file, look for variable standard name.<br/>493 !> If variable name is not present, check variable standard name.<br/>494 !495 !> @author J.Paul496 !> - Nov, 2013- Initial Version497 !498 !> @param[inout] td_mpp : mpp structure499 !> @param[in] cd_name : variable name or standard name500 !> @param[in] td_dom : domain structure501 !> @param[in] ld_border : read only border502 !-------------------------------------------------------------------503 !> @code504 SUBROUTINE iom_mpp__fill_var_name(td_mpp, cd_name, td_dom, ld_border )505 IMPLICIT NONE506 ! Argument507 TYPE(TMPP), INTENT(INOUT) :: td_mpp508 CHARACTER(LEN=*), INTENT(IN ) :: cd_name509 TYPE(TDOM) , INTENT(IN ), OPTIONAL :: td_dom510 LOGICAL, INTENT(IN ), OPTIONAL :: ld_border511 512 ! local variable513 INTEGER(i4) :: il_ind514 !----------------------------------------------------------------515 ! check if mpp exist516 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN517 518 CALL logger_error( " IOM MPP FILL VAR : domain decomposition not define "//&519 & " in mpp strcuture "//TRIM(td_mpp%c_name))520 521 ELSE522 523 il_ind=var_get_id( td_mpp%t_proc(1)%t_var(:), cd_name, cd_name)524 IF( il_ind /= 0 )THEN525 526 !!! read variable value527 CALL iom_mpp__read_var_value(td_mpp, &528 & td_mpp%t_proc(1)%t_var(il_ind), &529 & td_dom, ld_border)530 531 ELSE532 533 CALL logger_error( &534 & " IOM MPP FILL VAR : there is no variable with "//&535 & "name or standard name "//TRIM(cd_name)//&536 & " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name))537 538 ENDIF539 540 ENDIF541 542 END SUBROUTINE iom_mpp__fill_var_name543 !> @endcode544 409 !------------------------------------------------------------------- 545 410 !> @brief This subroutine read variable value … … 547 412 !> 548 413 !> @details 549 !> If domain is given, read only domain.550 !> If border is .TRUE., read only border processor414 !> Optionally start indices and number of point to be read could be specify. 415 !> as well as East West ovelap of the global domain. 551 416 ! 552 417 !> @author J.Paul 553 !> - Nov, 2013- Initial Version 554 ! 555 !> @param[in] td_mpp : mpp structure 556 !> @param[inout] td_var : variable structure 557 !> @param[in] td_dom : domain structure 558 !> @param[in] ld_border : read only border 559 !> @return variable structure completed 560 ! 561 !> @todo 562 !> - modif en fonction dimension de la variable lu pour cas dom 563 !------------------------------------------------------------------- 564 !> @code 418 !> - November, 2013- Initial Version 419 !> @date October, 2014 420 !> - use start and count array instead of domain structure. 421 !> 422 !> @param[in] td_mpp mpp structure 423 !> @param[inout] td_var variable structure 424 !> @param[in] id_start index in the variable from which the data values 425 !> will be read 426 !> @param[in] id_count number of indices selected along each dimension 427 !------------------------------------------------------------------- 565 428 SUBROUTINE iom_mpp__read_var_value(td_mpp, td_var, & 566 & td_dom, ld_border)429 & id_start, id_count ) 567 430 IMPLICIT NONE 568 431 ! Argument 569 432 TYPE(TMPP), INTENT(IN) :: td_mpp 570 433 TYPE(TVAR), INTENT(INOUT) :: td_var 571 TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom572 LOGICAL, INTENT(IN), OPTIONAL :: ld_border434 INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start 435 INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count 573 436 574 437 ! local variable … … 579 442 INTEGER(i4) :: il_j1p 580 443 INTEGER(i4) :: il_j2p 581 582 LOGICAL :: ll_border 444 INTEGER(i4) :: il_i1 445 INTEGER(i4) :: il_i2 446 INTEGER(i4) :: il_j1 447 INTEGER(i4) :: il_j2 448 449 INTEGER(i4), DIMENSION(ip_maxdim) :: il_start 450 INTEGER(i4), DIMENSION(ip_maxdim) :: il_end 451 INTEGER(i4), DIMENSION(ip_maxdim) :: il_count 452 453 INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt 454 INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt 455 456 TYPE(TATT) :: tl_att 583 457 TYPE(TVAR) :: tl_var 584 TYPE(TMPP) :: tl_mpp585 TYPE(TDOM) :: tl_dom586 458 587 459 ! loop indices … … 589 461 !---------------------------------------------------------------- 590 462 591 ll_border=.FALSE. 592 IF( PRESENT(ld_border) ) ll_border=ld_border 593 ! check td_dom and ld_border optionals parameters... 594 IF( ll_border .AND. PRESENT(td_dom) )THEN 595 CALL logger_error( "IOM MPP READ VAR VALUE: & 596 & domain and border can't be both specify") 597 ENDIF 598 599 IF( ll_border )THEN 600 601 ! copy mpp structure 602 tl_mpp=td_mpp 603 ! forced to keep same id 604 tl_mpp%t_proc(:)%i_id=td_mpp%t_proc(:)%i_id 605 606 IF( ALL(td_mpp%t_proc(:)%l_ctr) )THEN 607 CALL logger_warn( "IOM MPP READ VAR VALUE: & 608 & contour not define. look for it") 609 ! get contour 610 CALL mpp_get_contour( tl_mpp ) 611 ENDIF 612 613 ! Allocate space to hold variable value in structure 614 IF( ASSOCIATED(td_var%d_value) )THEN 615 DEALLOCATE(td_var%d_value) 616 ENDIF 617 618 DO jk=1,ip_maxdim 619 IF( .NOT. td_var%t_dim(jk)%l_use ) tl_mpp%t_dim(jk)%i_len = 1 620 ENDDO 621 622 ! use mpp global dimension 623 td_var%t_dim(:)%i_len=tl_mpp%t_dim(:)%i_len 624 625 ALLOCATE(td_var%d_value( td_var%t_dim(1)%i_len, & 626 & td_var%t_dim(2)%i_len, & 627 & td_var%t_dim(3)%i_len, & 628 & td_var%t_dim(4)%i_len),& 629 & stat=il_status) 630 IF(il_status /= 0 )THEN 631 632 CALL logger_error( & 633 & " IOM MPP READ VAR VALUE: not enough space to put variable "//& 634 & TRIM(td_var%c_name)//& 635 & " in variable structure") 636 637 ENDIF 638 639 ! read border processor 640 DO jk=1,tl_mpp%i_nproc 641 IF( tl_mpp%t_proc(jk)%l_ctr )THEN 642 643 CALL logger_debug(" IOM MPP READ VAR VALUE: name "//TRIM(td_var%c_name) ) 644 CALL logger_debug(" IOM MPP READ VAR VALUE: ndim "//TRIM(fct_str(td_var%i_ndim)) ) 645 tl_var=iom_read_var( tl_mpp%t_proc(jk), td_var%c_name ) 646 647 ! get processor indices 648 il_ind(:)=mpp_get_proc_index( tl_mpp, jk ) 649 il_i1p = il_ind(1) 650 il_i2p = il_ind(2) 651 il_j1p = il_ind(3) 652 il_j2p = il_ind(4) 653 654 IF( .NOT. td_var%t_dim(1)%l_use )THEN 655 il_i1p=1 656 il_i2p=1 657 ENDIF 658 659 IF( .NOT. td_var%t_dim(2)%l_use )THEN 660 il_j1p=1 661 il_j2p=1 662 ENDIF 663 664 ! replace value in mpp domain 665 td_var%d_value(il_i1p:il_i2p,il_j1p:il_j2p,:,:) = & 666 & tl_var%d_value(:,:,:,:) 667 668 ! clean variable 669 CALL var_clean(tl_var) 670 ENDIF 671 ENDDO 672 673 ENDIF 674 675 IF( PRESENT(td_dom) )THEN 676 677 ! copy mpp structure 678 tl_mpp=td_mpp 679 ! forced to keep same id 680 tl_mpp%t_proc(:)%i_id=td_mpp%t_proc(:)%i_id 681 682 IF( ALL(.NOT. td_mpp%t_proc(:)%l_use) )THEN 683 CALL logger_warn( "IOM MPP READ VAR VALUE: & 684 & processor to be used not defined. look for it") 685 ! get processor to be used 686 CALL mpp_get_use( tl_mpp, td_dom ) 687 ENDIF 688 689 ! Allocate space to hold variable value in structure 690 IF( ASSOCIATED(td_var%d_value) )THEN 691 DEALLOCATE(td_var%d_value) 692 ENDIF 693 694 tl_dom=td_dom 695 DO jk=1,ip_maxdim 696 IF( .NOT. td_var%t_dim(jk)%l_use ) tl_dom%t_dim(jk)%i_len = 1 697 ENDDO 698 699 ! use domain dimension 700 td_var%t_dim(1:2)%i_len=tl_dom%t_dim(1:2)%i_len 701 702 ALLOCATE(td_var%d_value( tl_dom%t_dim(1)%i_len, & 703 & tl_dom%t_dim(2)%i_len, & 704 & td_var%t_dim(3)%i_len, & 705 & td_var%t_dim(4)%i_len),& 706 & stat=il_status) 707 IF(il_status /= 0 )THEN 708 709 CALL logger_error( & 710 & " IOM MPP READ VAR VALUE: not enough space to put variable "//& 711 & TRIM(td_var%c_name)//& 712 & " in variable structure") 713 714 ENDIF 715 CALL logger_debug("IOM MPP READ VAR VALUE: shape ("//& 716 & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=1)))//","//& 717 & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=2)))//","//& 718 & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=3)))//","//& 719 & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=4)))//")" ) 720 ! FillValue by default 721 td_var%d_value(:,:,:,:)=td_var%d_fill 722 723 IF( tl_dom%i_jmin < tl_dom%i_jmax )THEN 724 ! no north pole 725 726 IF( tl_dom%i_imin == 1 .AND. & 727 & tl_dom%i_imax == tl_dom%t_dim0(1)%i_len )THEN 728 ! east west cyclic 729 730 CALL iom_mpp__no_pole_cyclic(tl_mpp, td_var, tl_dom) 731 732 ELSEIF( tl_dom%i_imin < tl_dom%i_imax )THEN 733 ! no east west overlap 734 735 CALL iom_mpp__no_pole_no_overlap(tl_mpp, td_var, tl_dom) 736 737 ! no more EW overlap in variable 738 td_var%i_ew=-1 739 740 ELSEIF( tl_dom%i_imin > tl_dom%i_imax )THEN 741 ! east west overlap 742 743 CALL iom_mpp__no_pole_overlap(tl_mpp, td_var, tl_dom) 744 745 ! no more EW overlap in variable 746 td_var%i_ew=-1 747 748 ELSE 749 750 CALL logger_error(" IOM MPP READ VAR VALUE: invalid domain definition.") 751 752 ENDIF 753 754 ELSE ! tl_dom%i_jmin >= tl_dom%i_jmax 755 ! north pole 756 757 CALL logger_error("IOM MPP READ VAR VALUE: siren is not able to do so now "//& 758 & "maybe in the next release") 759 ! IF( tl_dom%i_imin < tl_dom%i_imax )THEN 760 ! ! no east west overlap 761 762 ! CALL iom_mpp__pole_no_overlap(tl_mpp, td_var, tl_dom) 763 764 ! ELSEIF(tl_dom%i_imin == tl_dom%i_imax)THEN 765 ! ! east west cyclic 766 767 ! CALL iom_mpp__pole_cyclic(tl_mpp, td_var, tl_dom) 768 769 ! ELSE ! tl_dom%i_imin > tl_dom%i_imax 770 ! ! east west overlap 771 772 ! CALL iom_mpp__pole_overlap(tl_mpp, td_var, tl_dom) 773 774 ! ENDIF 775 ENDIF 776 777 ENDIF 778 779 ! force to change _FillValue to avoid mistake 780 ! with dummy zero _FillValue 781 IF( td_var%d_fill == 0._dp )THEN 782 CALL var_chg_FillValue(td_var) 783 ENDIF 784 785 END SUBROUTINE iom_mpp__read_var_value 786 !> @endcode 787 !------------------------------------------------------------------- 788 !> @brief This subroutine read variable value 789 !> in an mpp structure. The output domain do not overlap 790 !> north fold boundary or east-west boundary. 791 !> 792 !> @details 793 !> If domain is given, read only domain. 794 !> If border is .TRUE., read only border processor 795 ! 796 !> @author J.Paul 797 !> - Nov, 2013- Initial Version 798 ! 799 !> @param[in] td_mpp : mpp structure 800 !> @param[inout] td_var : variable structure 801 !> @param[in] td_dom : domain structure 802 !> @return variable structure completed 803 ! 804 !> @todo 805 !------------------------------------------------------------------- 806 !> @code 807 SUBROUTINE iom_mpp__no_pole_no_overlap(td_mpp, td_var, td_dom ) 808 IMPLICIT NONE 809 ! Argument 810 TYPE(TMPP), INTENT(IN) :: td_mpp 811 TYPE(TVAR), INTENT(INOUT) :: td_var 812 TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom 813 814 ! local variable 815 INTEGER(i4), DIMENSION(4) :: il_ind 816 INTEGER(i4) :: il_i1p 817 INTEGER(i4) :: il_j1p 818 INTEGER(i4) :: il_i2p 819 INTEGER(i4) :: il_j2p 820 821 INTEGER(i4) :: il_i1 822 INTEGER(i4) :: il_j1 823 INTEGER(i4) :: il_i2 824 INTEGER(i4) :: il_j2 825 826 INTEGER(i4), DIMENSION(4) :: il_start 827 INTEGER(i4), DIMENSION(4) :: il_count 828 TYPE(TVAR) :: tl_var 829 TYPE(TDOM) :: tl_dom 830 831 ! loop indices 832 INTEGER(i4) :: jk 833 !---------------------------------------------------------------- 834 835 ! change dimension length if not use 836 tl_dom=td_dom 837 IF( .NOT. td_var%t_dim(1)%l_use )THEN 838 tl_dom%i_imin=1 ; tl_dom%i_imax=1 839 ENDIF 840 IF( .NOT. td_var%t_dim(2)%l_use )THEN 841 tl_dom%i_jmin=1 ; tl_dom%i_jmax=1 842 ENDIF 843 ! IF( .NOT. td_var%t_dim(3)%l_use )THEN 844 ! tl_dom%i_kmin=1 ; tl_dom%i_kmax=1 845 ! ENDIF 846 ! IF( .NOT. td_var%t_dim(4)%l_use )THEN 847 ! tl_dom%i_lmin=1 ; tl_dom%i_lmax=1 848 ! ENDIF 849 850 ! read processor 851 DO jk=1,td_mpp%i_nproc 852 IF( td_mpp%t_proc(jk)%l_use )THEN 853 854 ! get processor indices 855 il_ind(:)=mpp_get_proc_index( td_mpp, jk ) 856 il_i1p = il_ind(1) 857 il_i2p = il_ind(2) 858 il_j1p = il_ind(3) 859 il_j2p = il_ind(4) 860 861 IF( .NOT. td_var%t_dim(1)%l_use )THEN 862 il_i1p=tl_dom%i_imin ; il_i2p=tl_dom%i_imax 863 ENDIF 864 IF( .NOT. td_var%t_dim(2)%l_use )THEN 865 il_j1p=tl_dom%i_jmin ; il_j2p=tl_dom%i_jmax 866 ENDIF 867 868 il_i1=MAX(il_i1p, tl_dom%i_imin) 869 il_i2=MIN(il_i2p, tl_dom%i_imax) 870 871 il_j1=MAX(il_j1p, tl_dom%i_jmin) 872 il_j2=MIN(il_j2p, tl_dom%i_jmax) 873 874 IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN 875 876 il_start(:)=(/ il_i1-il_i1p+1, & 877 & il_j1-il_j1p+1, & 878 & 1,1 /) 879 ! & tl_dom%i_kmin, & 880 ! & tl_dom%i_lmin /) 881 882 il_count(:)=(/ il_i2-il_i1+1, & 883 & il_j2-il_j1+1, & 884 & td_var%t_dim(3)%i_len, & 885 & td_var%t_dim(4)%i_len /) 886 ! & tl_dom%t_dim(3)%i_len, & 887 ! & tl_dom%t_dim(4)%i_len /) 888 889 tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,& 890 & il_start(:), il_count(:) ) 891 892 ! replace value in output variable structure 893 td_var%d_value( il_i1 - tl_dom%i_imin + 1 : & 894 & il_i2 - tl_dom%i_imin + 1, & 895 & il_j1 - tl_dom%i_jmin + 1 : & 896 & il_j2 - tl_dom%i_jmin + 1, & 897 & :,:) = tl_var%d_value(:,:,:,:) 898 899 ENDIF 900 901 ENDIF 463 il_start(:)=1 464 IF( PRESENT(id_start) ) il_start(:)=id_start(:) 465 466 il_count(:)=td_mpp%t_dim(:)%i_len 467 IF( PRESENT(id_count) ) il_count(:)=id_count(:) 468 469 DO jk=1,ip_maxdim 470 IF( .NOT. td_var%t_dim(jk)%l_use )THEN 471 il_start(jk) = 1 472 il_count(jk) = 1 473 ENDIF 474 475 il_end(jk)=il_start(jk)+il_count(jk)-1 902 476 ENDDO 903 477 904 END SUBROUTINE iom_mpp__no_pole_no_overlap 905 !> @endcode 906 !------------------------------------------------------------------- 907 !> @brief This subroutine read variable value 908 !> in an mpp structure. The output domain do not overlap north fold boundary. 909 !> However it uses cyclic east-west boundary. 910 !> 911 !> @details 912 !> If domain is given, read only domain. 913 !> If border is .TRUE., read only border processor 914 ! 915 !> @author J.Paul 916 !> - Nov, 2013- Initial Version 917 ! 918 !> @param[in] td_mpp : mpp structure 919 !> @param[inout] td_var : variable structure 920 !> @param[in] td_dom : domain structure 921 !> @return variable structure completed 922 ! 923 !> @todo 924 !------------------------------------------------------------------- 925 !> @code 926 SUBROUTINE iom_mpp__no_pole_cyclic(td_mpp, td_var, td_dom ) 927 IMPLICIT NONE 928 ! Argument 929 TYPE(TMPP), INTENT(IN ) :: td_mpp 930 TYPE(TVAR), INTENT(INOUT) :: td_var 931 TYPE(TDOM), INTENT(IN ), OPTIONAL :: td_dom 932 933 ! local variable 934 INTEGER(i4), DIMENSION(4) :: il_ind 935 INTEGER(i4) :: il_i1p 936 INTEGER(i4) :: il_j1p 937 INTEGER(i4) :: il_i2p 938 INTEGER(i4) :: il_j2p 939 940 INTEGER(i4) :: il_i1 941 INTEGER(i4) :: il_j1 942 INTEGER(i4) :: il_i2 943 INTEGER(i4) :: il_j2 944 945 INTEGER(i4), DIMENSION(4) :: il_start 946 INTEGER(i4), DIMENSION(4) :: il_count 947 TYPE(TVAR) :: tl_var 948 TYPE(TDOM) :: tl_dom 949 950 ! loop indices 951 INTEGER(i4) :: jk 952 !---------------------------------------------------------------- 953 954 ! change dimension length if not use 955 tl_dom=td_dom 956 IF( .NOT. td_var%t_dim(1)%l_use )THEN 957 tl_dom%i_imin=1 ; tl_dom%i_imax=1 958 ENDIF 959 IF( .NOT. td_var%t_dim(2)%l_use )THEN 960 tl_dom%i_jmin=1 ; tl_dom%i_jmax=1 961 ENDIF 962 ! IF( .NOT. td_var%t_dim(3)%l_use )THEN 963 ! tl_dom%i_kmin=1 ; tl_dom%i_kmax=1 964 ! ENDIF 965 ! IF( .NOT. td_var%t_dim(4)%l_use )THEN 966 ! tl_dom%i_lmin=1 ; tl_dom%i_lmax=1 967 ! ENDIF 478 479 IF( ANY(il_end(:) > td_mpp%t_dim(:)%i_len) )THEN 480 CALL logger_fatal("IOM MPP READ VAR VALUE: start + count "//& 481 & "exceed dimension bound.") 482 ENDIF 483 484 ! use domain dimension 485 td_var%t_dim(:)%i_len=il_count(:) 486 487 ! Allocate space to hold variable value in structure 488 IF( ASSOCIATED(td_var%d_value) )THEN 489 DEALLOCATE(td_var%d_value) 490 ENDIF 491 492 ALLOCATE(td_var%d_value( il_count(1), & 493 & il_count(2), & 494 & il_count(3), & 495 & il_count(4)),& 496 & stat=il_status) 497 IF(il_status /= 0 )THEN 498 499 CALL logger_error( & 500 & " IOM MPP READ VAR VALUE: not enough space to put variable "//& 501 & TRIM(td_var%c_name)//& 502 & " in variable structure") 503 504 ENDIF 505 506 CALL logger_debug("IOM MPP READ VAR VALUE: shape ("//& 507 & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=1)))//","//& 508 & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=2)))//","//& 509 & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=3)))//","//& 510 & TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=4)))//")" ) 511 ! FillValue by default 512 td_var%d_value(:,:,:,:)=td_var%d_fill 968 513 969 514 ! read processor … … 977 522 il_j1p = il_ind(3) 978 523 il_j2p = il_ind(4) 979 524 980 525 IF( .NOT. td_var%t_dim(1)%l_use )THEN 981 il_i1p= tl_dom%i_imin ; il_i2p=tl_dom%i_imax526 il_i1p=il_start(1) ; il_i2p=il_end(1) 982 527 ENDIF 983 528 IF( .NOT. td_var%t_dim(2)%l_use )THEN 984 il_j1p=tl_dom%i_jmin ; il_j2p=tl_dom%i_jmax 529 il_j1p=il_start(2) ; il_j2p=il_end(2) 530 ENDIF 531 532 il_i1=MAX(il_i1p, il_start(1)) 533 il_i2=MIN(il_i2p, il_end(1)) 534 535 il_j1=MAX(il_j1p, il_start(2)) 536 il_j2=MIN(il_j2p, il_end(2)) 537 538 IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN 539 il_strt(:)=(/ il_i1-il_i1p+1, & 540 & il_j1-il_j1p+1, & 541 & 1,1 /) 542 543 il_cnt(:)=(/ il_i2-il_i1+1, & 544 & il_j2-il_j1+1, & 545 & td_var%t_dim(3)%i_len, & 546 & td_var%t_dim(4)%i_len /) 547 548 tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,& 549 & il_strt(:), il_cnt(:) ) 550 ! replace value in output variable structure 551 td_var%d_value( il_i1 - il_start(1) + 1 : & 552 & il_i2 - il_start(1) + 1, & 553 & il_j1 - il_start(2) + 1 : & 554 & il_j2 - il_start(2) + 1, & 555 & :,:) = tl_var%d_value(:,:,:,:) 556 557 ! clean 558 CALL var_clean(tl_var) 985 559 ENDIF 986 560 987 il_i1=il_i1p988 il_j1=MAX(il_j1p, td_dom%i_jmin)989 990 il_i2=il_i2p991 il_j2=MIN(il_j2p, td_dom%i_jmax)992 993 IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN994 995 il_start(:)=(/ il_i1, &996 & il_j1-il_j1p+1, &997 & 1,1 /)998 ! & tl_dom%i_kmin, &999 ! & tl_dom%i_lmin /)1000 1001 il_count(:)=(/ il_i2-il_i1+1, &1002 & il_j2-il_j1+1, &1003 & td_var%t_dim(3)%i_len, &1004 & td_var%t_dim(4)%i_len /)1005 ! & tl_dom%t_dim(3)%i_len, &1006 ! & tl_dom%t_dim(4)%i_len /)1007 1008 tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,&1009 & il_start(:), il_count(:) )1010 1011 ! replace value in output variable structure1012 td_var%d_value( il_i1 : il_i2, &1013 & il_j1 - td_dom%i_jmin + 1 : &1014 & il_j2 - td_dom%i_jmin + 1, &1015 & :,:) = tl_var%d_value(:,:,:,:)1016 1017 ENDIF1018 1019 561 ENDIF 1020 562 ENDDO 1021 563 1022 END SUBROUTINE iom_mpp__no_pole_cyclic 1023 !> @endcode 1024 !------------------------------------------------------------------- 1025 !> @brief This subroutine read variable value 1026 !> in an mpp structure. The output domain do not overlap north fold boundary. 1027 !> However it overlaps east-west boundary. 1028 !> 564 IF( td_var%t_dim(1)%l_use .AND. & 565 & td_var%t_dim(1)%i_len == td_mpp%t_dim(1)%i_len )THEN 566 IF( td_mpp%i_ew >= 0 )THEN 567 tl_att=att_init("ew_overlap",td_mpp%i_ew) 568 CALL var_move_att(td_var,tl_att) 569 ! clean 570 CALL att_clean(tl_att) 571 ENDIF 572 ENDIF 573 574 ! force to change _FillValue to avoid mistake 575 ! with dummy zero _FillValue 576 IF( td_var%d_fill == 0._dp )THEN 577 CALL var_chg_FillValue(td_var) 578 ENDIF 579 580 END SUBROUTINE iom_mpp__read_var_value 581 !------------------------------------------------------------------- 582 !> @brief This subroutine write files composing mpp structure. 583 ! 1029 584 !> @details 1030 !> If domain is given, read only domain.1031 !> If border is .TRUE., read only border processor1032 585 ! 1033 586 !> @author J.Paul 1034 !> - Nov, 2013- Initial Version 1035 ! 1036 !> @param[in] td_mpp : mpp structure 1037 !> @param[inout] td_var : variable structure 1038 !> @param[in] td_dom : domain structure 1039 !> @return variable structure completed 1040 ! 1041 !> @todo 1042 !------------------------------------------------------------------- 1043 !> @code 1044 SUBROUTINE iom_mpp__no_pole_overlap(td_mpp, td_var, td_dom ) 1045 IMPLICIT NONE 1046 ! Argument 1047 TYPE(TMPP), INTENT(IN) :: td_mpp 1048 TYPE(TVAR), INTENT(INOUT) :: td_var 1049 TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom 1050 1051 ! local variable 1052 INTEGER(i4), DIMENSION(4) :: il_ind 1053 INTEGER(i4) :: il_i1p 1054 INTEGER(i4) :: il_j1p 1055 INTEGER(i4) :: il_i2p 1056 INTEGER(i4) :: il_j2p 1057 1058 INTEGER(i4) :: il_i1 1059 INTEGER(i4) :: il_j1 1060 INTEGER(i4) :: il_i2 1061 INTEGER(i4) :: il_j2 1062 1063 INTEGER(i4) :: il_ioffset 1064 1065 INTEGER(i4), DIMENSION(4) :: il_start 1066 INTEGER(i4), DIMENSION(4) :: il_count 1067 TYPE(TVAR) :: tl_var 1068 TYPE(TDOM) :: tl_dom 1069 1070 ! loop indices 1071 INTEGER(i4) :: jk 1072 !---------------------------------------------------------------- 1073 1074 il_ioffset = (td_mpp%t_dim(1)%i_len-2) - td_dom%i_imin + 1 1075 1076 ! change dimension length if not use 1077 tl_dom=td_dom 1078 IF( .NOT. td_var%t_dim(1)%l_use )THEN 1079 tl_dom%i_imin=1 ; tl_dom%i_imax=1 1080 il_ioffset=0 1081 ENDIF 1082 IF( .NOT. td_var%t_dim(2)%l_use )THEN 1083 tl_dom%i_jmin=1 ; tl_dom%i_jmax=1 1084 ENDIF 1085 ! IF( .NOT. td_var%t_dim(3)%l_use )THEN 1086 ! tl_dom%i_kmin=1 ; tl_dom%i_kmax=1 1087 ! ENDIF 1088 ! IF( .NOT. td_var%t_dim(4)%l_use )THEN 1089 ! tl_dom%i_lmin=1 ; tl_dom%i_lmax=1 1090 ! ENDIF 1091 1092 ! read processor 1093 DO jk=1,td_mpp%i_nproc 1094 IF( td_mpp%t_proc(jk)%l_use )THEN 1095 1096 ! get processor indices 1097 il_ind(:)=mpp_get_proc_index( td_mpp, jk ) 1098 il_i1p = il_ind(1) 1099 il_i2p = il_ind(2) 1100 il_j1p = il_ind(3) 1101 il_j2p = il_ind(4) 1102 1103 IF( .NOT. td_var%t_dim(1)%l_use )THEN 1104 il_i1p=tl_dom%i_imin ; il_i2p=tl_dom%i_imax 1105 ENDIF 1106 IF( .NOT. td_var%t_dim(2)%l_use )THEN 1107 il_j1p=tl_dom%i_jmin ; il_j2p=tl_dom%i_jmax 1108 ENDIF 1109 1110 !!!!!! get first part of domain 1111 il_i1=MAX(il_i1p, td_dom%i_imin) 1112 il_j1=MAX(il_j1p, td_dom%i_jmin) 1113 1114 il_i2=MIN(il_i2p, td_mpp%t_dim(1)%i_len-td_var%i_ew) ! east-west overlap 1115 il_j2=MIN(il_j2p, td_dom%i_jmax) 1116 1117 IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN 1118 1119 il_start(:)=(/ il_i1-il_i1p+1, & 1120 & il_j1-il_j1p+1, & 1121 & 1,1 /) 1122 ! & tl_dom%i_kmin, & 1123 ! & tl_dom%i_lmin /) 1124 1125 il_count(:)=(/ il_i2-il_i1+1, & 1126 & il_j2-il_j1+1, & 1127 & td_var%t_dim(3)%i_len, & 1128 & td_var%t_dim(4)%i_len /) 1129 ! & tl_dom%t_dim(3)%i_len, & 1130 ! & tl_dom%t_dim(4)%i_len /) 1131 1132 tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,& 1133 & il_start(:), il_count(:) ) 1134 1135 ! replace value in output variable structure 1136 td_var%d_value( il_i1 - td_dom%i_imin + 1 : & 1137 & il_i2 - td_dom%i_imin + 1, & 1138 & il_j1 - td_dom%i_jmin + 1 : & 1139 & il_j2 - td_dom%i_jmin + 1, & 1140 & :,:) = tl_var%d_value(:,:,:,:) 1141 1142 ENDIF 1143 1144 !!!!! get second part of domain 1145 il_i1=MAX(il_i1p, 1) 1146 il_j1=MAX(il_j1p, td_dom%i_jmin) 1147 1148 il_i2=MIN(il_i2p, td_dom%i_imax) 1149 il_j2=MIN(il_j2p, td_dom%i_jmax) 1150 1151 IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN 1152 1153 il_start(:)=(/ il_i1, & 1154 & il_j1-il_j1p+1, & 1155 & 1,1 /) 1156 ! & tl_dom%i_kmin, & 1157 ! & tl_dom%i_lmin /) 1158 1159 il_count(:)=(/ il_i2-il_i1+1, & 1160 & il_j2-il_j1+1, & 1161 & td_var%t_dim(3)%i_len, & 1162 & td_var%t_dim(4)%i_len /) 1163 ! & tl_dom%t_dim(3)%i_len, & 1164 ! & tl_dom%t_dim(4)%i_len /) 1165 1166 tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,& 1167 & il_start(:), il_count(:) ) 1168 1169 ! replace value in output variable structure 1170 td_var%d_value( il_ioffset + il_i1 : & 1171 & il_ioffset + il_i2, & 1172 & il_j1 - td_dom%i_jmin + 1 : & 1173 & il_j2 - td_dom%i_jmin + 1, & 1174 & :,:) = tl_var%d_value(:,:,:,:) 1175 1176 ENDIF 1177 1178 ENDIF 1179 ENDDO 1180 1181 END SUBROUTINE iom_mpp__no_pole_overlap 1182 !> @endcode 1183 !------------------------------------------------------------------- 1184 !> @brief This subroutine read variable value 1185 !> in an mpp structure. The output domain overlaps 1186 !> north fold boundary. However it do not overlap east-west boundary. 1187 !> 1188 !> @details 1189 !> If domain is given, read only domain. 1190 ! 1191 !> @author J.Paul 1192 !> - Nov, 2013- Initial Version 1193 ! 1194 !> @param[in] td_mpp : mpp structure 1195 !> @param[inout] td_var : variable structure 1196 !> @param[in] td_dom : domain structure 1197 !> @return variable structure completed 1198 ! 1199 !> @todo 1200 !------------------------------------------------------------------- 1201 !> @code 1202 ! SUBROUTINE iom_mpp__pole_no_overlap(td_mpp, td_var, td_dom ) 1203 ! IMPLICIT NONE 1204 ! ! Argument 1205 ! TYPE(TMPP), INTENT(IN) :: td_mpp 1206 ! TYPE(TVAR), INTENT(INOUT) :: td_var 1207 ! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom 1208 ! 1209 ! ! local variable 1210 ! 1211 ! ! loop indices 1212 ! !---------------------------------------------------------------- 1213 ! 1214 ! END SUBROUTINE iom_mpp__pole_no_overlap 1215 !> @endcode 1216 !------------------------------------------------------------------- 1217 !> @brief This subroutine read variable value 1218 !> in an mpp structure. The output domain overlaps north fold boundary. 1219 !> and uses cyclic east-west boundary. 1220 !> 1221 !> @details 1222 !> If domain is given, read only domain. 1223 !> If border is .TRUE., read only border processor 1224 ! 1225 !> @author J.Paul 1226 !> - Nov, 2013- Initial Version 1227 ! 1228 !> @param[in] td_mpp : mpp structure 1229 !> @param[inout] td_var : variable structure 1230 !> @param[in] td_dom : domain structure 1231 !> @param[in] ld_border : read only border 1232 !> @return variable structure completed 1233 ! 1234 !> @todo 1235 !------------------------------------------------------------------- 1236 !> @code 1237 ! SUBROUTINE iom_mpp__pole_cyclic(td_mpp, td_var, td_dom ) 1238 ! IMPLICIT NONE 1239 ! ! Argument 1240 ! TYPE(TMPP), INTENT(IN) :: td_mpp 1241 ! TYPE(TVAR), INTENT(INOUT) :: td_var 1242 ! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom 1243 ! 1244 ! ! local variable 1245 ! 1246 ! ! loop indices 1247 ! !---------------------------------------------------------------- 1248 ! 1249 ! END SUBROUTINE iom_mpp__pole_cyclic 1250 !> @endcode 1251 !------------------------------------------------------------------- 1252 !> @brief This subroutine read variable value 1253 !> in an mpp structure. The output domain overlaps north fold boundary. 1254 !> and east-west boundary. 1255 !> 1256 !> @details 1257 !> If domain is given, read only domain. 1258 !> If border is .TRUE., read only border processor 1259 ! 1260 !> @author J.Paul 1261 !> - Nov, 2013- Initial Version 1262 ! 1263 !> @param[in] td_mpp : mpp structure 1264 !> @param[inout] td_var : variable structure 1265 !> @param[in] td_dom : domain structure 1266 !> @param[in] ld_border : read only border 1267 !> @return variable structure completed 1268 ! 1269 !> @todo 1270 !------------------------------------------------------------------- 1271 !> @code 1272 ! SUBROUTINE iom_mpp__pole_overlap(td_mpp, td_var, td_dom ) 1273 ! IMPLICIT NONE 1274 ! ! Argument 1275 ! TYPE(TMPP), INTENT(IN) :: td_mpp 1276 ! TYPE(TVAR), INTENT(INOUT) :: td_var 1277 ! TYPE(TDOM), INTENT(IN), OPTIONAL :: td_dom 1278 ! 1279 ! ! local variable 1280 ! 1281 ! ! loop indices 1282 ! !---------------------------------------------------------------- 1283 ! 1284 ! END SUBROUTINE iom_mpp__pole_overlap 1285 !> @endcode 1286 !------------------------------------------------------------------- 1287 !> @brief This subroutine write mpp structure in opened files. 1288 ! 1289 !> @details 1290 ! 1291 !> @author J.Paul 1292 !> - Nov, 2013- Initial Version 1293 ! 1294 !> @param[in] td_file : file structure 1295 !------------------------------------------------------------------- 1296 !> @code 587 !> - November, 2013- Initial Version 588 ! 589 !> @param[inout] td_mpp mpp structure 590 !------------------------------------------------------------------- 1297 591 SUBROUTINE iom_mpp_write_file(td_mpp) 1298 592 IMPLICIT NONE … … 1300 594 TYPE(TMPP), INTENT(INOUT) :: td_mpp 1301 595 596 ! local variable 1302 597 ! loop indices 1303 598 INTEGER(i4) :: ji … … 1312 607 DO ji=1, td_mpp%i_nproc 1313 608 IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN 609 !CALL file_del_att(td_mpp%t_proc(ji), 'periodicity') 610 !CALL file_del_att(td_mpp%t_proc(ji), 'ew_overlap') 611 1314 612 CALL iom_write_file(td_mpp%t_proc(ji)) 1315 613 ELSE … … 1320 618 ENDIF 1321 619 END SUBROUTINE iom_mpp_write_file 1322 !> @endcode1323 620 END MODULE iom_mpp
Note: See TracChangeset
for help on using the changeset viewer.