- 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/file.f90
r4213 r6225 7 7 !> @brief 8 8 !> This module manage file structure. 9 ! 9 !> 10 10 !> @details 11 !>12 11 !> define type TFILE:<br/> 13 !> TYPE(TFILE) :: tl_file<br/> 14 !> 15 !> to initialise a file structure:<br/> 16 !> tl_file=file_init(cd_file [,cd_type] [,ld_wrt]) 12 !> @code 13 !> TYPE(TFILE) :: tl_file 14 !> @endcode 15 !> 16 !> to initialize a file structure:<br/> 17 !> @code 18 !> tl_file=file_init(cd_file [,cd_type] [,ld_wrt] [,cd_grid]) 19 !% tl_file=file_init(cd_file [,cd_type] [,ld_wrt] [,id_ew] [,id_perio] [,id_pivot] [,cd_grid]) 20 !> @endcode 17 21 !> - cd_file is the file name 18 !> - cd_type is the type of the file ('cdf', 'dimg') (optional) 19 !> - ld_wrt file in write mode or not (optional) 22 !> - cd_type is the type of the file ('cdf', 'dimg') [optional] 23 !> - ld_wrt file in write mode or not [optional] 24 !% - id_ew is the number of point for east-west overlap [optional] 25 !% - id_perio is the NEMO periodicity index [optional] 26 !% - id_pivot is the NEMO pivot point index F(0),T(1) [optional] 27 !> - cd_grid is the grid type (default 'ARAKAWA-C') 20 28 !> 21 29 !> to get file name:<br/> … … 38 46 !> - tl_file\%i_nvar 39 47 !> 40 !> to get the tableof variable structure associated to the file:<br/>48 !> to get the array of variable structure associated to the file:<br/> 41 49 !> - tl_file\%t_var(:) 42 50 !> … … 45 53 !> - tl_file\%i_natt 46 54 !> 47 !> to get the tableof attributes structure associated to the file:<br/>55 !> to get the array of attributes structure associated to the file:<br/> 48 56 !> - tl_file\%t_att(:) 49 57 !> … … 52 60 !> - tl_file\%i_ndim 53 61 !> 54 !> to get the tableof dimension structure (4 elts) associated to the62 !> to get the array of dimension structure (4 elts) associated to the 55 63 !> file:<br/> 56 64 !> - tl_file\%t_dim(:) 57 65 !> 58 66 !> to print information about file structure:<br/> 67 !> @code 59 68 !> CALL file_print(td_file) 69 !> @endcode 70 !> 71 !> to clean file structure:<br/> 72 !> @code 73 !> CALL file_clean(td_file) 74 !> @endcode 60 75 !> 61 76 !> to add a global attribute structure in file structure:<br/> 77 !> @code 62 78 !> CALL file_add_att(td_file, td_att) 79 !> @endcode 63 80 !> - td_att is an attribute structure 64 81 !> 65 82 !> to add a dimension structure in file structure:<br/> 83 !> @code 66 84 !> CALL file_add_dim(td_file, td_dim) 85 !> @endcode 67 86 !> - td_dim is a dimension structure 68 87 !> 69 88 !> to add a variable structure in file structure:<br/> 89 !> @code 70 90 !> CALL file_add_var(td_file, td_var) 91 !> @endcode 71 92 !> - td_var is a variable structure 72 93 !> 73 94 !> to delete a global attribute structure in file structure:<br/> 95 !> @code 74 96 !> CALL file_del_att(td_file, td_att) 97 !> @endcode 75 98 !> - td_att is an attribute structure 76 99 !> 77 100 !> to delete a dimension structure in file structure:<br/> 101 !> @code 78 102 !> CALL file_del_dim(td_file, td_dim) 103 !> @endcode 79 104 !> - td_dim is a dimension structure 80 105 !> 81 106 !> to delete a variable structure in file structure:<br/> 107 !> @code 82 108 !> CALL file_del_var(td_file, td_var) 109 !> @endcode 83 110 !> - td_var is a variable structure 84 111 !> 85 112 !> to overwrite one attribute structure in file structure:<br/> 113 !> @code 86 114 !> CALL file_move_att(td_file, td_att) 115 !> @endcode 87 116 !> - td_att is an attribute structure 88 117 !> 89 118 !> to overwrite one dimension strucutre in file structure:<br/> 119 !> @code 90 120 !> CALL file_move_dim(td_file, td_dim) 121 !> @endcode 91 122 !> - td_dim is a dimension structure 92 123 !> 93 124 !> to overwrite one variable structure in file structure:<br/> 125 !> @code 94 126 !> CALL file_move_var(td_file, td_var) 127 !> @endcode 95 128 !> - td_var is a variable structure 96 129 !> 97 130 !> to check if file and variable structure share same dimension:<br/> 131 !> @code 98 132 !> ll_check_dim = file_check_var_dim(td_file, td_var) 133 !> @endcode 99 134 !> - td_var is a variable structure 100 135 !> … … 102 137 !> J.Paul 103 138 ! REVISION HISTORY: 104 !> @date Nov, 2013- Initial Version 139 !> @date November, 2013 - Initial Version 140 !> @date November, 2014 141 !> - Fix memory leaks bug 105 142 !> 106 143 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 107 !> @todo108 !> - file_get_var(td_file, varname)109 !> - add description generique de l'objet file110 144 !---------------------------------------------------------------------- 111 145 MODULE file … … 113 147 USE global ! global variable 114 148 USE fct ! basic useful function 115 USE logger 149 USE logger ! log file manager 116 150 USE dim ! dimension manager 117 151 USE att ! attribute manager 118 152 USE var ! variable manager 119 153 IMPLICIT NONE 120 PRIVATE121 154 ! NOTE_avoid_public_variables_if_possible 122 155 123 156 ! type and variable 124 PUBLIC :: TFILE ! file structure157 PUBLIC :: TFILE !< file structure 125 158 126 159 ! function and subroutine 127 PUBLIC :: ASSIGNMENT(=)!< copy file structure128 PUBLIC :: file_print !< print information about file structure129 PUBLIC :: file_clean !< clean file structure130 PUBLIC :: file_init !< initialise file structure131 PUBLIC :: file_add_att !< add one attribute structure in file structure132 PUBLIC :: file_add_var !< add one variable structure in file structure133 PUBLIC :: file_add_dim !< add one dimension strucutre in file structure134 PUBLIC :: file_del_att !< delete one attribute structure of file structure135 PUBLIC :: file_del_var !< delete one variable structure of file structure136 PUBLIC :: file_del_dim !< delete one dimension strucutre of file structure137 PUBLIC :: file_move_att !< overwrite one attribute structure in file structure138 PUBLIC :: file_move_var !< overwrite one variable structure in file structure139 PUBLIC :: file_move_dim !< overwrite one dimension strucutre in file structure160 PUBLIC :: file_copy !< copy file structure 161 PUBLIC :: file_print !< print information about file structure 162 PUBLIC :: file_clean !< clean file structure 163 PUBLIC :: file_init !< initialize file structure 164 PUBLIC :: file_add_att !< add one attribute structure in file structure 165 PUBLIC :: file_add_var !< add one variable structure in file structure 166 PUBLIC :: file_add_dim !< add one dimension strucutre in file structure 167 PUBLIC :: file_del_att !< delete one attribute structure of file structure 168 PUBLIC :: file_del_var !< delete one variable structure of file structure 169 PUBLIC :: file_del_dim !< delete one dimension strucutre of file structure 170 PUBLIC :: file_move_att !< overwrite one attribute structure in file structure 171 PUBLIC :: file_move_var !< overwrite one variable structure in file structure 172 PUBLIC :: file_move_dim !< overwrite one dimension strucutre in file structure 140 173 PUBLIC :: file_check_var_dim !< check if file and variable structure use same dimension. 141 PUBLIC :: file_get_type !< get type of file142 PUBLIC :: file_get_id !< get file id143 PUBLIC :: file_rename !< rename file name144 PUBLIC :: file_add_suffix !< add suffix to file name174 PUBLIC :: file_get_type !< get type of file 175 PUBLIC :: file_get_id !< get file id 176 PUBLIC :: file_rename !< rename file name 177 PUBLIC :: file_add_suffix !< add suffix to file name 145 178 146 PRIVATE :: file__del_var_name !< delete a variable structure in file structure, given variable name or standard name 147 PRIVATE :: file__del_var_str !< delete a variable structure in file structure, given variable structure 148 PRIVATE :: file__del_att_name !< delete a attribute structure in file structure, given attribute name 149 PRIVATE :: file__del_att_str !< delete a attribute structure in file structure, given attribute structure 150 PRIVATE :: file__get_number !< get number in file name without suffix 151 PRIVATE :: file__get_suffix !< get suffix of file name 152 PRIVATE :: file__copy_unit !< copy file structure 153 PRIVATE :: file__copy_tab !< copy file structure 154 155 !> @struct 156 TYPE TFILE 179 PRIVATE :: file__clean_unit ! clean file structure 180 PRIVATE :: file__clean_arr ! clean array of file structure 181 PRIVATE :: file__del_var_name ! delete a variable structure in file structure, given variable name or standard name 182 PRIVATE :: file__del_var_str ! delete a variable structure in file structure, given variable structure 183 PRIVATE :: file__del_att_name ! delete a attribute structure in file structure, given attribute name 184 PRIVATE :: file__del_att_str ! delete a attribute structure in file structure, given attribute structure 185 PRIVATE :: file__get_number ! get number in file name without suffix 186 PRIVATE :: file__get_suffix ! get suffix of file name 187 PRIVATE :: file__copy_unit ! copy file structure 188 PRIVATE :: file__copy_arr ! copy array of file structure 189 PRIVATE :: file__rename_char ! rename file name, given processor number. 190 PRIVATE :: file__rename_str ! rename file name, given file structure. 191 192 TYPE TFILE !< file structure 157 193 158 194 ! general 159 CHARACTER(LEN=lc) :: c_name = "" !< file name160 CHARACTER(LEN=lc) :: c_type = "" !< type of the file (cdf, cdf4, dimg)161 INTEGER(i4) :: i_id = 0 162 LOGICAL :: l_wrt = .FALSE. 163 INTEGER(i4) :: i_nvar = 0 164 TYPE(TVAR), DIMENSION(:), POINTER :: t_var => NULL() 195 CHARACTER(LEN=lc) :: c_name = "" !< file name 196 CHARACTER(LEN=lc) :: c_type = "" !< type of the file (cdf, cdf4, dimg) 197 INTEGER(i4) :: i_id = 0 !< file id 198 LOGICAL :: l_wrt = .FALSE. !< read or write mode 199 INTEGER(i4) :: i_nvar = 0 !< number of variable 200 TYPE(TVAR), DIMENSION(:), POINTER :: t_var => NULL() !< file variables 165 201 166 202 CHARACTER(LEN=lc) :: c_grid = 'ARAKAWA-C' !< grid type 167 203 168 INTEGER(i4) :: i_ew =-1 !< east-west overlap169 INTEGER(i4) :: i_perio =-1 !< NEMO periodicity index170 INTEGER(i4) :: i_pivot =-1 !< NEMO pivot point index F(0),T(1)171 172 INTEGER(i4) :: i_depthid = 0 173 INTEGER(i4) :: i_timeid = 0 204 INTEGER(i4) :: i_ew =-1 !< east-west overlap 205 INTEGER(i4) :: i_perio =-1 !< NEMO periodicity index 206 INTEGER(i4) :: i_pivot =-1 !< NEMO pivot point index F(0),T(1) 207 208 INTEGER(i4) :: i_depthid = 0 !< variable id of depth 209 INTEGER(i4) :: i_timeid = 0 !< variable id of time 174 210 175 211 ! netcdf file 176 INTEGER(i4) :: i_ndim = 0 177 INTEGER(i4) :: i_natt = 0 178 INTEGER(i4) :: i_uldid = 0 179 LOGICAL :: l_def = .FALSE. 180 TYPE(TATT), DIMENSION(:), POINTER :: t_att => NULL() 181 TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim 212 INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in the file 213 INTEGER(i4) :: i_natt = 0 !< number of global attributes in the file 214 INTEGER(i4) :: i_uldid = 0 !< id of the unlimited dimension in the file 215 LOGICAL :: l_def = .FALSE. !< define mode or not 216 TYPE(TATT), DIMENSION(:), POINTER :: t_att => NULL() !< global attributes 217 TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< dimension structure 182 218 183 219 ! dimg file 184 INTEGER(i4) :: i_recl = 0 185 INTEGER(i4) :: i_n0d = 0 186 INTEGER(i4) :: i_n1d = 0 187 INTEGER(i4) :: i_n2d = 0 188 INTEGER(i4) :: i_n3d = 0 189 INTEGER(i4) :: i_rhd = 0 220 INTEGER(i4) :: i_recl = 0 !< record length (binary file) 221 INTEGER(i4) :: i_n0d = 0 !< number of scalar variable 222 INTEGER(i4) :: i_n1d = 0 !< number of 1D variable 223 INTEGER(i4) :: i_n2d = 0 !< number of 2D variable 224 INTEGER(i4) :: i_n3d = 0 !< number of 3D variable 225 INTEGER(i4) :: i_rhd = 0 !< record of the header infos (last record) 190 226 191 227 ! mpp 192 228 ! only use for massively parallel processing 193 INTEGER(i4) :: i_pid = -1 194 INTEGER(i4) :: i_impp = 0 195 INTEGER(i4) :: i_jmpp = 0 196 INTEGER(i4) :: i_lci = 0 197 INTEGER(i4) :: i_lcj = 0 198 INTEGER(i4) :: i_ldi = 0 199 INTEGER(i4) :: i_ldj = 0 200 INTEGER(i4) :: i_lei = 0 201 INTEGER(i4) :: i_lej = 0 202 203 LOGICAL :: l_ctr = .FALSE. 204 LOGICAL :: l_use = .FALSE. 205 206 ! only use to draw domain decomposition when initiali se with mpp_init207 INTEGER(i4) :: i_iind = 0 208 INTEGER(i4) :: i_jind = 0 229 INTEGER(i4) :: i_pid = -1 !< processor id (start to 1) 230 INTEGER(i4) :: i_impp = 0 !< i-indexes for mpp-subdomain left bottom 231 INTEGER(i4) :: i_jmpp = 0 !< j-indexes for mpp-subdomain left bottom 232 INTEGER(i4) :: i_lci = 0 !< i-dimensions of subdomain 233 INTEGER(i4) :: i_lcj = 0 !< j-dimensions of subdomain 234 INTEGER(i4) :: i_ldi = 0 !< first indoor i-indices 235 INTEGER(i4) :: i_ldj = 0 !< first indoor j-indices 236 INTEGER(i4) :: i_lei = 0 !< last indoor i-indices 237 INTEGER(i4) :: i_lej = 0 !< last indoor j-indices 238 239 LOGICAL :: l_ctr = .FALSE. !< domain is on border 240 LOGICAL :: l_use = .FALSE. !< domain is used 241 242 ! only use to draw domain decomposition when initialize with mpp_init 243 INTEGER(i4) :: i_iind = 0 !< i-direction indices 244 INTEGER(i4) :: i_jind = 0 !< j-direction indices 209 245 210 246 END TYPE TFILE 247 248 INTERFACE file_clean 249 MODULE PROCEDURE file__clean_unit 250 MODULE PROCEDURE file__clean_arr 251 END INTERFACE file_clean 211 252 212 253 INTERFACE file_del_var … … 225 266 END INTERFACE file_rename 226 267 227 INTERFACE ASSIGNMENT(=)228 MODULE PROCEDURE file__copy_unit ! copy file structure229 MODULE PROCEDURE file__copy_ tab ! copy file structure268 INTERFACE file_copy 269 MODULE PROCEDURE file__copy_unit 270 MODULE PROCEDURE file__copy_arr 230 271 END INTERFACE 231 272 … … 233 274 !------------------------------------------------------------------- 234 275 !> @brief 235 !> This function copy file structure in another file 236 !> structure 276 !> This subroutine copy file structure in another one 237 277 !> @details 238 !> file variable and attribute value are copied in a temporary table,278 !> file variable and attribute value are copied in a temporary array, 239 279 !> so input and output file structure value do not point on the same 240 280 !> "memory cell", and so on are independant. … … 242 282 !> @note new file is assume to be closed. 243 283 !> 284 !> @warning do not use on the output of a function who create or read an 285 !> structure (ex: tl_file=file_copy(file_init()) is forbidden). 286 !> This will create memory leaks. 244 287 !> @warning to avoid infinite loop, do not use any function inside 245 288 !> this subroutine 246 289 !> 247 290 !> @author J.Paul 248 !> - Nov, 2013- Initial Version 249 ! 250 !> @param[out] td_file1 : file structure 251 !> @param[in] td_file2 : file structure 252 !------------------------------------------------------------------- 253 !> @code 254 SUBROUTINE file__copy_unit( td_file1, td_file2 ) 291 !> @date November, 2013 - Initial Version 292 !> @date November, 2014 293 !> - use function instead of overload assignment operator 294 !> (to avoid memory leak) 295 ! 296 !> @param[in] td_file file structure 297 !> @return copy of input file structure 298 !------------------------------------------------------------------- 299 FUNCTION file__copy_unit( td_file ) 255 300 IMPLICIT NONE 256 301 ! Argument 257 TYPE(TFILE), INTENT( OUT) :: td_file1 258 TYPE(TFILE), INTENT(IN ) :: td_file2 302 TYPE(TFILE), INTENT(IN) :: td_file 303 ! function 304 TYPE(TFILE) :: file__copy_unit 305 306 ! local variable 307 TYPE(TVAR) :: tl_var 308 TYPE(TATT) :: tl_att 259 309 260 310 ! loop indices … … 262 312 !---------------------------------------------------------------- 263 313 264 CALL logger_trace(" COPY: file "//TRIM(td_file2%c_name) )314 CALL logger_trace("FILE COPY: file "//TRIM(td_file%c_name) ) 265 315 266 316 ! copy file variable 267 td_file1%c_name = TRIM(td_file2%c_name)268 td_file1%c_type = TRIM(td_file2%c_type)317 file__copy_unit%c_name = TRIM(td_file%c_name) 318 file__copy_unit%c_type = TRIM(td_file%c_type) 269 319 ! file1 should be closed even if file2 is opened right now 270 td_file1%i_id = 0 271 td_file1%l_wrt = td_file2%l_wrt 272 td_file1%i_nvar = td_file2%i_nvar 273 274 td_file1%c_grid = td_file2%c_grid 275 276 td_file1%i_ew = td_file2%i_ew 277 td_file1%i_perio= td_file2%i_perio 278 td_file1%i_pivot= td_file2%i_pivot 320 file__copy_unit%i_id = 0 321 file__copy_unit%l_wrt = td_file%l_wrt 322 file__copy_unit%i_nvar = td_file%i_nvar 323 324 file__copy_unit%c_grid = td_file%c_grid 325 326 file__copy_unit%i_ew = td_file%i_ew 327 file__copy_unit%i_perio= td_file%i_perio 328 file__copy_unit%i_pivot= td_file%i_pivot 329 330 file__copy_unit%i_depthid = td_file%i_depthid 331 file__copy_unit%i_timeid = td_file%i_timeid 279 332 280 333 ! copy variable structure 281 IF( ASSOCIATED(td_file1%t_var) ) DEALLOCATE(td_file1%t_var) 282 IF( ASSOCIATED(td_file2%t_var) .AND. td_file1%i_nvar > 0 )THEN 283 ALLOCATE( td_file1%t_var(td_file1%i_nvar) ) 284 DO ji=1,td_file1%i_nvar 285 td_file1%t_var(ji) = td_file2%t_var(ji) 334 IF( ASSOCIATED(file__copy_unit%t_var) )THEN 335 CALL var_clean(file__copy_unit%t_var(:)) 336 DEALLOCATE(file__copy_unit%t_var) 337 ENDIF 338 IF( ASSOCIATED(td_file%t_var) .AND. file__copy_unit%i_nvar > 0 )THEN 339 ALLOCATE( file__copy_unit%t_var(file__copy_unit%i_nvar) ) 340 DO ji=1,file__copy_unit%i_nvar 341 tl_var = var_copy(td_file%t_var(ji)) 342 file__copy_unit%t_var(ji) = var_copy(tl_var) 286 343 ENDDO 287 344 ENDIF 288 345 289 346 ! copy netcdf variable 290 td_file1%i_ndim = td_file2%i_ndim291 td_file1%i_natt = td_file2%i_natt292 td_file1%i_uldid = td_file2%i_uldid293 td_file1%l_def = td_file2%l_def347 file__copy_unit%i_ndim = td_file%i_ndim 348 file__copy_unit%i_natt = td_file%i_natt 349 file__copy_unit%i_uldid = td_file%i_uldid 350 file__copy_unit%l_def = td_file%l_def 294 351 295 352 ! copy dimension 296 td_file1%t_dim(:) = td_file2%t_dim(:)353 file__copy_unit%t_dim(:) = dim_copy(td_file%t_dim(:)) 297 354 298 355 ! copy attribute structure 299 IF( ASSOCIATED(td_file1%t_att) ) DEALLOCATE(td_file1%t_att) 300 IF( ASSOCIATED(td_file2%t_att) .AND. td_file1%i_natt > 0 )THEN 301 ALLOCATE( td_file1%t_att(td_file1%i_natt) ) 302 DO ji=1,td_file1%i_natt 303 td_file1%t_att(ji) = td_file2%t_att(ji) 356 IF( ASSOCIATED(file__copy_unit%t_att) )THEN 357 CALL att_clean(file__copy_unit%t_att(:)) 358 DEALLOCATE(file__copy_unit%t_att) 359 ENDIF 360 IF( ASSOCIATED(td_file%t_att) .AND. file__copy_unit%i_natt > 0 )THEN 361 ALLOCATE( file__copy_unit%t_att(file__copy_unit%i_natt) ) 362 DO ji=1,file__copy_unit%i_natt 363 tl_att = att_copy(td_file%t_att(ji)) 364 file__copy_unit%t_att(ji) = att_copy(tl_att) 304 365 ENDDO 305 366 ENDIF 306 367 368 ! clean 369 CALL att_clean(tl_att) 370 307 371 ! copy dimg variable 308 td_file1%i_recl = td_file2%i_recl309 td_file1%i_n0d = td_file2%i_n0d310 td_file1%i_n1d = td_file2%i_n1d311 td_file1%i_n2d = td_file2%i_n2d312 td_file1%i_n3d = td_file2%i_n3d313 td_file1%i_rhd = td_file2%i_rhd372 file__copy_unit%i_recl = td_file%i_recl 373 file__copy_unit%i_n0d = td_file%i_n0d 374 file__copy_unit%i_n1d = td_file%i_n1d 375 file__copy_unit%i_n2d = td_file%i_n2d 376 file__copy_unit%i_n3d = td_file%i_n3d 377 file__copy_unit%i_rhd = td_file%i_rhd 314 378 315 379 ! copy mpp variable 316 td_file1%i_pid = td_file2%i_pid 317 td_file1%i_impp = td_file2%i_impp 318 td_file1%i_jmpp = td_file2%i_jmpp 319 td_file1%i_lci = td_file2%i_lci 320 td_file1%i_lcj = td_file2%i_lcj 321 td_file1%i_ldi = td_file2%i_ldi 322 td_file1%i_ldj = td_file2%i_ldj 323 td_file1%i_lei = td_file2%i_lei 324 td_file1%i_lej = td_file2%i_lej 325 td_file1%l_ctr = td_file2%l_ctr 326 td_file1%l_use = td_file2%l_use 327 td_file1%i_iind = td_file2%i_iind 328 td_file1%i_jind = td_file2%i_jind 329 330 END SUBROUTINE file__copy_unit 331 !> @endcode 380 file__copy_unit%i_pid = td_file%i_pid 381 file__copy_unit%i_impp = td_file%i_impp 382 file__copy_unit%i_jmpp = td_file%i_jmpp 383 file__copy_unit%i_lci = td_file%i_lci 384 file__copy_unit%i_lcj = td_file%i_lcj 385 file__copy_unit%i_ldi = td_file%i_ldi 386 file__copy_unit%i_ldj = td_file%i_ldj 387 file__copy_unit%i_lei = td_file%i_lei 388 file__copy_unit%i_lej = td_file%i_lej 389 file__copy_unit%l_ctr = td_file%l_ctr 390 file__copy_unit%l_use = td_file%l_use 391 file__copy_unit%i_iind = td_file%i_iind 392 file__copy_unit%i_jind = td_file%i_jind 393 394 END FUNCTION file__copy_unit 332 395 !------------------------------------------------------------------- 333 396 !> @brief 334 !> This function copy file structure in another file 335 !> structure 397 !> This subroutine copy a array of file structure in another one 336 398 !> @details 337 !> file variable and attribute value are copied in a temporary table,399 !> file variable and attribute value are copied in a temporary array, 338 400 !> so input and output file structure value do not point on the same 339 401 !> "memory cell", and so on are independant. … … 341 403 !> @note new file is assume to be closed. 342 404 !> 405 !> @warning do not use on the output of a function who create or read an 406 !> structure (ex: tl_file=file_copy(file_init()) is forbidden). 407 !> This will create memory leaks. 343 408 !> @warning to avoid infinite loop, do not use any function inside 344 409 !> this subroutine 345 410 !> 346 411 !> @author J.Paul 347 !> - Nov, 2013- Initial Version 348 ! 349 !> @param[out] td_file1 : file structure 350 !> @param[in] td_file2 : file structure 351 !------------------------------------------------------------------- 352 !> @code 353 SUBROUTINE file__copy_tab( td_file1, td_file2 ) 412 !> @date November, 2013 - Initial Version 413 !> @date November, 2014 414 !> - use function instead of overload assignment operator 415 !> (to avoid memory leak) 416 ! 417 !> @param[in] td_file file structure 418 !> @return copy of input array of file structure 419 !------------------------------------------------------------------- 420 FUNCTION file__copy_arr( td_file ) 354 421 IMPLICIT NONE 355 422 ! Argument 356 TYPE(TFILE), DIMENSION(:) , INTENT(IN ) :: td_file2 357 TYPE(TFILE), DIMENSION(SIZE(td_file2(:))), INTENT( OUT) :: td_file1 423 TYPE(TFILE), DIMENSION(:) , INTENT(IN ) :: td_file 424 ! function 425 TYPE(TFILE), DIMENSION(SIZE(td_file(:))) :: file__copy_arr 358 426 359 427 ! loop indices … … 361 429 !---------------------------------------------------------------- 362 430 363 DO ji=1,SIZE(td_file 2(:))364 td_file1(ji)=td_file2(ji)431 DO ji=1,SIZE(td_file(:)) 432 file__copy_arr(ji)=file_copy(td_file(ji)) 365 433 ENDDO 366 434 367 END SUBROUTINE file__copy_tab368 ! > @endcode369 ! -------------------------------------------------------------------370 !> @ brief This function initialise file structure.<br/>435 END FUNCTION file__copy_arr 436 !------------------------------------------------------------------- 437 !> @brief This function initialize file structure.<br/> 438 !> @details 371 439 !> If cd_type is not specify, check if file name include '.nc' or 372 !> .'dimg'<br/> 440 !> '.dimg'<br/> 441 !> Optionally, you could specify:<br/> 442 !> - write mode (default .FALSE., ld_wrt) 443 !% - East-West overlap (id_ew) 444 !% - NEMO periodicity index (id_perio) 445 !% - NEMO pivot point index F(0),T(1) (id_pivot) 446 !> - grid type (default: 'ARAKAWA-C') 373 447 ! 374 448 !> @details 375 449 ! 376 450 !> @author J.Paul 377 !> - Nov, 2013- Initial Version 378 ! 379 !> @param[in] cd_file : file name 380 !> @param[in] cd_type : file type ('cdf', 'dimg') 381 !> @param[in] ld_wrt : write mode (default .FALSE.) 451 !> @date November, 2013 - Initial Version 452 ! 453 !> @param[in] cd_file file name 454 !> @param[in] cd_type file type ('cdf', 'dimg') 455 !> @param[in] ld_wrt write mode (default .FALSE.) 456 !> @param[in] id_ew east-west overlap 457 !> @param[in] id_perio NEMO periodicity index 458 !> @param[in] id_pivot NEMO pivot point index F(0),T(1) 459 !> @param[in] cd_grid grid type (default 'ARAKAWA-C') 382 460 !> @return file structure 383 461 !------------------------------------------------------------------- 384 !> @code385 462 TYPE(TFILE) FUNCTION file_init( cd_file, cd_type, ld_wrt, & 386 463 & id_ew, id_perio, id_pivot,& … … 397 474 398 475 ! local variable 399 TYPE(TATT) :: tl_att476 TYPE(TATT) :: tl_att 400 477 !---------------------------------------------------------------- 401 478 … … 404 481 405 482 file_init%c_name=TRIM(ADJUSTL(cd_file)) 406 CALL logger_trace("INIT: initialise file "//TRIM(file_init%c_name)) 407 408 ! create some global attribute 409 tl_att=att_init("Conventions","CF-1.5") 410 CALL file_add_att(file_init,tl_att) 411 412 tl_att=att_init("Grid",TRIM(file_init%c_grid)) 413 CALL file_add_att(file_init,tl_att) 483 CALL logger_trace("FILE INIT: initialize file "//TRIM(file_init%c_name)) 414 484 415 485 ! check type … … 421 491 file_init%c_type='dimg' 422 492 CASE DEFAULT 423 CALL logger_error( " INIT: can't initialise file "//&493 CALL logger_error( " FILE INIT: can't initialize file "//& 424 494 & TRIM(file_init%c_name)//" : type unknown " ) 425 495 END SELECT … … 427 497 file_init%c_type=TRIM(file_get_type(cd_file)) 428 498 ENDIF 499 500 ! create some global attribute 501 IF( TRIM(file_init%c_type) == 'cdf' )THEN 502 tl_att=att_init("Conventions","CF-1.5") 503 CALL file_add_att(file_init,tl_att) 504 ENDIF 505 506 tl_att=att_init("Grid",TRIM(file_init%c_grid)) 507 CALL file_add_att(file_init,tl_att) 429 508 430 509 IF( PRESENT(ld_wrt) )THEN … … 460 539 ENDIF 461 540 541 ! clean 542 CALL att_clean(tl_att) 543 462 544 END FUNCTION file_init 463 !> @endcode464 545 !------------------------------------------------------------------- 465 546 !> @brief … … 473 554 ! 474 555 !> @author J.Paul 475 !> - Nov, 2013- Initial Version476 ! 477 !> @param[in] cd_file :file name556 !> @date November, 2013 - Initial Version 557 ! 558 !> @param[in] cd_file file name 478 559 !> @return type of file 479 560 !------------------------------------------------------------------- 480 !> @code481 561 CHARACTER(LEN=lc) FUNCTION file_get_type(cd_file) 482 562 IMPLICIT NONE 483 563 ! Argument 484 564 CHARACTER(LEN=*), INTENT(IN) :: cd_file 565 485 566 !local variable 486 567 CHARACTER(LEN=lc) :: cl_suffix … … 490 571 SELECT CASE( TRIM(fct_lower(cl_suffix)) ) 491 572 CASE('.nc','.cdf') 492 CALL logger_debug(" GET TYPE: file "//TRIM(cd_file)//" is cdf")573 CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is cdf") 493 574 file_get_type='cdf' 494 575 CASE('.dimg') 495 CALL logger_debug(" GET TYPE: file "//TRIM(cd_file)//" is dimg" )576 CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is dimg" ) 496 577 file_get_type='dimg' 497 578 CASE DEFAULT 498 CALL logger_warn(" GET TYPE: type unknown, we assume file: "//&579 CALL logger_warn(" FILE GET TYPE: type unknown, we assume file: "//& 499 580 & TRIM(cd_file)//" is dimg ") 500 581 file_get_type='dimg' … … 502 583 503 584 END FUNCTION file_get_type 504 !> @endcode505 585 !------------------------------------------------------------------- 506 586 !> @brief This function check if variable dimension to be used … … 510 590 ! 511 591 !> @author J.Paul 512 !> - Nov, 2013- Initial Version 513 ! 514 !> @param[in] td_file : file structure 515 !> @param[in] td_var : variable structure 516 !> @return dimension of variable and file structure agree (or not) 517 !------------------------------------------------------------------- 518 !> @code 592 !> @date November, 2013 - Initial Version 593 ! 594 !> @param[in] td_file file structure 595 !> @param[in] td_var variable structure 596 !> @return true if dimension of variable and file structure agree 597 !------------------------------------------------------------------- 519 598 LOGICAL FUNCTION file_check_var_dim(td_file, td_var) 520 599 IMPLICIT NONE … … 524 603 525 604 ! local variable 526 INTEGER(i4) :: il_ndim 605 CHARACTER(LEN=lc) :: cl_dim 606 LOGICAL :: ll_error 607 LOGICAL :: ll_warn 608 609 INTEGER(i4) :: il_ind 527 610 528 611 ! loop indices … … 530 613 !---------------------------------------------------------------- 531 614 file_check_var_dim=.TRUE. 615 532 616 ! check used dimension 533 IF( ANY( td_var%t_dim(:)%l_use .AND. & 534 & td_var%t_dim(:)%i_len /= td_file%t_dim(:)%i_len) )THEN 617 ll_error=.FALSE. 618 ll_warn=.FALSE. 619 DO ji=1,ip_maxdim 620 il_ind=dim_get_index( td_file%t_dim(:), & 621 & TRIM(td_var%t_dim(ji)%c_name), & 622 & TRIM(td_var%t_dim(ji)%c_sname)) 623 IF( il_ind /= 0 )THEN 624 IF( td_var%t_dim(ji)%l_use .AND. & 625 & td_file%t_dim(il_ind)%l_use .AND. & 626 & td_var%t_dim(ji)%i_len /= td_file%t_dim(il_ind)%i_len )THEN 627 IF( INDEX( TRIM(td_var%c_axis), & 628 & TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN 629 ll_warn=.TRUE. 630 ELSE 631 ll_error=.TRUE. 632 ENDIF 633 ENDIF 634 ENDIF 635 ENDDO 636 637 IF( ll_error )THEN 638 639 cl_dim='(/' 640 DO ji = 1, td_file%i_ndim 641 IF( td_file%t_dim(ji)%l_use )THEN 642 cl_dim=TRIM(cl_dim)//& 643 & TRIM(fct_upper(td_file%t_dim(ji)%c_sname))//':'//& 644 & TRIM(fct_str(td_file%t_dim(ji)%i_len))//',' 645 ENDIF 646 ENDDO 647 cl_dim=TRIM(cl_dim)//'/)' 648 CALL logger_debug( " file dimension: "//TRIM(cl_dim) ) 649 650 cl_dim='(/' 651 DO ji = 1, td_var%i_ndim 652 IF( td_var%t_dim(ji)%l_use )THEN 653 cl_dim=TRIM(cl_dim)//& 654 & TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//& 655 & TRIM(fct_str(td_var%t_dim(ji)%i_len))//',' 656 ENDIF 657 ENDDO 658 cl_dim=TRIM(cl_dim)//'/)' 659 CALL logger_debug( " variable dimension: "//TRIM(cl_dim) ) 535 660 536 661 file_check_var_dim=.FALSE. … … 541 666 & " and file "//TRIM(td_file%c_name)) 542 667 543 544 CALL logger_debug( & 545 & " file dimension: "//TRIM(fct_str(td_file%i_ndim))//& 546 & " variable dimension: "//TRIM(fct_str(td_var%i_ndim)) ) 547 il_ndim=MIN(td_var%i_ndim, td_file%i_ndim ) 548 DO ji = 1, il_ndim 549 CALL logger_debug( & 550 & " FILE CHECK VAR DIM: for dimension "//& 551 & TRIM(td_file%t_dim(ji)%c_name)//& 552 & ", file length: "//& 553 & TRIM(fct_str(td_file%t_dim(ji)%i_len))//& 554 & ", variable length: "//& 555 & TRIM(fct_str(td_var%t_dim(ji)%i_len))//& 556 & ", variable used "//TRIM(fct_str(td_var%t_dim(ji)%l_use))) 557 ENDDO 668 ELSEIF( ll_warn )THEN 669 CALL logger_warn( & 670 & " FILE CHECK VAR DIM: variable and file dimension differ"//& 671 & " for variable "//TRIM(td_var%c_name)//& 672 & " and file "//TRIM(td_file%c_name)//". you should use"//& 673 & " var_check_dim to remove useless dimension.") 558 674 ELSE 559 IF( ANY( td_var%t_dim(:)%l_use .AND. & 560 & .NOT. td_file%t_dim(:)%l_use ) )THEN 561 562 CALL logger_info("FILE CHECK VAR DIM: variable use more dimension "//& 563 & " than file do until now. file dimension use will change.") 564 675 676 IF( td_var%i_ndim > td_file%i_ndim )THEN 677 CALL logger_info("FILE CHECK VAR DIM: variable "//& 678 & TRIM(td_var%c_name)//" use more dimension than file "//& 679 & TRIM(td_file%c_name)//" do until now.") 565 680 ENDIF 681 566 682 ENDIF 567 683 568 684 END FUNCTION file_check_var_dim 569 !> @endcode570 685 !------------------------------------------------------------------- 571 686 !> @brief This subroutine add a variable structure in a file structure.<br/> … … 577 692 ! 578 693 !> @author J.Paul 579 !> - Nov, 2013- Initial Version 580 ! 581 !> @param[inout] td_file : file structure 582 !> @param[in] td_var : variable structure 583 ! 584 !> @todo 585 !> - check dimension order 586 !> - voir pour ajouter variable avec plus de dim que deja presente dans fichier 587 !------------------------------------------------------------------- 588 !> @code 694 !> @date November, 2013 - Initial Version 695 !> @date September, 2014 696 !> - add dimension to file if need be 697 !> - do not reorder dimension from variable, before put in file 698 ! 699 !> @param[inout] td_file file structure 700 !> @param[in] td_var variable structure 701 !------------------------------------------------------------------- 589 702 SUBROUTINE file_add_var(td_file, td_var) 590 703 IMPLICIT NONE … … 596 709 ! local variable 597 710 INTEGER(i4) :: il_status 598 INTEGER(i4) :: il_varid 599 INTEGER(i4) :: il_rec 711 !INTEGER(i4) :: il_rec 600 712 INTEGER(i4) :: il_ind 601 713 … … 606 718 !---------------------------------------------------------------- 607 719 ! check if file opened 608 !IF( TRIM(td_file%c_name) == "unknown" )THEN609 720 IF( TRIM(td_file%c_name) == '' )THEN 610 721 611 CALL logger_error( " ADD VAR: structure file unknown" ) 612 CALL logger_debug( " ADD VAR: you should have used file_init before "//& 722 CALL logger_debug( " FILE ADD VAR: you should have used file_init before "//& 613 723 & "running file_add_var" ) 724 CALL logger_error( " FILE ADD VAR: structure file unknown" ) 614 725 615 726 ELSE … … 617 728 IF( TRIM(td_var%c_name) == '' .AND. & 618 729 & TRIM(td_var%c_stdname) == '' )THEN 619 CALL logger_error(" ADD VAR: variable not define ")730 CALL logger_error(" FILE ADD VAR: variable without name ") 620 731 ELSE 621 732 ! check if variable already in file structure 622 il_ varid=0733 il_ind=0 623 734 IF( ASSOCIATED(td_file%t_var) )THEN 624 il_ varid=var_get_id( td_file%t_var(:), td_var%c_name, &625 & td_var%c_stdname )735 il_ind=var_get_index( td_file%t_var(:), td_var%c_name, & 736 & td_var%c_stdname ) 626 737 ENDIF 627 628 IF( il_varid /= 0 )THEN 738 CALL logger_debug( & 739 & " FILE ADD VAR: ind "//TRIM(fct_str(il_ind)) ) 740 IF( il_ind /= 0 )THEN 629 741 630 742 CALL logger_error( & 631 & " ADD VAR: variable "//TRIM(td_var%c_name)//&743 & " FILE ADD VAR: variable "//TRIM(td_var%c_name)//& 632 744 & ", standard name "//TRIM(td_var%c_stdname)//& 633 745 & ", already in file "//TRIM(td_file%c_name) ) … … 641 753 ELSE 642 754 643 CALL logger_ info( &644 & " ADD VAR: add variable "//TRIM(td_var%c_name)//&755 CALL logger_debug( & 756 & " FILE ADD VAR: add variable "//TRIM(td_var%c_name)//& 645 757 & ", standard name "//TRIM(td_var%c_stdname)//& 646 758 & ", in file "//TRIM(td_file%c_name) ) 647 759 648 ! if none, force to use variable dimension649 IF( ALL( .NOT. td_file%t_dim(:)%l_use) )THEN650 td_file%t_dim(:)=td_var%t_dim(:)651 ENDIF652 653 760 ! check used dimension 654 761 IF( file_check_var_dim(td_file, td_var) )THEN 655 762 763 ! update dimension if need be 764 DO ji=1,ip_maxdim 765 IF( td_var%t_dim(ji)%l_use .AND. & 766 & .NOT. td_file%t_dim(ji)%l_use )THEN 767 CALL file_add_dim(td_file,td_var%t_dim(ji)) 768 ENDIF 769 ENDDO 770 771 ! get index of new variable 656 772 SELECT CASE(td_var%i_ndim) 657 773 CASE(0) 658 774 il_ind=td_file%i_n0d+1 659 il_rec=0775 !il_rec=0 660 776 CASE(1) 661 777 il_ind=td_file%i_n0d+td_file%i_n1d+1 662 il_rec=1778 !il_rec=1 663 779 CASE(2) 664 780 il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+1 665 il_rec=1781 !il_rec=1 666 782 CASE(3,4) 667 783 il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+td_file%i_n3d+1 668 il_rec=td_file%t_dim(3)%i_len784 !il_rec=td_file%t_dim(3)%i_len 669 785 END SELECT 670 786 … … 675 791 676 792 CALL logger_error( & 677 & " ADD VAR: not enough space to put variables "//&793 & " FILE ADD VAR: not enough space to put variables "//& 678 794 & "from "//TRIM(td_file%c_name)//& 679 795 & " in variable structure") … … 682 798 683 799 ! save temporary variable of file structure 684 tl_var(:)=td_file%t_var(:) 685 686 DEALLOCATE( td_file%t_var ) 800 tl_var(:)=var_copy(td_file%t_var(:)) 801 802 CALL var_clean( td_file%t_var(:) ) 803 DEALLOCATE(td_file%t_var) 687 804 ALLOCATE( td_file%t_var(td_file%i_nvar+1), & 688 805 & stat=il_status) … … 690 807 691 808 CALL logger_error( & 692 & " ADD VAR: not enough space to put variable "//&809 & " FILE ADD VAR: not enough space to put variable "//& 693 810 & "in file structure "//TRIM(td_file%c_name) ) 694 811 … … 697 814 ! copy variable in file before 698 815 ! variable with less than or equal dimension that new variable 699 td_file%t_var( 1:il_ind-1 ) = tl_var( 1:il_ind-1 ) 700 701 ! variable with greater dimension than new variable 702 td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = & 703 & tl_var( il_ind : td_file%i_nvar ) 704 705 ! update id 706 td_file%t_var( il_ind+1 : td_file%i_nvar+1 )%i_id = & 707 & tl_var( il_ind : td_file%i_nvar )%i_id + 1 708 709 ! update record index 710 td_file%t_var( il_ind+1 : td_file%i_nvar+1 )%i_rec = & 711 & tl_var( il_ind : td_file%i_nvar )%i_rec + il_rec 712 816 IF( il_ind > 1 )THEN 817 td_file%t_var( 1:il_ind-1 ) = var_copy(tl_var(1:il_ind-1)) 818 ENDIF 819 820 IF( il_ind < td_file%i_nvar+1 )THEN 821 ! variable with more dimension than new variable 822 td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = & 823 & var_copy( tl_var(il_ind : td_file%i_nvar) ) 824 ENDIF 825 826 ! clean 827 CALL var_clean(tl_var(:)) 713 828 DEALLOCATE(tl_var) 714 829 ENDIF … … 717 832 ! no variable in file structure 718 833 IF( ASSOCIATED(td_file%t_var) )THEN 834 CALL var_clean(td_file%t_var(:)) 719 835 DEALLOCATE(td_file%t_var) 720 836 ENDIF … … 723 839 724 840 CALL logger_error( & 725 & " ADD VAR: not enough space to put variable "//&841 & " FILE ADD VAR: not enough space to put variable "//& 726 842 & "in file structure "//TRIM(td_file%c_name) ) 727 843 … … 730 846 ENDIF 731 847 848 ! add new variable in array of variable 732 849 ALLOCATE( tl_var(1), stat=il_status ) 733 850 IF(il_status /= 0 )THEN 734 851 735 852 CALL logger_error( & 736 & " ADD VAR: not enough space to put variables from "//&853 & " FILE ADD VAR: not enough space to put variables from "//& 737 854 & TRIM(td_var%c_name)//" in variable structure") 738 855 739 856 ELSE 740 tl_var(1)= td_var857 tl_var(1)=var_copy(td_var) 741 858 742 859 ! update dimension name in new variable … … 744 861 745 862 ! add new variable 746 td_file%t_var(il_ind)= tl_var(1)863 td_file%t_var(il_ind)=var_copy(tl_var(1)) 747 864 748 865 ! update number of variable … … 755 872 CASE(2) 756 873 td_file%i_n2d=td_file%i_n2d+1 757 CASE(3 )874 CASE(3,4) 758 875 td_file%i_n3d=td_file%i_n3d+1 759 876 END SELECT 760 877 761 878 ! update variable id 762 td_file%t_var(il_ind)%i_id=il_ind 763 764 ! update record header index 765 td_file%i_rhd=td_file%i_rhd+il_rec 766 767 ! update record index 768 IF( il_ind > 1 )THEN 769 td_file%t_var(il_ind)%i_rec = & 770 & td_file%t_var(il_ind-1)%i_rec+il_rec 771 ELSE 772 td_file%t_var(il_ind)%i_rec = il_rec 773 ENDIF 879 td_file%t_var(il_ind)%i_id=var_get_unit(td_file%t_var(:)) 774 880 775 881 ! update dimension used … … 780 886 ENDIF 781 887 ENDDO 782 CALL dim_reorder(td_file%t_dim(:)) 888 783 889 ! update number of dimension 784 890 td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use) 785 891 786 DEALLOCATE( tl_var ) 892 ! clean 893 CALL var_clean( tl_var(:) ) 894 DEALLOCATE(tl_var) 787 895 ENDIF 788 789 896 ENDIF 790 897 ENDIF … … 793 900 794 901 END SUBROUTINE file_add_var 795 !> @endcode796 902 !------------------------------------------------------------------- 797 903 !> @brief This subroutine delete a variable structure 798 !> in file structure. 799 ! 800 !> @details 801 ! 802 !> @author J.Paul 803 !> - Nov, 2013- Initial Version 804 ! 805 !> @param[inout] td_file : file structure 806 !> @param[in] cd_name : variable name or standard name 807 !------------------------------------------------------------------- 808 !> @code 904 !> in file structure, given variable name or standard name. 905 ! 906 !> @author J.Paul 907 !> @date November, 2013 - Initial Version 908 !> @date February, 2015 909 !> - define local variable structure to avoid mistake with pointer 910 ! 911 !> @param[inout] td_file file structure 912 !> @param[in] cd_name variable name or standard name 913 !------------------------------------------------------------------- 809 914 SUBROUTINE file__del_var_name(td_file, cd_name ) 810 915 IMPLICIT NONE … … 815 920 816 921 ! local variable 817 INTEGER(i4) :: il_varid 922 INTEGER(i4) :: il_ind 923 TYPE(TVAR) :: tl_var 818 924 !---------------------------------------------------------------- 819 925 … … 821 927 IF( TRIM(td_file%c_name) == '' )THEN 822 928 823 CALL logger_error( " DEL VAR NAME: file structure unknown ")824 CALL logger_debug( " DEL VAR NAME: you should have used file_init before "//&929 CALL logger_error( " FILE DEL VAR NAME: file structure unknown ") 930 CALL logger_debug( " FILE DEL VAR NAME: you should have used file_init before "//& 825 931 & "running file_del_var" ) 826 932 … … 829 935 IF( td_file%i_nvar /= 0 )THEN 830 936 831 ! get the variable i d, in file variable structure832 il_ varid=0937 ! get the variable index, in file variable structure 938 il_ind=0 833 939 IF( ASSOCIATED(td_file%t_var) )THEN 834 il_ varid=var_get_id(td_file%t_var(:), cd_name )940 il_ind=var_get_index(td_file%t_var(:), cd_name ) 835 941 ENDIF 836 IF( il_varid /= 0 )THEN 942 943 IF( il_ind /= 0 )THEN 837 944 838 CALL file_del_var(td_file, td_file%t_var(il_varid)) 945 tl_var=var_copy(td_file%t_var(il_ind)) 946 CALL file_del_var(td_file, tl_var) 839 947 840 948 ELSE 841 949 842 CALL logger_ warn( &843 & " DEL VAR NAME: there is no variable with name or "//&950 CALL logger_debug( & 951 & " FILE DEL VAR NAME: there is no variable with name or "//& 844 952 & "standard name "//TRIM(cd_name)//" in file "//& 845 953 & TRIM(td_file%c_name)) … … 848 956 849 957 ELSE 850 CALL logger_debug( " DEL VAR NAME: no variable associated to file "//& 851 & TRIM(td_file%c_name) ) 958 CALL logger_debug( " FILE DEL VAR NAME: "//& 959 & "no variable associated to file "//& 960 & TRIM(td_file%c_name) ) 852 961 ENDIF 853 962 … … 855 964 856 965 END SUBROUTINE file__del_var_name 857 !> @endcode858 966 !------------------------------------------------------------------- 859 967 !> @brief This subroutine delete a variable structure 860 968 !> in file structure, given variable structure. 861 ! 862 !> @details 863 ! 864 !> @author J.Paul 865 !> - Nov, 2013- Initial Version 866 ! 867 !> @param[inout] td_file : file structure 868 !> @param[in] td_var : variable structure 869 !> @todo 870 !> - verifier pose pas de souci de ne pas modifier id 871 !------------------------------------------------------------------- 872 !> @code 969 !> 970 !> @author J.Paul 971 !> @date November, 2013 - Initial Version 972 !> 973 !> @param[inout] td_file file structure 974 !> @param[in] td_var variable structure 975 !------------------------------------------------------------------- 873 976 SUBROUTINE file__del_var_str(td_file, td_var) 874 977 IMPLICIT NONE … … 880 983 ! local variable 881 984 INTEGER(i4) :: il_status 882 INTEGER(i4) :: il_ varid985 INTEGER(i4) :: il_ind 883 986 INTEGER(i4) :: il_rec 884 987 TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var … … 889 992 890 993 ! check if file opened 891 !IF( TRIM(td_file%c_name) == "unknown" )THEN892 994 IF( TRIM(td_file%c_name) == '' )THEN 893 995 894 CALL logger_error( " DEL VAR: file structure unknown ")895 CALL logger_debug( " DEL VAR: you should have used file_init before"//&896 & "running file_del_var" )996 CALL logger_error( " FILE DEL VAR: file structure unknown ") 997 CALL logger_debug( " FILE DEL VAR: you should have used "//& 998 & "file_init before running file_del_var" ) 897 999 898 1000 ELSE 899 1001 900 ! check if variable already in file structure 901 il_varid=var_get_id(td_file%t_var(:), td_var%c_name, td_var%c_stdname ) 902 IF( il_varid == 0 )THEN 903 1002 ! check if variable is member of a file 1003 IF( td_var%l_file )THEN 1004 CALL logger_warn( & 1005 & " FILE DEL VAR: variable "//TRIM(td_var%c_name)//& 1006 & ", belong to file "//TRIM(td_file%c_name)//& 1007 & " and can not be removed.") 1008 ELSE 1009 ! check if variable already in file structure 1010 il_ind=0 1011 IF( ASSOCIATED(td_file%t_var) )THEN 1012 il_ind=var_get_index( td_file%t_var(:), td_var%c_name, & 1013 & td_var%c_stdname ) 1014 ENDIF 1015 1016 IF( il_ind == 0 )THEN 1017 1018 CALL logger_warn( "FILE DEL VAR: no variable "//& 1019 & TRIM(td_var%c_name)//", in file "//TRIM(td_file%c_name) ) 1020 1021 DO ji=1,td_file%i_nvar 1022 CALL logger_debug( "FILE DEL VAR: in file "//& 1023 & TRIM(td_file%t_var(ji)%c_name)//", standard name "//& 1024 & TRIM(td_file%t_var(ji)%c_stdname) ) 1025 ENDDO 1026 1027 ELSE 1028 1029 CALL logger_trace( "FILE DEL VAR: delete variable "//& 1030 & TRIM(td_var%c_name)//", from file "//TRIM(td_file%c_name) ) 1031 1032 ALLOCATE( tl_var(td_file%i_nvar-1), stat=il_status ) 1033 IF(il_status /= 0 )THEN 1034 1035 CALL logger_error( & 1036 & " FILE DEL VAR: not enough space to put variables from "//& 1037 & TRIM(td_file%c_name)//" in temporary variable structure") 1038 1039 ELSE 1040 1041 ! save temporary variable's file structure 1042 IF( il_ind > 1 )THEN 1043 tl_var(1:il_ind-1)=var_copy(td_file%t_var(1:il_ind-1)) 1044 ENDIF 1045 1046 IF( il_ind < td_file%i_nvar )THEN 1047 tl_var(il_ind:)=var_copy(td_file%t_var(il_ind+1:)) 1048 ENDIF 1049 1050 ! new number of variable in file 1051 td_file%i_nvar=td_file%i_nvar-1 1052 1053 SELECT CASE(td_var%i_ndim) 1054 CASE(0) 1055 td_file%i_n0d=td_file%i_n0d-1 1056 il_rec=0 1057 CASE(1) 1058 td_file%i_n1d=td_file%i_n1d-1 1059 il_rec=1 1060 CASE(2) 1061 td_file%i_n2d=td_file%i_n2d-1 1062 il_rec=1 1063 CASE(3,4) 1064 td_file%i_n3d=td_file%i_n3d-1 1065 il_rec=td_file%t_dim(3)%i_len 1066 END SELECT 1067 1068 CALL var_clean( td_file%t_var(:) ) 1069 DEALLOCATE(td_file%t_var) 1070 1071 IF( td_file%i_nvar > 0 )THEN 1072 ALLOCATE( td_file%t_var(td_file%i_nvar), stat=il_status ) 1073 IF(il_status /= 0 )THEN 1074 1075 CALL logger_error( " FILE DEL VAR: not enough space"//& 1076 & "to put variables in file structure "//& 1077 & TRIM(td_file%c_name) ) 1078 1079 ENDIF 1080 1081 ! copy attribute in file before 1082 td_file%t_var(:)=var_copy(tl_var(:)) 1083 1084 ! update dimension used 1085 td_file%t_dim(:)%l_use=.FALSE. 1086 DO ji=1,ip_maxdim 1087 IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN 1088 td_file%t_dim(ji)%l_use=.TRUE. 1089 ENDIF 1090 ENDDO 1091 1092 ! update number of dimension 1093 td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use) 1094 1095 ENDIF 1096 1097 ! clean 1098 CALL var_clean(tl_var(:)) 1099 DEALLOCATE(tl_var) 1100 1101 ENDIF 1102 ENDIF 1103 ENDIF 1104 ENDIF 1105 1106 END SUBROUTINE file__del_var_str 1107 !------------------------------------------------------------------- 1108 !> @brief This subroutine overwrite variable structure 1109 !> in file structure. 1110 ! 1111 !> @warning change variable id in file structure. 1112 ! 1113 !> @author J.Paul 1114 !> @date November, 2013 - Initial Version 1115 ! 1116 !> @param[inout] td_file file structure 1117 !> @param[in] td_var variable structure 1118 !------------------------------------------------------------------- 1119 SUBROUTINE file_move_var(td_file, td_var) 1120 IMPLICIT NONE 1121 1122 ! Argument 1123 TYPE(TFILE), INTENT(INOUT) :: td_file 1124 TYPE(TVAR), INTENT(IN) :: td_var 1125 1126 ! local variable 1127 TYPE(TVAR) :: tl_var 1128 !---------------------------------------------------------------- 1129 1130 ! copy variable 1131 tl_var=var_copy(td_var) 1132 1133 ! remove variable with same name or standard name 1134 CALL file_del_var(td_file, tl_var) 1135 1136 ! add new variable 1137 CALL file_add_var(td_file, tl_var) 1138 1139 ! clean 1140 CALL var_clean(tl_var) 1141 1142 END SUBROUTINE file_move_var 1143 !------------------------------------------------------------------- 1144 !> @brief This subroutine add a global attribute 1145 !> in a file structure.<br/> 1146 !> Do not overwrite, if attribute already in file structure. 1147 ! 1148 !> @author J.Paul 1149 !> @date November, 2013 - Initial Version 1150 ! 1151 !> @param[inout] td_file file structure 1152 !> @param[in] td_att attribute structure 1153 !------------------------------------------------------------------- 1154 SUBROUTINE file_add_att(td_file, td_att) 1155 IMPLICIT NONE 1156 1157 ! Argument 1158 TYPE(TFILE), INTENT(INOUT) :: td_file 1159 TYPE(TATT), INTENT(IN) :: td_att 1160 1161 ! local variable 1162 INTEGER(i4) :: il_status 1163 INTEGER(i4) :: il_ind 1164 TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att 1165 1166 ! loop indices 1167 INTEGER(i4) :: ji 1168 !---------------------------------------------------------------- 1169 1170 ! check if file opened 1171 IF( TRIM(td_file%c_name) == '' )THEN 1172 1173 CALL logger_error( " FILE ADD ATT: file structure unknown ") 1174 CALL logger_debug( " FILE ADD ATT: you should have used file_init before "//& 1175 & "running file_add_att" ) 1176 1177 ELSE 1178 1179 ! check if attribute already in file structure 1180 il_ind=0 1181 IF( ASSOCIATED(td_file%t_att) )THEN 1182 il_ind=att_get_index( td_file%t_att(:), td_att%c_name ) 1183 ENDIF 1184 1185 IF( il_ind /= 0 )THEN 1186 904 1187 CALL logger_error( & 905 & " DEL VAR: no variable "//TRIM(td_var%c_name)//&906 & ", in file "//TRIM(td_file%c_name) )907 908 DO ji=1,td_file%i_n var1188 & " FILE ADD ATT: attribute "//TRIM(td_att%c_name)//& 1189 & ", already in file "//TRIM(td_file%c_name) ) 1190 1191 DO ji=1,td_file%i_natt 909 1192 CALL logger_debug( & 910 & " DEL VAR: in file "//TRIM(td_file%t_var(ji)%c_name)//& 911 & ", standard name "//TRIM(td_file%t_var(ji)%c_stdname) ) 1193 & " FILE ADD ATT: in file "//TRIM(td_file%t_att(ji)%c_name) ) 912 1194 ENDDO 913 1195 … … 915 1197 916 1198 CALL logger_trace( & 917 & " DEL VAR: delete variable "//TRIM(td_var%c_name)//& 918 & ", from file "//TRIM(td_file%c_name) ) 919 920 ALLOCATE( tl_var(td_file%i_nvar-1), stat=il_status ) 921 IF(il_status /= 0 )THEN 922 923 CALL logger_error( & 924 & " DEL VAR: not enough space to put variables from "//& 925 & TRIM(td_file%c_name)//" in temporary variable structure") 926 927 ELSE 928 929 ! save temporary variable's file structure 930 tl_var(1:il_varid-1)=td_file%t_var(1:il_varid-1) 931 tl_var(il_varid:)=td_file%t_var(il_varid+1:) 932 933 ! new number of variable in file 934 td_file%i_nvar=td_file%i_nvar-1 935 936 SELECT CASE(td_var%i_ndim) 937 CASE(0) 938 td_file%i_n0d=td_file%i_n0d-1 939 il_rec=0 940 CASE(1) 941 td_file%i_n1d=td_file%i_n1d-1 942 il_rec=1 943 CASE(2) 944 td_file%i_n2d=td_file%i_n2d-1 945 il_rec=1 946 CASE(3,4) 947 td_file%i_n3d=td_file%i_n3d-1 948 il_rec=td_file%t_dim(3)%i_len 949 END SELECT 950 951 DEALLOCATE( td_file%t_var ) 952 953 IF( td_file%i_nvar > 0 )THEN 954 ALLOCATE( td_file%t_var(td_file%i_nvar), stat=il_status ) 955 IF(il_status /= 0 )THEN 956 957 CALL logger_error( & 958 & " DEL VAR: not enough space to put variables "//& 959 & "in file structure "//TRIM(td_file%c_name) ) 960 961 ENDIF 962 963 ! copy attribute in file before 964 td_file%t_var(:)=tl_var(:) 965 966 ! update record header index 967 td_file%i_rhd = td_file%i_rhd - il_rec 968 969 ! ! update id 970 ! td_file%t_var( il_varid : td_file%i_nvar )%i_id = & 971 ! & td_file%t_var( il_varid : td_file%i_nvar )%i_id - 1 972 973 ! update record index 974 td_file%t_var( il_varid : td_file%i_nvar )%i_rec = & 975 & td_file%t_var( il_varid : td_file%i_nvar )%i_rec - il_rec 976 977 ! update dimension used 978 td_file%t_dim(:)%l_use=.FALSE. 979 DO ji=1,ip_maxdim 980 IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN 981 td_file%t_dim(ji)%l_use=.TRUE. 982 ENDIF 983 ENDDO 984 CALL dim_reorder(td_file%t_dim(:)) 985 ! update number of dimension 986 td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use) 987 988 ENDIF 989 DEALLOCATE(tl_var) 990 991 ENDIF 992 ENDIF 993 ENDIF 994 995 END SUBROUTINE file__del_var_str 996 !> @endcode 997 !------------------------------------------------------------------- 998 !> @brief This subroutine overwrite variable structure 999 !> in file structure. 1000 ! 1001 !> @details 1002 ! 1003 !> @author J.Paul 1004 !> - Nov, 2013- Initial Version 1005 ! 1006 !> @param[inout] td_file : file structure 1007 !> @param[in] td_var : variable structure 1008 !> @todo 1009 !> - check independance td_var (cf move dim variable) 1010 !------------------------------------------------------------------- 1011 !> @code 1012 SUBROUTINE file_move_var(td_file, td_var) 1013 IMPLICIT NONE 1014 1015 ! Argument 1016 TYPE(TFILE), INTENT(INOUT) :: td_file 1017 TYPE(TVAR), INTENT(IN) :: td_var 1018 1019 ! local variable 1020 TYPE(TVAR) :: tl_var 1021 INTEGER(i4):: il_varid 1022 !---------------------------------------------------------------- 1023 1024 ! copy variable 1025 tl_var=td_var 1026 1027 IF( ASSOCIATED(td_file%t_var) )THEN 1028 il_varid=var_get_id(td_file%t_var(:),TRIM(tl_var%c_name)) 1029 IF( il_varid /= 0 )THEN 1030 ! remove variable with same name or standard name 1031 CALL file_del_var(td_file, tl_var) 1032 ENDIF 1033 ENDIF 1034 1035 ! add new variable 1036 CALL file_add_var(td_file, tl_var) 1037 1038 END SUBROUTINE file_move_var 1039 !> @endcode 1040 !------------------------------------------------------------------- 1041 !> @brief This subroutine add a global attribute 1042 !> in a file structure.<br/> 1043 !> Do not overwrite, if attribute already in file structure. 1044 ! 1045 !> @details 1046 ! 1047 !> @author J.Paul 1048 !> - Nov, 2013- Initial Version 1049 ! 1050 !> @param[inout] td_file : file structure 1051 !> @param[in] td_att : attribute structure 1052 !------------------------------------------------------------------- 1053 !> @code 1054 SUBROUTINE file_add_att(td_file, td_att) 1055 IMPLICIT NONE 1056 1057 ! Argument 1058 TYPE(TFILE), INTENT(INOUT) :: td_file 1059 TYPE(TATT), INTENT(IN) :: td_att 1060 1061 ! local variable 1062 INTEGER(i4) :: il_status 1063 INTEGER(i4) :: il_attid 1064 TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att 1065 1066 ! loop indices 1067 INTEGER(i4) :: ji 1068 !---------------------------------------------------------------- 1069 1070 ! check if file opened 1071 !IF( TRIM(td_file%c_name) == "unknown" )THEN 1072 IF( TRIM(td_file%c_name) == '' )THEN 1073 1074 CALL logger_error( " ADD ATT: file structure unknown ") 1075 CALL logger_debug( " ADD ATT: you should have used file_init before "//& 1076 & "running file_add_att" ) 1077 1078 ELSE 1079 1080 ! check if attribute already in file structure 1081 il_attid=0 1082 IF( ASSOCIATED(td_file%t_att) )THEN 1083 il_attid=att_get_id( td_file%t_att(:), td_att%c_name ) 1084 ENDIF 1085 1086 IF( il_attid /= 0 )THEN 1087 1088 CALL logger_error( & 1089 & " ADD ATT: attribute "//TRIM(td_att%c_name)//& 1090 & ", already in file "//TRIM(td_file%c_name) ) 1091 CALL logger_flush() 1092 1093 DO ji=1,td_file%i_natt 1094 CALL logger_debug( & 1095 & " ADD ATT: in file "//TRIM(td_file%t_att(ji)%c_name) ) 1096 ENDDO 1097 1098 ELSE 1099 1100 CALL logger_debug( & 1101 & " ADD ATT: add attribute "//TRIM(td_att%c_name)//& 1199 & " FILE ADD ATT: add attribute "//TRIM(td_att%c_name)//& 1102 1200 & ", in file "//TRIM(td_file%c_name) ) 1103 1201 … … 1108 1206 1109 1207 CALL logger_error( & 1110 & " ADD ATT: not enough space to put attributes from "//&1208 & " FILE ADD ATT: not enough space to put attributes from "//& 1111 1209 & TRIM(td_file%c_name)//" in temporary attribute structure") 1112 1210 … … 1114 1212 1115 1213 ! save temporary global attribute's file structure 1116 tl_att(:)=td_file%t_att(:) 1117 1118 DEALLOCATE( td_file%t_att ) 1214 tl_att(:)=att_copy(td_file%t_att(:)) 1215 1216 CALL att_clean( td_file%t_att(:) ) 1217 DEALLOCATE(td_file%t_att) 1119 1218 ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status ) 1120 1219 IF(il_status /= 0 )THEN 1121 1220 1122 1221 CALL logger_error( & 1123 & " ADD ATT: not enough space to put attributes "//&1222 & " FILE ADD ATT: not enough space to put attributes "//& 1124 1223 & "in file structure "//TRIM(td_file%c_name) ) 1125 1224 … … 1127 1226 1128 1227 ! copy attribute in file before 1129 td_file%t_att(1:td_file%i_natt)=tl_att(:) 1130 1228 td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:)) 1229 1230 ! clean 1231 CALL att_clean(tl_att(:)) 1131 1232 DEALLOCATE(tl_att) 1233 1132 1234 ENDIF 1133 1235 ELSE 1134 1236 ! no attribute in file structure 1135 1237 IF( ASSOCIATED(td_file%t_att) )THEN 1238 CALL att_clean(td_file%t_att(:)) 1136 1239 DEALLOCATE(td_file%t_att) 1137 1240 ENDIF 1138 CALL logger_debug(" natt "//TRIM(fct_str(td_file%i_natt)) ) 1241 1139 1242 ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status ) 1140 1243 IF(il_status /= 0 )THEN 1141 1244 1142 1245 CALL logger_error( & 1143 & " ADD ATT: not enough space to put attributes "//&1246 & " FILE ADD ATT: not enough space to put attributes "//& 1144 1247 & "in file structure "//TRIM(td_file%c_name) ) 1145 1248 1146 1249 ENDIF 1147 1250 ENDIF 1148 ! add new attributes 1149 td_file%t_att(td_file%i_natt+1)=td_att 1150 1151 ! update attributes id 1152 td_file%t_att(td_file%i_natt+1)%i_id=td_file%i_natt+1 1251 ! add new attribute 1252 td_file%t_att(td_file%i_natt+1)=att_copy(td_att) 1153 1253 1154 1254 ! update number of attribute … … 1158 1258 1159 1259 END SUBROUTINE file_add_att 1160 !> @endcode 1161 !------------------------------------------------------------------- 1162 !> @brief This subroutine delete a variable structure 1163 !> in file structure. 1164 ! 1165 !> @details 1166 ! 1167 !> @author J.Paul 1168 !> - Nov, 2013- Initial Version 1169 ! 1170 !> @param[inout] td_file : file structure 1171 !> @param[in] cd_name : variable name or standard name 1172 !------------------------------------------------------------------- 1173 !> @code 1260 !------------------------------------------------------------------- 1261 !> @brief This subroutine delete a global attribute structure 1262 !> in file structure, given attribute name. 1263 ! 1264 !> @author J.Paul 1265 !> @date November, 2013 - Initial Version 1266 !> @date February, 2015 1267 !> - define local attribute structure to avoid mistake 1268 !> with pointer 1269 ! 1270 !> @param[inout] td_file file structure 1271 !> @param[in] cd_name attribute name 1272 !------------------------------------------------------------------- 1174 1273 SUBROUTINE file__del_att_name(td_file, cd_name ) 1175 1274 IMPLICIT NONE … … 1180 1279 1181 1280 ! local variable 1182 INTEGER(i4) :: il_attid 1281 INTEGER(i4) :: il_ind 1282 TYPE(TATT) :: tl_att 1183 1283 !---------------------------------------------------------------- 1184 1284 … … 1186 1286 IF( TRIM(td_file%c_name) == '' )THEN 1187 1287 1188 CALL logger_error( " DEL ATT NAME: file structure unknown ")1189 CALL logger_debug( " DEL ATT NAME: you should have used file_init before "//&1190 & "running file_del_var" )1288 CALL logger_error( " FILE DEL ATT NAME: file structure unknown ") 1289 CALL logger_debug( " FILE DEL ATT NAME: you should have "//& 1290 & "used file_init before running file_del_att" ) 1191 1291 1192 1292 ELSE … … 1195 1295 1196 1296 ! get the variable id, in file variable structure 1197 il_ attid=01297 il_ind=0 1198 1298 IF( ASSOCIATED(td_file%t_att) )THEN 1199 il_ attid=att_get_id(td_file%t_att(:), cd_name )1299 il_ind=att_get_index(td_file%t_att(:), cd_name ) 1200 1300 ENDIF 1201 IF( il_attid /= 0 )THEN 1301 1302 IF( il_ind /= 0 )THEN 1202 1303 1203 CALL file_del_att(td_file, td_file%t_att(il_attid)) 1304 tl_att=att_copy(td_file%t_att(il_ind)) 1305 CALL file_del_att(td_file, tl_att) 1204 1306 1205 1307 ELSE 1206 1308 1207 CALL logger_ warn( &1208 & " DEL ATT NAME: there is no attribute with name "//&1309 CALL logger_debug( & 1310 & " FILE DEL ATT NAME: there is no attribute with name "//& 1209 1311 & TRIM(cd_name)//" in file "//TRIM(td_file%c_name)) 1210 1312 … … 1212 1314 1213 1315 ELSE 1214 CALL logger_debug( " DEL ATT NAME: no attribute associated to file "//&1215 & 1316 CALL logger_debug( " FILE DEL ATT NAME: no attribute "//& 1317 & "associated to file "//TRIM(td_file%c_name) ) 1216 1318 ENDIF 1217 1319 … … 1219 1321 1220 1322 END SUBROUTINE file__del_att_name 1221 !> @endcode1222 1323 !------------------------------------------------------------------- 1223 1324 !> @brief This subroutine delete a global attribute structure 1224 !> from file structure. 1225 ! 1226 !> @details 1227 ! 1228 !> @author J.Paul 1229 !> - Nov, 2013- Initial Version 1230 ! 1231 !> @param[inout] td_file : file structure 1232 !> @param[in] td_att : attribute structure 1233 !------------------------------------------------------------------- 1234 !> @code 1325 !> from file structure, given attribute structure. 1326 ! 1327 !> @author J.Paul 1328 !> @date November, 2013 - Initial Version 1329 ! 1330 !> @param[inout] td_file file structure 1331 !> @param[in] td_att attribute structure 1332 !------------------------------------------------------------------- 1235 1333 SUBROUTINE file__del_att_str(td_file, td_att) 1236 1334 IMPLICIT NONE … … 1242 1340 ! local variable 1243 1341 INTEGER(i4) :: il_status 1244 INTEGER(i4) :: il_ attid1342 INTEGER(i4) :: il_ind 1245 1343 TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att 1246 1344 1247 1345 ! loop indices 1248 INTEGER(i4) :: ji1249 1346 !---------------------------------------------------------------- 1250 1347 1251 1348 ! check if file opened 1252 !IF( TRIM(td_file%c_name) == "unknown" )THEN1253 1349 IF( TRIM(td_file%c_name) == '' )THEN 1254 1350 1255 CALL logger_error( " DEL ATT: file structure unknown ")1256 CALL logger_debug( " DEL ATT: you should have used file_init before"//&1257 & "running file_del_att" )1351 CALL logger_error( " FILE DEL ATT: file structure unknown ") 1352 CALL logger_debug( " FILE DEL ATT: you should have used "//& 1353 & "file_init before running file_del_att" ) 1258 1354 1259 1355 ELSE 1260 1356 1261 1357 ! check if attribute already in file structure 1262 il_ attid=01358 il_ind=0 1263 1359 IF( ASSOCIATED(td_file%t_att) )THEN 1264 il_ attid=att_get_id( td_file%t_att(:), td_att%c_name )1360 il_ind=att_get_index( td_file%t_att(:), td_att%c_name ) 1265 1361 ENDIF 1266 1362 1267 IF( il_ attid == 0 )THEN1363 IF( il_ind == 0 )THEN 1268 1364 1269 1365 CALL logger_error( & 1270 & " DEL ATT: no attribute "//TRIM(td_att%c_name)//&1366 & " FILE DEL ATT: no attribute "//TRIM(td_att%c_name)//& 1271 1367 & ", in file "//TRIM(td_file%c_name) ) 1272 1368 1273 1369 ELSE 1274 1370 1275 CALL logger_ debug( &1276 & " DEL ATT: del attribute "//TRIM(td_att%c_name)//&1371 CALL logger_trace( & 1372 & " FILE DEL ATT: del attribute "//TRIM(td_att%c_name)//& 1277 1373 & ", in file "//TRIM(td_file%c_name) ) 1278 1374 … … 1281 1377 1282 1378 CALL logger_error( & 1283 & " ADD ATT: not enough space to put attributes from "//&1379 & " FILE ADD ATT: not enough space to put attributes from "//& 1284 1380 & TRIM(td_file%c_name)//" in temporary attribute structure") 1285 1381 … … 1287 1383 1288 1384 ! save temporary global attribute's file structure 1289 tl_att(1:il_attid-1)=td_file%t_att(1:il_attid-1) 1290 tl_att(il_attid:)=td_file%t_att(il_attid+1:) 1291 1292 DEALLOCATE( td_file%t_att ) 1385 IF( il_ind > 1 )THEN 1386 tl_att(1:il_ind-1)=att_copy(td_file%t_att(1:il_ind-1)) 1387 ENDIF 1388 1389 IF( il_ind < td_file%i_natt )THEN 1390 tl_att(il_ind:)=att_copy(td_file%t_att(il_ind+1:)) 1391 ENDIF 1392 1393 CALL att_clean( td_file%t_att(:) ) 1394 DEALLOCATE(td_file%t_att) 1293 1395 1294 1396 ! new number of attribute in file … … 1299 1401 1300 1402 CALL logger_error( & 1301 & " ADD ATT: not enough space to put attributes "//&1403 & " FILE ADD ATT: not enough space to put attributes "//& 1302 1404 & "in file structure "//TRIM(td_file%c_name) ) 1303 1405 … … 1305 1407 1306 1408 ! copy attribute in file before 1307 td_file%t_att(1:td_file%i_natt)=tl_att(:) 1308 1309 ! update attribute id 1310 DO ji=1,td_file%i_natt 1311 td_file%t_att(ji)%i_id=ji 1312 ENDDO 1313 1409 td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:)) 1410 1411 ! clean 1412 CALL att_clean(tl_att(:)) 1314 1413 DEALLOCATE(tl_att) 1414 1315 1415 ENDIF 1316 1416 ENDIF … … 1318 1418 1319 1419 END SUBROUTINE file__del_att_str 1320 !> @endcode1321 1420 !------------------------------------------------------------------- 1322 1421 !> @brief This subroutine move a global attribute structure 1323 1422 !> from file structure. 1324 !> @note attribute id could be change 1325 ! 1326 !> @details 1327 ! 1328 !> @author J.Paul 1329 !> - Nov, 2013- Initial Version 1330 ! 1331 !> @param[inout] td_file : file structure 1332 !> @param[in] td_att : attribute structure 1333 !> @todo 1334 !------------------------------------------------------------------- 1335 !> @code 1423 !> @warning change attribute id in file structure. 1424 ! 1425 !> @author J.Paul 1426 !> @date November, 2013 - Initial Version 1427 ! 1428 !> @param[inout] td_file file structure 1429 !> @param[in] td_att attribute structure 1430 !------------------------------------------------------------------- 1336 1431 SUBROUTINE file_move_att(td_file, td_att) 1337 1432 IMPLICIT NONE … … 1343 1438 ! local variable 1344 1439 TYPE(TATT) :: tl_att 1345 INTEGER(i4) :: il_ attid1440 INTEGER(i4) :: il_ind 1346 1441 !---------------------------------------------------------------- 1347 1442 1348 1443 ! copy attribute 1349 tl_att= td_att1444 tl_att=att_copy(td_att) 1350 1445 1351 1446 IF( ASSOCIATED(td_file%t_att) )THEN 1352 il_ attid=att_get_id(td_file%t_att(:),TRIM(tl_att%c_name))1353 IF( il_ attid /= 0 )THEN1447 il_ind=att_get_index(td_file%t_att(:),TRIM(tl_att%c_name)) 1448 IF( il_ind /= 0 )THEN 1354 1449 ! remove attribute with same name 1355 1450 CALL file_del_att(td_file, tl_att) … … 1360 1455 CALL file_add_att(td_file, tl_att) 1361 1456 1457 ! clean 1458 CALL att_clean(tl_att) 1459 1362 1460 END SUBROUTINE file_move_att 1363 !> @endcode1364 1461 !------------------------------------------------------------------- 1365 1462 !> @brief This subroutine add a dimension structure in file … … 1367 1464 !> Do not overwrite, if dimension already in file structure. 1368 1465 ! 1369 !> @details 1370 ! 1371 !> @author J.Paul 1372 !> - Nov, 2013- Initial Version 1373 ! 1374 !> @param[inout] td_file : file structure 1375 !> @param[in] td_dim : dimension structure 1376 ! 1377 !> @todo 1378 !------------------------------------------------------------------- 1379 !> @code 1466 !> @author J.Paul 1467 !> @date November, 2013 - Initial Version 1468 !> @date September, 2014 1469 !> - do not reorder dimension, before put in file 1470 ! 1471 !> @param[inout] td_file file structure 1472 !> @param[in] td_dim dimension structure 1473 !------------------------------------------------------------------- 1380 1474 SUBROUTINE file_add_dim(td_file, td_dim) 1381 1475 IMPLICIT NONE 1382 1476 1383 1477 ! Argument 1384 TYPE(TFILE), INTENT(INOUT) :: td_file 1385 TYPE(TDIM), INTENT(IN) :: td_dim 1386 1387 ! local variable 1388 INTEGER(i4) :: il_dimid 1478 TYPE(TFILE) , INTENT(INOUT) :: td_file 1479 TYPE(TDIM) , INTENT(IN ) :: td_dim 1480 1481 ! local variable 1482 INTEGER(i4) :: il_ind 1483 1484 ! loop indices 1485 INTEGER(i4) :: ji 1389 1486 !---------------------------------------------------------------- 1390 1487 ! check if file opened 1391 !IF( TRIM(td_file%c_name) == "unknown" )THEN1392 1488 IF( TRIM(td_file%c_name) == '' )THEN 1393 1489 1394 CALL logger_error( " ADD DIM: file structure unknown ")1395 CALL logger_debug( " ADD DIM: you should have used file_init before"//&1396 & "running file_add_dim" )1490 CALL logger_error( " FILE ADD DIM: file structure unknown ") 1491 CALL logger_debug( " FILE ADD DIM: you should have used "//& 1492 & "file_init before running file_add_dim" ) 1397 1493 1398 1494 ELSE 1399 1495 1400 IF( td_file%i_ndim <= 4)THEN1496 IF( td_file%i_ndim <= ip_maxdim )THEN 1401 1497 1402 1498 ! check if dimension already in file structure 1403 il_dimid=dim_get_id(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname) 1404 IF( il_dimid /= 0 )THEN 1405 1406 CALL logger_warn("ADD DIM: dimension "//TRIM(td_dim%c_name)//& 1407 & ", short name "//TRIM(td_dim%c_sname)//& 1408 & ", already in file "//TRIM(td_file%c_name) ) 1409 1410 IF( td_file%t_dim(il_dimid)%i_len /= td_dim%i_len )THEN 1499 il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname) 1500 IF( il_ind /= 0 )THEN 1501 IF( td_file%t_dim(il_ind)%l_use )THEN 1411 1502 CALL logger_error( & 1412 & "ADD DIM: dimension "//TRIM(td_dim%c_name)//& 1413 & " already in file "//TRIM(td_file%c_name)//& 1414 & " differ from added dimension ") 1503 & "FILE ADD DIM: dimension "//TRIM(td_dim%c_name)//& 1504 & ", short name "//TRIM(td_dim%c_sname)//& 1505 & ", already used in file "//TRIM(td_file%c_name) ) 1506 ELSE 1507 ! replace dimension 1508 td_file%t_dim(il_ind)=dim_copy(td_dim) 1509 td_file%t_dim(il_ind)%i_id=il_ind 1510 td_file%t_dim(il_ind)%l_use=.TRUE. 1415 1511 ENDIF 1416 1417 1512 ELSE 1418 1419 CALL logger_debug( &1420 & " ADD DIM:add dimension "//TRIM(td_dim%c_name)//&1421 & ", short name "//TRIM(td_dim%c_sname)//&1422 & ", in file "//TRIM(td_file%c_name) )1423 1424 IF( td_file%i_ndim == 4 )THEN1513 IF( td_file%i_ndim == ip_maxdim )THEN 1514 CALL logger_error( & 1515 & "FILE ADD DIM: can not add dimension "//TRIM(td_dim%c_name)//& 1516 & ", short name "//TRIM(td_dim%c_sname)//& 1517 & ", in file "//TRIM(td_file%c_name)//". Already "//& 1518 & TRIM(fct_str(ip_maxdim))//" dimensions." ) 1519 ELSE 1425 1520 ! search empty dimension 1426 il_dimid=dim_get_void_id(td_file%t_dim(:),TRIM(td_dim%c_name), & 1427 & TRIM(td_dim%c_sname)) 1428 ! replace empty dimension 1429 td_file%t_dim(il_dimid)=td_dim 1430 td_file%t_dim(il_dimid)%i_id=il_dimid 1431 td_file%t_dim(il_dimid)%l_use=.TRUE. 1432 ELSE 1433 ! add new dimension 1434 il_dimid=dim_get_void_id(td_file%t_dim(:),TRIM(td_dim%c_name), & 1435 & TRIM(td_dim%c_sname)) 1436 td_file%t_dim(il_dimid)=td_dim 1437 td_file%t_dim(il_dimid)%i_id=td_file%i_ndim+1 1438 td_file%t_dim(il_dimid)%l_use=.TRUE. 1521 DO ji=1,ip_maxdim 1522 IF( td_file%t_dim(ji)%i_id == 0 )THEN 1523 il_ind=ji 1524 EXIT 1525 ENDIF 1526 ENDDO 1527 1528 ! add new dimension 1529 td_file%t_dim(il_ind)=dim_copy(td_dim) 1439 1530 ! update number of attribute 1440 1531 td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use) 1441 ENDIF 1442 1443 ! reorder dimension to ('x','y','z','t') 1444 CALL dim_reorder(td_file%t_dim) 1445 1532 1533 td_file%t_dim(il_ind)%i_id=td_file%i_ndim 1534 td_file%t_dim(il_ind)%l_use=.TRUE. 1535 ENDIF 1446 1536 ENDIF 1537 1447 1538 ELSE 1448 1539 CALL logger_error( & 1449 & " ADD DIM: too much dimension in file "//&1540 & " FILE ADD DIM: too much dimension in file "//& 1450 1541 & TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")") 1451 1542 ENDIF … … 1454 1545 1455 1546 END SUBROUTINE file_add_dim 1456 !> @endcode1457 1547 !------------------------------------------------------------------- 1458 1548 !> @brief This subroutine delete a dimension structure in file 1459 !> structure.<br/> 1460 ! 1461 !> @details 1462 ! 1463 !> @author J.Paul 1464 !> - Nov, 2013- Initial Version 1465 ! 1466 !> @param[inout] td_file : file structure 1467 !> @param[in] td_dim : dimension structure 1468 ! 1469 !> @todo 1470 !------------------------------------------------------------------- 1471 !> @code 1549 !> structure. 1550 !> 1551 !> @author J.Paul 1552 !> @date November, 2013 - Initial Version 1553 ! 1554 !> @param[inout] td_file file structure 1555 !> @param[in] td_dim dimension structure 1556 !------------------------------------------------------------------- 1472 1557 SUBROUTINE file_del_dim(td_file, td_dim) 1473 1558 IMPLICIT NONE 1474 1559 1475 1560 ! Argument 1476 TYPE(TFILE) , INTENT(INOUT) :: td_file1477 TYPE(TDIM) , INTENT(IN):: td_dim1561 TYPE(TFILE) , INTENT(INOUT) :: td_file 1562 TYPE(TDIM) , INTENT(IN ) :: td_dim 1478 1563 1479 1564 ! local variable 1480 1565 INTEGER(i4) :: il_status 1481 INTEGER(i4) :: il_dimid 1566 INTEGER(i4) :: il_ind 1567 1482 1568 TYPE(TDIM), DIMENSION(:), ALLOCATABLE :: tl_dim 1569 1570 ! loop indices 1571 INTEGER(i4) :: ji 1483 1572 !---------------------------------------------------------------- 1484 1573 ! check if file opened 1485 !IF( TRIM(td_file%c_name) == "unknown" )THEN1486 1574 IF( TRIM(td_file%c_name) == '' )THEN 1487 1575 1488 CALL logger_error( " DEL DIM: file structure unknown ")1489 CALL logger_debug( " DEL DIM: you should have used file_init before"//&1490 & "running file_del_dim" )1576 CALL logger_error( " FILE DEL DIM: file structure unknown ") 1577 CALL logger_debug( " FILE DEL DIM: you should have used "//& 1578 & "file_init before running file_del_dim" ) 1491 1579 1492 1580 ELSE 1493 1581 1494 IF( td_file%i_ndim <= 4 )THEN 1495 1496 ! check if dimension already in file structure 1497 il_dimid=dim_get_id(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname) 1498 IF( il_dimid == 0 )THEN 1582 ! check if dimension already in file structure 1583 il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname) 1584 IF( il_ind == 0 )THEN 1585 1586 CALL logger_error( & 1587 & "FILE DEL DIM: no dimension "//TRIM(td_dim%c_name)//& 1588 & ", short name "//TRIM(td_dim%c_sname)//& 1589 & ", in file "//TRIM(td_file%c_name) ) 1590 1591 ELSE 1592 ALLOCATE( tl_dim(td_file%i_ndim-1), stat=il_status ) 1593 IF(il_status /= 0 )THEN 1499 1594 1500 1595 CALL logger_error( & 1501 & " DEL DIM: no dimension "//TRIM(td_dim%c_name)//& 1502 & ", short name "//TRIM(td_dim%c_sname)//& 1503 & ", in file "//TRIM(td_file%c_name) ) 1504 1505 ELSE 1506 1507 CALL logger_debug( & 1508 & " DEL DIM: delete dimension "//TRIM(td_dim%c_name)//& 1509 & ", short name "//TRIM(td_dim%c_sname)//& 1510 & ", in file "//TRIM(td_file%c_name) ) 1511 1512 IF( td_file%i_ndim == 4 )THEN 1513 ALLOCATE( tl_dim(1), stat=il_status ) 1514 IF(il_status /= 0 )THEN 1515 CALL logger_error( & 1516 & " DEL DIM: not enough space to put dimensions from "//& 1517 & TRIM(td_file%c_name)//" in temporary dimension structure") 1518 ELSE 1519 ! replace dimension by empty one 1520 td_file%t_dim(il_dimid)=tl_dim(1) 1521 ENDIF 1522 DEALLOCATE(tl_dim) 1523 ELSE 1524 ! 1525 !ALLOCATE( tl_dim(td_file%i_ndim), stat=il_status ) 1526 ALLOCATE( tl_dim(ip_maxdim), stat=il_status ) 1527 IF(il_status /= 0 )THEN 1528 1529 CALL logger_error( & 1530 & " DEL DIM: not enough space to put dimensions from "//& 1531 & TRIM(td_file%c_name)//" in temporary dimension structure") 1532 1533 ELSE 1534 1535 print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" 1536 print *,'il_dimid '//TRIM(fct_str(il_dimid)) 1537 CALL dim_print(td_file%t_dim(:)) 1538 ! save temporary dimension's file structure 1539 tl_dim( 1 : il_dimid-1 ) = td_file%t_dim( 1 : il_dimid-1 ) 1540 !tl_dim( il_dimid : td_file%i_ndim-1 ) = & 1541 !& td_file%t_dim( il_dimid+1 : td_file%i_ndim ) 1542 tl_dim( il_dimid : ip_maxdim-1 ) = & 1543 & td_file%t_dim( il_dimid+1 : ip_maxdim ) 1544 print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" 1545 CALL dim_print(tl_dim(:)) 1546 1547 ! copy dimension in file, except one 1548 !td_file%t_dim(1:td_file%i_ndim)=tl_dim(:) 1549 td_file%t_dim(:)=tl_dim(:) 1550 print *,"<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" 1551 CALL dim_print(td_file%t_dim(:)) 1552 1553 ! update number of dimension 1554 td_file%i_ndim=td_file%i_ndim-1 1555 1556 ENDIF 1557 ENDIF 1558 1559 ! reorder dimension to ('x','y','z','t') 1560 CALL dim_reorder(td_file%t_dim) 1561 1596 & "FILE DEL DIM: not enough space to put dimensions from "//& 1597 & TRIM(td_file%c_name)//" in temporary dimension structure") 1598 1599 ELSE 1600 ! save temporary dimension's mpp structure 1601 tl_dim( 1 : il_ind-1 ) = dim_copy(td_file%t_dim(1 : il_ind-1)) 1602 tl_dim( il_ind : td_file%i_ndim-1 ) = & 1603 & dim_copy(td_file%t_dim(il_ind+1 : td_file%i_ndim)) 1604 1605 ! remove dimension from file 1606 CALL dim_clean(td_file%t_dim(:)) 1607 ! copy dimension in file, except one 1608 td_file%t_dim(1:td_file%i_ndim)=dim_copy(tl_dim(:)) 1609 1610 ! update number of dimension 1611 td_file%i_ndim=td_file%i_ndim-1 1612 1613 ! update dimension id 1614 DO ji=1,td_file%i_ndim 1615 td_file%t_dim(ji)%i_id=ji 1616 ENDDO 1617 1618 ! clean 1619 CALL dim_clean(tl_dim(:)) 1620 DEALLOCATE(tl_dim) 1562 1621 ENDIF 1563 ELSE1564 CALL logger_error( &1565 & " DEL DIM: too much dimension in file "//&1566 & TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")")1567 1622 ENDIF 1568 1569 1623 ENDIF 1570 1624 1571 1625 END SUBROUTINE file_del_dim 1572 !> @endcode1573 1626 !------------------------------------------------------------------- 1574 1627 !> @brief This subroutine move a dimension structure 1575 1628 !> in file structure. 1576 !> @warning dimension order Nov have changed 1577 ! 1578 !> @details 1579 ! 1580 !> @author J.Paul 1581 !> - Nov, 2013- Initial Version 1582 ! 1583 !> @param[inout] td_file : file structure 1584 !> @param[in] td_dim : dimension structure 1585 !> @todo 1586 !------------------------------------------------------------------- 1587 !> @code 1629 !> @warning change dimension order in file structure. 1630 ! 1631 !> @author J.Paul 1632 !> @date November, 2013 - Initial Version 1633 ! 1634 !> @param[inout] td_file file structure 1635 !> @param[in] td_dim dimension structure 1636 !------------------------------------------------------------------- 1588 1637 SUBROUTINE file_move_dim(td_file, td_dim) 1589 1638 IMPLICIT NONE 1590 1639 1591 1640 ! Argument 1592 TYPE(TFILE) , INTENT(INOUT) :: td_file1593 TYPE(TDIM) , INTENT(IN):: td_dim1594 1595 ! local variable 1596 TYPE(TDIM) :: tl_dim1641 TYPE(TFILE) , INTENT(INOUT) :: td_file 1642 TYPE(TDIM) , INTENT(IN ) :: td_dim 1643 1644 ! local variable 1645 INTEGER(i4) :: il_ind 1597 1646 INTEGER(i4) :: il_dimid 1598 1647 !---------------------------------------------------------------- 1599 1600 ! copy dimension 1601 tl_dim=td_dim 1602 1603 il_dimid=dim_get_id(td_file%t_dim(:), TRIM(td_dim%c_name), & 1604 & TRIM(td_dim%c_sname)) 1605 IF( il_dimid /= 0 )THEN 1606 ! remove dimension with same name 1607 CALL file_del_dim(td_file, tl_dim) 1608 ENDIF 1609 1610 ! add new dimension 1611 CALL file_add_dim(td_file, tl_dim) 1648 IF( td_file%i_ndim <= ip_maxdim )THEN 1649 1650 ! check if dimension already in mpp structure 1651 il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname) 1652 IF( il_ind /= 0 )THEN 1653 1654 il_dimid=td_file%t_dim(il_ind)%i_id 1655 ! replace dimension 1656 td_file%t_dim(il_ind)=dim_copy(td_dim) 1657 td_file%t_dim(il_ind)%i_id=il_dimid 1658 td_file%t_dim(il_ind)%l_use=.TRUE. 1659 1660 ELSE 1661 CALL file_add_dim(td_file, td_dim) 1662 ENDIF 1663 1664 ELSE 1665 CALL logger_error( & 1666 & "FILE MOVE DIM: too much dimension in mpp "//& 1667 & TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")") 1668 ENDIF 1612 1669 1613 1670 END SUBROUTINE file_move_dim 1614 !> @endcode1615 1671 !------------------------------------------------------------------- 1616 1672 !> @brief This subroutine print some information about file strucutre. 1617 1673 ! 1618 1674 !> @author J.Paul 1619 !> - Nov, 2013- Initial Version 1620 ! 1621 !> @param[in] td_file : file structure 1622 !------------------------------------------------------------------- 1623 !> @code 1675 !> @date November, 2013 - Initial Version 1676 ! 1677 !> @param[in] td_file file structure 1678 !------------------------------------------------------------------- 1624 1679 SUBROUTINE file_print(td_file) 1625 1680 IMPLICIT NONE … … 1683 1738 WRITE(*,'(/a)') " File variable" 1684 1739 DO ji=1,td_file%i_nvar 1685 CALL var_print(td_file%t_var(ji) )!,.FALSE.)1740 CALL var_print(td_file%t_var(ji),.FALSE.) 1686 1741 ENDDO 1687 1742 ENDIF 1688 1743 1689 1744 END SUBROUTINE file_print 1690 !> @endcode1691 1745 !------------------------------------------------------------------- 1692 1746 !> @brief This function get suffix of file name. 1693 1747 !> @details 1694 1748 !> we assume suffix is define as alphanumeric character following the 1695 !> last '.' in file name 1749 !> last '.' in file name.<br/> 1696 1750 !> If no suffix is found, return empty character. 1697 1751 ! 1698 1752 !> @author J.Paul 1699 !> - Nov, 2013- Initial Version1700 ! 1701 !> @param[in] cd_file :file structure1753 !> @date November, 2013 - Initial Version 1754 ! 1755 !> @param[in] cd_file file structure 1702 1756 !> @return suffix 1703 1757 !------------------------------------------------------------------- 1704 !> @code1705 1758 CHARACTER(LEN=lc) FUNCTION file__get_suffix(cd_file) 1706 1759 IMPLICIT NONE … … 1713 1766 !---------------------------------------------------------------- 1714 1767 1715 CALL logger_trace( " GET SUFFIX: look for suffix in file name "//&1768 CALL logger_trace( "FILE GET SUFFIX: look for suffix in file name "//& 1716 1769 & TRIM(cd_file) ) 1717 1770 … … 1721 1774 READ( cd_file(il_ind:),'(a)' ) file__get_suffix 1722 1775 1723 IF( fct_is_num(file__get_suffix ) )THEN1776 IF( fct_is_num(file__get_suffix(2:)) )THEN 1724 1777 file__get_suffix='' 1725 1778 ENDIF … … 1730 1783 1731 1784 END FUNCTION file__get_suffix 1732 !> @endcode1733 1785 !------------------------------------------------------------------- 1734 1786 !> @brief This function get number in file name without suffix. 1735 1787 !> @details 1736 1788 !> Actually it get the number following the last separator. 1737 !> separator could be '.' or '_' 1738 ! 1739 !> @author J.Paul 1740 !> - Nov, 2013- Initial Version 1741 ! 1742 !> @param[in] cd_file : file name (without suffix) 1743 !> @return file structure 1744 !------------------------------------------------------------------- 1745 !> @code 1789 !> separator could be '.' or '_'. 1790 ! 1791 !> @author J.Paul 1792 !> @date November, 2013 - Initial Version 1793 !> @date February, 2015 1794 !> - add case to not return date (yyyymmdd) at the end of filename 1795 !> @date February, 2015 1796 !> - add case to not return release number 1797 !> we assume release number only on one digit (ex : file_v3.5.nc) 1798 ! 1799 !> @param[in] cd_file file name (without suffix) 1800 !> @return character file number. 1801 !------------------------------------------------------------------- 1746 1802 CHARACTER(LEN=lc) FUNCTION file__get_number(cd_file) 1747 1803 IMPLICIT NONE … … 1760 1816 ! get number position in file name 1761 1817 il_indmax=0 1762 DO ji=1,i g_nsep1763 il_ind=INDEX(TRIM(cd_file),TRIM(c g_sep(ji)),BACK=.TRUE.)1818 DO ji=1,ip_nsep 1819 il_ind=INDEX(TRIM(cd_file),TRIM(cp_sep(ji)),BACK=.TRUE.) 1764 1820 IF( il_ind > il_indmax )THEN 1765 1821 il_indmax=il_ind … … 1773 1829 IF( .NOT. fct_is_num(file__get_number(2:)) )THEN 1774 1830 file__get_number='' 1831 ELSEIF( LEN(TRIM(file__get_number))-1 == 8 )THEN 1832 ! date case yyyymmdd 1833 file__get_number='' 1834 ELSEIF( LEN(TRIM(file__get_number))-1 == 1 )THEN 1835 ! release number case 1836 file__get_number='' 1775 1837 ENDIF 1776 1838 ELSE … … 1779 1841 1780 1842 END FUNCTION file__get_number 1781 !> @endcode 1782 !------------------------------------------------------------------- 1783 !> @brief This function rename file name. 1843 !------------------------------------------------------------------- 1844 !> @brief This function rename file name, given processor number. 1784 1845 !> @details 1785 1846 !> If no processor number is given, return file name without number … … 1787 1848 ! 1788 1849 !> @author J.Paul 1789 !> - Nov, 2013- Initial Version 1790 ! 1791 !> @param[in] td_file : file structure 1792 !> @param[in] id_num : processor number (start to 1) 1793 !> @return file structure 1794 !------------------------------------------------------------------- 1795 !> @code 1850 !> @date November, 2013 - Initial Version 1851 ! 1852 !> @param[in] td_file file structure 1853 !> @param[in] id_num processor number (start to 1) 1854 !> @return file name 1855 !------------------------------------------------------------------- 1796 1856 CHARACTER(LEN=lc) FUNCTION file__rename_char(cd_file, id_num) 1797 1857 IMPLICIT NONE … … 1841 1901 WRITE(file__rename_char,'(a,a)') TRIM(cl_base),TRIM(cl_suffix) 1842 1902 ENDIF 1843 CALL logger_trace(" RENAME : "//TRIM(file__rename_char))1903 CALL logger_trace(" FILE RENAME : "//TRIM(file__rename_char)) 1844 1904 1845 1905 END FUNCTION file__rename_char 1846 !> @endcode1847 1906 !------------------------------------------------------------------- 1848 1907 !> @brief This function rename file name, given file structure. … … 1852 1911 ! 1853 1912 !> @author J.Paul 1854 !> - Nov, 2013- Initial Version1855 ! 1856 !> @param[in] td_file :file structure1857 !> @param[in] id_num :processor number (start to 1)1913 !> @date November, 2013 - Initial Version 1914 ! 1915 !> @param[in] td_file file structure 1916 !> @param[in] id_num processor number (start to 1) 1858 1917 !> @return file structure 1859 1918 !------------------------------------------------------------------- 1860 !> @code1861 1919 TYPE(TFILE) FUNCTION file__rename_str(td_file, id_num) 1862 1920 IMPLICIT NONE … … 1876 1934 1877 1935 END FUNCTION file__rename_str 1878 !> @endcode1879 1936 !------------------------------------------------------------------- 1880 1937 !> @brief This function add suffix to file name. 1881 1938 ! 1882 1939 !> @author J.Paul 1883 !> - Nov, 2013- Initial Version 1884 ! 1885 !> @param[in] td_file : file structure 1886 !> @return file structure 1887 !------------------------------------------------------------------- 1888 !> @code 1940 !> @date November, 2013 - Initial Version 1941 ! 1942 !> @param[in] td_file file structure 1943 !> @return file name 1944 !------------------------------------------------------------------- 1889 1945 CHARACTER(LEN=lc) FUNCTION file_add_suffix(cd_file, cd_type) 1890 1946 IMPLICIT NONE … … 1918 1974 ENDIF 1919 1975 CASE DEFAULT 1920 CALL logger_error( " ADD SUFFIX: type unknown "//TRIM(cd_type))1976 CALL logger_error(" FILE ADD SUFFIX: type unknown "//TRIM(cd_type)) 1921 1977 END SELECT 1922 1978 1923 1979 END FUNCTION file_add_suffix 1924 !> @endcode1925 1980 !------------------------------------------------------------------- 1926 1981 !> @brief 1927 !> This subroutine clean mpp strcuture. 1928 ! 1929 !> @author J.Paul 1930 !> @date Nov, 2013 1931 ! 1932 !> @param[inout] td_mpp : mpp strcuture 1933 !------------------------------------------------------------------- 1934 !> @code 1935 SUBROUTINE file_clean( td_file ) 1982 !> This subroutine clean file strcuture. 1983 ! 1984 !> @author J.Paul 1985 !> @date November, 2013 - Inital version 1986 ! 1987 !> @param[inout] td_file file strcuture 1988 !------------------------------------------------------------------- 1989 SUBROUTINE file__clean_unit( td_file ) 1936 1990 IMPLICIT NONE 1937 1991 ! Argument … … 1942 1996 1943 1997 ! loop indices 1944 INTEGER(i4) :: ji 1945 !---------------------------------------------------------------- 1946 1947 CALL logger_info( & 1948 & " CLEAN: reset file "//TRIM(td_file%c_name) ) 1998 !---------------------------------------------------------------- 1999 2000 CALL logger_trace( & 2001 & " FILE CLEAN: reset file "//TRIM(td_file%c_name) ) 1949 2002 1950 2003 ! del attribute 1951 2004 IF( ASSOCIATED( td_file%t_att ) )THEN 1952 DO ji=td_file%i_natt,1,-1 1953 CALL att_clean( td_file%t_att(ji) ) 1954 ENDDO 1955 DEALLOCATE( td_file%t_att ) 2005 CALL att_clean( td_file%t_att(:) ) 2006 DEALLOCATE(td_file%t_att) 1956 2007 ENDIF 1957 2008 1958 2009 ! del dimension 1959 2010 IF( td_file%i_ndim /= 0 )THEN 1960 DO ji=td_file%i_ndim,1,-1 1961 CALL dim_clean( td_file%t_dim(ji) ) 1962 ENDDO 2011 CALL dim_clean( td_file%t_dim(:) ) 1963 2012 ENDIF 1964 2013 1965 2014 ! del variable 1966 2015 IF( ASSOCIATED( td_file%t_var ) )THEN 1967 DO ji=td_file%i_nvar,1,-1 1968 CALL var_clean( td_file%t_var(ji) ) 1969 ENDDO 1970 DEALLOCATE( td_file%t_var ) 2016 CALL var_clean( td_file%t_var(:) ) 2017 DEALLOCATE(td_file%t_var) 1971 2018 ENDIF 1972 2019 1973 2020 ! replace by empty structure 1974 td_file=tl_file 1975 1976 END SUBROUTINE file_clean 1977 !> @endcode 1978 !------------------------------------------------------------------- 1979 !> @brief This function return the file id, in a table of file 1980 !> structure, given file name 1981 ! 1982 !> @author J.Paul 1983 !> - Nov, 2013- Initial Version 1984 ! 1985 !> @param[in] td_file : table of file structure 1986 !> @param[in] cd_name : file name 1987 !> @return file id in table of file structure (0 if not found) 1988 !------------------------------------------------------------------- 1989 !> @code 2021 td_file=file_copy(tl_file) 2022 2023 END SUBROUTINE file__clean_unit 2024 !------------------------------------------------------------------- 2025 !> @brief 2026 !> This subroutine clean file array of file strcuture. 2027 ! 2028 !> @author J.Paul 2029 !> @date Marsh, 2014 - Inital version 2030 ! 2031 !> @param[inout] td_file array file strcuture 2032 !------------------------------------------------------------------- 2033 SUBROUTINE file__clean_arr( td_file ) 2034 IMPLICIT NONE 2035 ! Argument 2036 TYPE(TFILE), DIMENSION(:), INTENT(INOUT) :: td_file 2037 2038 ! local variable 2039 ! loop indices 2040 INTEGER(i4) :: ji 2041 !---------------------------------------------------------------- 2042 2043 DO ji=SIZE(td_file(:)),1,-1 2044 CALL file_clean(td_file(ji)) 2045 ENDDO 2046 2047 END SUBROUTINE file__clean_arr 2048 !------------------------------------------------------------------- 2049 !> @brief This function return the file id, in a array of file 2050 !> structure, given file name. 2051 ! 2052 !> @author J.Paul 2053 !> @date November, 2013 - Initial Version 2054 ! 2055 !> @param[in] td_file array of file structure 2056 !> @param[in] cd_name file name 2057 !> @return file id in array of file structure (0 if not found) 2058 !------------------------------------------------------------------- 1990 2059 INTEGER(i4) FUNCTION file_get_id(td_file, cd_name) 1991 2060 IMPLICIT NONE … … 2003 2072 il_size=SIZE(td_file(:)) 2004 2073 2005 ! check if file is in tableof file structure2074 ! check if file is in array of file structure 2006 2075 DO ji=1,il_size 2007 2076 ! look for file name 2008 CALL logger_debug(" cd_name "//TRIM(fct_lower(cd_name)) )2009 2077 IF( fct_lower(td_file(ji)%c_name) == fct_lower(cd_name) )THEN 2010 2078 2011 file_get_id= ji2079 file_get_id=td_file(ji)%i_id 2012 2080 EXIT 2013 2081 … … 2016 2084 2017 2085 END FUNCTION file_get_id 2018 !> @endcode 2086 !------------------------------------------------------------------- 2087 !> @brief 2088 !> This function get the next unused unit in array of file structure. 2089 !> 2090 !> @author J.Paul 2091 !> @date September, 2014 - Initial Version 2092 ! 2093 !> @param[in] td_file array of file 2094 !------------------------------------------------------------------- 2095 FUNCTION file_get_unit(td_file) 2096 IMPLICIT NONE 2097 ! Argument 2098 TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_file 2099 2100 ! function 2101 INTEGER(i4) :: file_get_unit 2102 2103 ! local variable 2104 ! loop indices 2105 !---------------------------------------------------------------- 2106 2107 file_get_unit=MAXVAL(td_file(:)%i_id)+1 2108 2109 END FUNCTION file_get_unit 2019 2110 END MODULE file 2020 2111
Note: See TracChangeset
for help on using the changeset viewer.
