- 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/file.f90
r4213 r5240 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 - Fix memory leaks bug 105 141 !> 106 142 !> @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 143 !---------------------------------------------------------------------- 111 144 MODULE file … … 113 146 USE global ! global variable 114 147 USE fct ! basic useful function 115 USE logger 148 USE logger ! log file manager 116 149 USE dim ! dimension manager 117 150 USE att ! attribute manager 118 151 USE var ! variable manager 119 152 IMPLICIT NONE 120 PRIVATE121 153 ! NOTE_avoid_public_variables_if_possible 122 154 123 155 ! type and variable 124 PUBLIC :: TFILE ! file structure156 PUBLIC :: TFILE !< file structure 125 157 126 158 ! 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 structure159 PUBLIC :: file_copy !< copy file structure 160 PUBLIC :: file_print !< print information about file structure 161 PUBLIC :: file_clean !< clean file structure 162 PUBLIC :: file_init !< initialize file structure 163 PUBLIC :: file_add_att !< add one attribute structure in file structure 164 PUBLIC :: file_add_var !< add one variable structure in file structure 165 PUBLIC :: file_add_dim !< add one dimension strucutre in file structure 166 PUBLIC :: file_del_att !< delete one attribute structure of file structure 167 PUBLIC :: file_del_var !< delete one variable structure of file structure 168 PUBLIC :: file_del_dim !< delete one dimension strucutre of file structure 169 PUBLIC :: file_move_att !< overwrite one attribute structure in file structure 170 PUBLIC :: file_move_var !< overwrite one variable structure in file structure 171 PUBLIC :: file_move_dim !< overwrite one dimension strucutre in file structure 140 172 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 name173 PUBLIC :: file_get_type !< get type of file 174 PUBLIC :: file_get_id !< get file id 175 PUBLIC :: file_rename !< rename file name 176 PUBLIC :: file_add_suffix !< add suffix to file name 145 177 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 178 PRIVATE :: file__clean_unit ! clean file structure 179 PRIVATE :: file__clean_arr ! clean array of file structure 180 PRIVATE :: file__del_var_name ! delete a variable structure in file structure, given variable name or standard name 181 PRIVATE :: file__del_var_str ! delete a variable structure in file structure, given variable structure 182 PRIVATE :: file__del_att_name ! delete a attribute structure in file structure, given attribute name 183 PRIVATE :: file__del_att_str ! delete a attribute structure in file structure, given attribute structure 184 PRIVATE :: file__get_number ! get number in file name without suffix 185 PRIVATE :: file__get_suffix ! get suffix of file name 186 PRIVATE :: file__copy_unit ! copy file structure 187 PRIVATE :: file__copy_arr ! copy array of file structure 188 PRIVATE :: file__rename_char ! rename file name, given processor number. 189 PRIVATE :: file__rename_str ! rename file name, given file structure. 190 191 TYPE TFILE !< file structure 157 192 158 193 ! 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() 194 CHARACTER(LEN=lc) :: c_name = "" !< file name 195 CHARACTER(LEN=lc) :: c_type = "" !< type of the file (cdf, cdf4, dimg) 196 INTEGER(i4) :: i_id = 0 !< file id 197 LOGICAL :: l_wrt = .FALSE. !< read or write mode 198 INTEGER(i4) :: i_nvar = 0 !< number of variable 199 TYPE(TVAR), DIMENSION(:), POINTER :: t_var => NULL() !< file variables 165 200 166 201 CHARACTER(LEN=lc) :: c_grid = 'ARAKAWA-C' !< grid type 167 202 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 203 INTEGER(i4) :: i_ew =-1 !< east-west overlap 204 INTEGER(i4) :: i_perio =-1 !< NEMO periodicity index 205 INTEGER(i4) :: i_pivot =-1 !< NEMO pivot point index F(0),T(1) 206 207 INTEGER(i4) :: i_depthid = 0 !< variable id of depth 208 INTEGER(i4) :: i_timeid = 0 !< variable id of time 174 209 175 210 ! 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 211 INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in the file 212 INTEGER(i4) :: i_natt = 0 !< number of global attributes in the file 213 INTEGER(i4) :: i_uldid = 0 !< id of the unlimited dimension in the file 214 LOGICAL :: l_def = .FALSE. !< define mode or not 215 TYPE(TATT), DIMENSION(:), POINTER :: t_att => NULL() !< global attributes 216 TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< dimension structure 182 217 183 218 ! 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 219 INTEGER(i4) :: i_recl = 0 !< record length (binary file) 220 INTEGER(i4) :: i_n0d = 0 !< number of scalar variable 221 INTEGER(i4) :: i_n1d = 0 !< number of 1D variable 222 INTEGER(i4) :: i_n2d = 0 !< number of 2D variable 223 INTEGER(i4) :: i_n3d = 0 !< number of 3D variable 224 INTEGER(i4) :: i_rhd = 0 !< record of the header infos (last record) 190 225 191 226 ! mpp 192 227 ! 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 228 INTEGER(i4) :: i_pid = -1 !< processor id (start to 1) 229 INTEGER(i4) :: i_impp = 0 !< i-indexes for mpp-subdomain left bottom 230 INTEGER(i4) :: i_jmpp = 0 !< j-indexes for mpp-subdomain left bottom 231 INTEGER(i4) :: i_lci = 0 !< i-dimensions of subdomain 232 INTEGER(i4) :: i_lcj = 0 !< j-dimensions of subdomain 233 INTEGER(i4) :: i_ldi = 0 !< first indoor i-indices 234 INTEGER(i4) :: i_ldj = 0 !< first indoor j-indices 235 INTEGER(i4) :: i_lei = 0 !< last indoor i-indices 236 INTEGER(i4) :: i_lej = 0 !< last indoor j-indices 237 238 LOGICAL :: l_ctr = .FALSE. !< domain is on border 239 LOGICAL :: l_use = .FALSE. !< domain is used 240 241 ! only use to draw domain decomposition when initialize with mpp_init 242 INTEGER(i4) :: i_iind = 0 !< i-direction indices 243 INTEGER(i4) :: i_jind = 0 !< j-direction indices 209 244 210 245 END TYPE TFILE 246 247 INTERFACE file_clean 248 MODULE PROCEDURE file__clean_unit 249 MODULE PROCEDURE file__clean_arr 250 END INTERFACE file_clean 211 251 212 252 INTERFACE file_del_var … … 225 265 END INTERFACE file_rename 226 266 227 INTERFACE ASSIGNMENT(=)228 MODULE PROCEDURE file__copy_unit ! copy file structure229 MODULE PROCEDURE file__copy_ tab ! copy file structure267 INTERFACE file_copy 268 MODULE PROCEDURE file__copy_unit 269 MODULE PROCEDURE file__copy_arr 230 270 END INTERFACE 231 271 … … 233 273 !------------------------------------------------------------------- 234 274 !> @brief 235 !> This function copy file structure in another file 236 !> structure 275 !> This subroutine copy file structure in another one 237 276 !> @details 238 !> file variable and attribute value are copied in a temporary table,277 !> file variable and attribute value are copied in a temporary array, 239 278 !> so input and output file structure value do not point on the same 240 279 !> "memory cell", and so on are independant. … … 242 281 !> @note new file is assume to be closed. 243 282 !> 283 !> @warning do not use on the output of a function who create or read an 284 !> structure (ex: tl_file=file_copy(file_init()) is forbidden). 285 !> This will create memory leaks. 244 286 !> @warning to avoid infinite loop, do not use any function inside 245 287 !> this subroutine 246 288 !> 247 289 !> @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 ) 290 !> - November, 2013- Initial Version 291 !> @date November, 2014 292 !> - use function instead of overload assignment operator 293 !> (to avoid memory leak) 294 ! 295 !> @param[in] td_file file structure 296 !> @return copy of input file structure 297 !------------------------------------------------------------------- 298 FUNCTION file__copy_unit( td_file ) 255 299 IMPLICIT NONE 256 300 ! Argument 257 TYPE(TFILE), INTENT( OUT) :: td_file1 258 TYPE(TFILE), INTENT(IN ) :: td_file2 301 TYPE(TFILE), INTENT(IN) :: td_file 302 ! function 303 TYPE(TFILE) :: file__copy_unit 304 305 ! local variable 306 TYPE(TVAR) :: tl_var 307 TYPE(TATT) :: tl_att 259 308 260 309 ! loop indices … … 262 311 !---------------------------------------------------------------- 263 312 264 CALL logger_trace(" COPY: file "//TRIM(td_file2%c_name) )313 CALL logger_trace("FILE COPY: file "//TRIM(td_file%c_name) ) 265 314 266 315 ! copy file variable 267 td_file1%c_name = TRIM(td_file2%c_name)268 td_file1%c_type = TRIM(td_file2%c_type)316 file__copy_unit%c_name = TRIM(td_file%c_name) 317 file__copy_unit%c_type = TRIM(td_file%c_type) 269 318 ! 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 319 file__copy_unit%i_id = 0 320 file__copy_unit%l_wrt = td_file%l_wrt 321 file__copy_unit%i_nvar = td_file%i_nvar 322 323 file__copy_unit%c_grid = td_file%c_grid 324 325 file__copy_unit%i_ew = td_file%i_ew 326 file__copy_unit%i_perio= td_file%i_perio 327 file__copy_unit%i_pivot= td_file%i_pivot 328 329 file__copy_unit%i_depthid = td_file%i_depthid 330 file__copy_unit%i_timeid = td_file%i_timeid 279 331 280 332 ! 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) 333 IF( ASSOCIATED(file__copy_unit%t_var) )THEN 334 CALL var_clean(file__copy_unit%t_var(:)) 335 DEALLOCATE(file__copy_unit%t_var) 336 ENDIF 337 IF( ASSOCIATED(td_file%t_var) .AND. file__copy_unit%i_nvar > 0 )THEN 338 ALLOCATE( file__copy_unit%t_var(file__copy_unit%i_nvar) ) 339 DO ji=1,file__copy_unit%i_nvar 340 tl_var = var_copy(td_file%t_var(ji)) 341 file__copy_unit%t_var(ji) = var_copy(tl_var) 286 342 ENDDO 287 343 ENDIF 288 344 289 345 ! 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_def346 file__copy_unit%i_ndim = td_file%i_ndim 347 file__copy_unit%i_natt = td_file%i_natt 348 file__copy_unit%i_uldid = td_file%i_uldid 349 file__copy_unit%l_def = td_file%l_def 294 350 295 351 ! copy dimension 296 td_file1%t_dim(:) = td_file2%t_dim(:)352 file__copy_unit%t_dim(:) = dim_copy(td_file%t_dim(:)) 297 353 298 354 ! 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) 355 IF( ASSOCIATED(file__copy_unit%t_att) )THEN 356 CALL att_clean(file__copy_unit%t_att(:)) 357 DEALLOCATE(file__copy_unit%t_att) 358 ENDIF 359 IF( ASSOCIATED(td_file%t_att) .AND. file__copy_unit%i_natt > 0 )THEN 360 ALLOCATE( file__copy_unit%t_att(file__copy_unit%i_natt) ) 361 DO ji=1,file__copy_unit%i_natt 362 tl_att = att_copy(td_file%t_att(ji)) 363 file__copy_unit%t_att(ji) = att_copy(tl_att) 304 364 ENDDO 305 365 ENDIF 306 366 367 ! clean 368 CALL att_clean(tl_att) 369 307 370 ! 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_rhd371 file__copy_unit%i_recl = td_file%i_recl 372 file__copy_unit%i_n0d = td_file%i_n0d 373 file__copy_unit%i_n1d = td_file%i_n1d 374 file__copy_unit%i_n2d = td_file%i_n2d 375 file__copy_unit%i_n3d = td_file%i_n3d 376 file__copy_unit%i_rhd = td_file%i_rhd 314 377 315 378 ! 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 379 file__copy_unit%i_pid = td_file%i_pid 380 file__copy_unit%i_impp = td_file%i_impp 381 file__copy_unit%i_jmpp = td_file%i_jmpp 382 file__copy_unit%i_lci = td_file%i_lci 383 file__copy_unit%i_lcj = td_file%i_lcj 384 file__copy_unit%i_ldi = td_file%i_ldi 385 file__copy_unit%i_ldj = td_file%i_ldj 386 file__copy_unit%i_lei = td_file%i_lei 387 file__copy_unit%i_lej = td_file%i_lej 388 file__copy_unit%l_ctr = td_file%l_ctr 389 file__copy_unit%l_use = td_file%l_use 390 file__copy_unit%i_iind = td_file%i_iind 391 file__copy_unit%i_jind = td_file%i_jind 392 393 END FUNCTION file__copy_unit 332 394 !------------------------------------------------------------------- 333 395 !> @brief 334 !> This function copy file structure in another file 335 !> structure 396 !> This subroutine copy a array of file structure in another one 336 397 !> @details 337 !> file variable and attribute value are copied in a temporary table,398 !> file variable and attribute value are copied in a temporary array, 338 399 !> so input and output file structure value do not point on the same 339 400 !> "memory cell", and so on are independant. … … 341 402 !> @note new file is assume to be closed. 342 403 !> 404 !> @warning do not use on the output of a function who create or read an 405 !> structure (ex: tl_file=file_copy(file_init()) is forbidden). 406 !> This will create memory leaks. 343 407 !> @warning to avoid infinite loop, do not use any function inside 344 408 !> this subroutine 345 409 !> 346 410 !> @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 ) 411 !> - November, 2013- Initial Version 412 !> @date November, 2014 413 !> - use function instead of overload assignment operator 414 !> (to avoid memory leak) 415 ! 416 !> @param[in] td_file file structure 417 !> @return copy of input array of file structure 418 !------------------------------------------------------------------- 419 FUNCTION file__copy_arr( td_file ) 354 420 IMPLICIT NONE 355 421 ! Argument 356 TYPE(TFILE), DIMENSION(:) , INTENT(IN ) :: td_file2 357 TYPE(TFILE), DIMENSION(SIZE(td_file2(:))), INTENT( OUT) :: td_file1 422 TYPE(TFILE), DIMENSION(:) , INTENT(IN ) :: td_file 423 ! function 424 TYPE(TFILE), DIMENSION(SIZE(td_file(:))) :: file__copy_arr 358 425 359 426 ! loop indices … … 361 428 !---------------------------------------------------------------- 362 429 363 DO ji=1,SIZE(td_file 2(:))364 td_file1(ji)=td_file2(ji)430 DO ji=1,SIZE(td_file(:)) 431 file__copy_arr(ji)=file_copy(td_file(ji)) 365 432 ENDDO 366 433 367 END SUBROUTINE file__copy_tab368 ! > @endcode369 ! -------------------------------------------------------------------370 !> @ brief This function initialise file structure.<br/>434 END FUNCTION file__copy_arr 435 !------------------------------------------------------------------- 436 !> @brief This function initialize file structure.<br/> 437 !> @details 371 438 !> If cd_type is not specify, check if file name include '.nc' or 372 !> .'dimg'<br/> 439 !> '.dimg'<br/> 440 !> Optionally, you could specify:<br/> 441 !> - write mode (default .FALSE., ld_wrt) 442 !% - East-West overlap (id_ew) 443 !% - NEMO periodicity index (id_perio) 444 !% - NEMO pivot point index F(0),T(1) (id_pivot) 445 !> - grid type (default: 'ARAKAWA-C') 373 446 ! 374 447 !> @details 375 448 ! 376 449 !> @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.) 450 !> - November, 2013- Initial Version 451 ! 452 !> @param[in] cd_file file name 453 !> @param[in] cd_type file type ('cdf', 'dimg') 454 !> @param[in] ld_wrt write mode (default .FALSE.) 455 !> @param[in] id_ew east-west overlap 456 !> @param[in] id_perio NEMO periodicity index 457 !> @param[in] id_pivot NEMO pivot point index F(0),T(1) 458 !> @param[in] cd_grid grid type (default 'ARAKAWA-C') 382 459 !> @return file structure 383 460 !------------------------------------------------------------------- 384 !> @code385 461 TYPE(TFILE) FUNCTION file_init( cd_file, cd_type, ld_wrt, & 386 462 & id_ew, id_perio, id_pivot,& … … 397 473 398 474 ! local variable 399 TYPE(TATT) :: tl_att475 TYPE(TATT) :: tl_att 400 476 !---------------------------------------------------------------- 401 477 … … 404 480 405 481 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) 482 CALL logger_trace("FILE INIT: initialize file "//TRIM(file_init%c_name)) 414 483 415 484 ! check type … … 421 490 file_init%c_type='dimg' 422 491 CASE DEFAULT 423 CALL logger_error( " INIT: can't initialise file "//&492 CALL logger_error( " FILE INIT: can't initialize file "//& 424 493 & TRIM(file_init%c_name)//" : type unknown " ) 425 494 END SELECT … … 427 496 file_init%c_type=TRIM(file_get_type(cd_file)) 428 497 ENDIF 498 499 ! create some global attribute 500 IF( TRIM(file_init%c_type) == 'cdf' )THEN 501 tl_att=att_init("Conventions","CF-1.5") 502 CALL file_add_att(file_init,tl_att) 503 ENDIF 504 505 tl_att=att_init("Grid",TRIM(file_init%c_grid)) 506 CALL file_add_att(file_init,tl_att) 429 507 430 508 IF( PRESENT(ld_wrt) )THEN … … 460 538 ENDIF 461 539 540 ! clean 541 CALL att_clean(tl_att) 542 462 543 END FUNCTION file_init 463 !> @endcode464 544 !------------------------------------------------------------------- 465 545 !> @brief … … 473 553 ! 474 554 !> @author J.Paul 475 !> - Nov , 2013- Initial Version476 ! 477 !> @param[in] cd_file :file name555 !> - November, 2013- Initial Version 556 ! 557 !> @param[in] cd_file file name 478 558 !> @return type of file 479 559 !------------------------------------------------------------------- 480 !> @code481 560 CHARACTER(LEN=lc) FUNCTION file_get_type(cd_file) 482 561 IMPLICIT NONE 483 562 ! Argument 484 563 CHARACTER(LEN=*), INTENT(IN) :: cd_file 564 485 565 !local variable 486 566 CHARACTER(LEN=lc) :: cl_suffix … … 490 570 SELECT CASE( TRIM(fct_lower(cl_suffix)) ) 491 571 CASE('.nc','.cdf') 492 CALL logger_debug(" GET TYPE: file "//TRIM(cd_file)//" is cdf")572 CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is cdf") 493 573 file_get_type='cdf' 494 574 CASE('.dimg') 495 CALL logger_debug(" GET TYPE: file "//TRIM(cd_file)//" is dimg" )575 CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is dimg" ) 496 576 file_get_type='dimg' 497 577 CASE DEFAULT 498 CALL logger_warn(" GET TYPE: type unknown, we assume file: "//&578 CALL logger_warn(" FILE GET TYPE: type unknown, we assume file: "//& 499 579 & TRIM(cd_file)//" is dimg ") 500 580 file_get_type='dimg' … … 502 582 503 583 END FUNCTION file_get_type 504 !> @endcode505 584 !------------------------------------------------------------------- 506 585 !> @brief This function check if variable dimension to be used … … 510 589 ! 511 590 !> @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 591 !> - November, 2013- Initial Version 592 ! 593 !> @param[in] td_file file structure 594 !> @param[in] td_var variable structure 595 !> @return true if dimension of variable and file structure agree 596 !------------------------------------------------------------------- 519 597 LOGICAL FUNCTION file_check_var_dim(td_file, td_var) 520 598 IMPLICIT NONE … … 524 602 525 603 ! local variable 526 INTEGER(i4) :: il_ndim 604 CHARACTER(LEN=lc) :: cl_dim 605 LOGICAL :: ll_error 606 607 INTEGER(i4) :: il_ind 527 608 528 609 ! loop indices … … 530 611 !---------------------------------------------------------------- 531 612 file_check_var_dim=.TRUE. 613 532 614 ! 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 615 ll_error=.FALSE. 616 DO ji=1,ip_maxdim 617 il_ind=dim_get_index( td_file%t_dim(:), & 618 & TRIM(td_var%t_dim(ji)%c_name), & 619 & TRIM(td_var%t_dim(ji)%c_sname)) 620 IF( il_ind /= 0 )THEN 621 IF( td_var%t_dim(ji)%l_use .AND. & 622 & td_file%t_dim(il_ind)%l_use .AND. & 623 & td_var%t_dim(ji)%i_len /= td_file%t_dim(il_ind)%i_len )THEN 624 ll_error=.TRUE. 625 ENDIF 626 ENDIF 627 ENDDO 628 629 IF( ll_error )THEN 535 630 536 631 file_check_var_dim=.FALSE. … … 542 637 543 638 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))) 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 557 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) ) 660 558 661 ELSE 559 IF( ANY( td_var%t_dim(:)%l_use .AND. & 560 & .NOT. td_file%t_dim(:)%l_use ))THEN561 562 CALL logger_info("FILE CHECK VAR DIM: variable use more dimension"//&563 & " than file do until now. file dimension use will change.")564 565 ENDIF 662 663 IF( td_var%i_ndim > td_file%i_ndim )THEN 664 CALL logger_info("FILE CHECK VAR DIM: variable "//& 665 & TRIM(td_var%c_name)//" use more dimension than file "//& 666 & TRIM(td_file%c_name)//" do until now.") 667 ENDIF 668 566 669 ENDIF 567 670 568 671 END FUNCTION file_check_var_dim 569 !> @endcode570 672 !------------------------------------------------------------------- 571 673 !> @brief This subroutine add a variable structure in a file structure.<br/> … … 577 679 ! 578 680 !> @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 681 !> - November, 2013- Initial Version 682 !> @date September, 2014 683 !> - add dimension to file if need be 684 !> - do not reorder dimension from variable, before put in file 685 ! 686 !> @param[inout] td_file file structure 687 !> @param[in] td_var variable structure 688 !------------------------------------------------------------------- 589 689 SUBROUTINE file_add_var(td_file, td_var) 590 690 IMPLICIT NONE … … 596 696 ! local variable 597 697 INTEGER(i4) :: il_status 598 INTEGER(i4) :: il_varid 599 INTEGER(i4) :: il_rec 698 !INTEGER(i4) :: il_rec 600 699 INTEGER(i4) :: il_ind 601 700 … … 606 705 !---------------------------------------------------------------- 607 706 ! check if file opened 608 !IF( TRIM(td_file%c_name) == "unknown" )THEN609 707 IF( TRIM(td_file%c_name) == '' )THEN 610 708 611 CALL logger_error( " ADD VAR: structure file unknown" )612 CALL logger_debug( " ADD VAR: you should have used file_init before "//&709 CALL logger_error( " FILE ADD VAR: structure file unknown" ) 710 CALL logger_debug( " FILE ADD VAR: you should have used file_init before "//& 613 711 & "running file_add_var" ) 614 712 … … 617 715 IF( TRIM(td_var%c_name) == '' .AND. & 618 716 & TRIM(td_var%c_stdname) == '' )THEN 619 CALL logger_error(" ADD VAR: variable not define ")717 CALL logger_error(" FILE ADD VAR: variable without name ") 620 718 ELSE 621 719 ! check if variable already in file structure 622 il_ varid=0720 il_ind=0 623 721 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 )722 il_ind=var_get_index( td_file%t_var(:), td_var%c_name, & 723 & td_var%c_stdname ) 626 724 ENDIF 627 725 628 IF( il_ varid /= 0 )THEN726 IF( il_ind /= 0 )THEN 629 727 630 728 CALL logger_error( & 631 & " ADD VAR: variable "//TRIM(td_var%c_name)//&729 & " FILE ADD VAR: variable "//TRIM(td_var%c_name)//& 632 730 & ", standard name "//TRIM(td_var%c_stdname)//& 633 731 & ", already in file "//TRIM(td_file%c_name) ) … … 641 739 ELSE 642 740 643 CALL logger_ info( &644 & " ADD VAR: add variable "//TRIM(td_var%c_name)//&741 CALL logger_trace( & 742 & " FILE ADD VAR: add variable "//TRIM(td_var%c_name)//& 645 743 & ", standard name "//TRIM(td_var%c_stdname)//& 646 744 & ", in file "//TRIM(td_file%c_name) ) 647 745 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 746 ! check used dimension 654 747 IF( file_check_var_dim(td_file, td_var) )THEN 655 748 749 ! update dimension if need be 750 DO ji=1,ip_maxdim 751 IF( td_var%t_dim(ji)%l_use .AND. & 752 & .NOT. td_file%t_dim(ji)%l_use )THEN 753 CALL file_add_dim(td_file,td_var%t_dim(ji)) 754 ENDIF 755 ENDDO 756 757 ! get index of new variable 656 758 SELECT CASE(td_var%i_ndim) 657 759 CASE(0) 658 760 il_ind=td_file%i_n0d+1 659 il_rec=0761 !il_rec=0 660 762 CASE(1) 661 763 il_ind=td_file%i_n0d+td_file%i_n1d+1 662 il_rec=1764 !il_rec=1 663 765 CASE(2) 664 766 il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+1 665 il_rec=1767 !il_rec=1 666 768 CASE(3,4) 667 769 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_len770 !il_rec=td_file%t_dim(3)%i_len 669 771 END SELECT 772 CALL logger_info( & 773 & " FILE ADD VAR: variable index "//TRIM(fct_str(il_ind))) 670 774 671 775 IF( td_file%i_nvar > 0 )THEN … … 675 779 676 780 CALL logger_error( & 677 & " ADD VAR: not enough space to put variables "//&781 & " FILE ADD VAR: not enough space to put variables "//& 678 782 & "from "//TRIM(td_file%c_name)//& 679 783 & " in variable structure") … … 682 786 683 787 ! save temporary variable of file structure 684 tl_var(:)=td_file%t_var(:) 685 686 DEALLOCATE( td_file%t_var ) 788 tl_var(:)=var_copy(td_file%t_var(:)) 789 790 CALL var_clean( td_file%t_var(:) ) 791 DEALLOCATE(td_file%t_var) 687 792 ALLOCATE( td_file%t_var(td_file%i_nvar+1), & 688 793 & stat=il_status) … … 690 795 691 796 CALL logger_error( & 692 & " ADD VAR: not enough space to put variable "//&797 & " FILE ADD VAR: not enough space to put variable "//& 693 798 & "in file structure "//TRIM(td_file%c_name) ) 694 799 … … 697 802 ! copy variable in file before 698 803 ! 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 804 IF( il_ind > 1 )THEN 805 td_file%t_var( 1:il_ind-1 ) = var_copy(tl_var(1:il_ind-1)) 806 ENDIF 807 808 IF( il_ind < td_file%i_nvar )THEN 809 ! variable with more dimension than new variable 810 td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = & 811 & var_copy( tl_var(il_ind : td_file%i_nvar) ) 812 ENDIF 813 814 ! clean 815 CALL var_clean(tl_var(:)) 713 816 DEALLOCATE(tl_var) 714 817 ENDIF … … 717 820 ! no variable in file structure 718 821 IF( ASSOCIATED(td_file%t_var) )THEN 822 CALL var_clean(td_file%t_var(:)) 719 823 DEALLOCATE(td_file%t_var) 720 824 ENDIF … … 723 827 724 828 CALL logger_error( & 725 & " ADD VAR: not enough space to put variable "//&829 & " FILE ADD VAR: not enough space to put variable "//& 726 830 & "in file structure "//TRIM(td_file%c_name) ) 727 831 … … 730 834 ENDIF 731 835 836 ! add new variable in array of variable 732 837 ALLOCATE( tl_var(1), stat=il_status ) 733 838 IF(il_status /= 0 )THEN 734 839 735 840 CALL logger_error( & 736 & " ADD VAR: not enough space to put variables from "//&841 & " FILE ADD VAR: not enough space to put variables from "//& 737 842 & TRIM(td_var%c_name)//" in variable structure") 738 843 739 844 ELSE 740 tl_var(1)= td_var845 tl_var(1)=var_copy(td_var) 741 846 742 847 ! update dimension name in new variable … … 744 849 745 850 ! add new variable 746 td_file%t_var(il_ind)= tl_var(1)851 td_file%t_var(il_ind)=var_copy(tl_var(1)) 747 852 748 853 ! update number of variable … … 755 860 CASE(2) 756 861 td_file%i_n2d=td_file%i_n2d+1 757 CASE(3 )862 CASE(3,4) 758 863 td_file%i_n3d=td_file%i_n3d+1 759 864 END SELECT 760 865 761 866 ! 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 867 td_file%t_var(il_ind)%i_id=var_get_unit(td_file%t_var(:)) 774 868 775 869 ! update dimension used … … 780 874 ENDIF 781 875 ENDDO 782 CALL dim_reorder(td_file%t_dim(:)) 876 783 877 ! update number of dimension 784 878 td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use) 785 879 786 DEALLOCATE( tl_var ) 880 ! clean 881 CALL var_clean( tl_var(:) ) 882 DEALLOCATE(tl_var) 787 883 ENDIF 788 789 884 ENDIF 790 885 ENDIF … … 793 888 794 889 END SUBROUTINE file_add_var 795 !> @endcode796 890 !------------------------------------------------------------------- 797 891 !> @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 892 !> in file structure, given variable name or standard name. 893 ! 894 !> @author J.Paul 895 !> - November, 2013- Initial Version 896 ! 897 !> @param[inout] td_file file structure 898 !> @param[in] cd_name variable name or standard name 899 !------------------------------------------------------------------- 809 900 SUBROUTINE file__del_var_name(td_file, cd_name ) 810 901 IMPLICIT NONE … … 815 906 816 907 ! local variable 817 INTEGER(i4) :: il_ varid908 INTEGER(i4) :: il_ind 818 909 !---------------------------------------------------------------- 819 910 … … 821 912 IF( TRIM(td_file%c_name) == '' )THEN 822 913 823 CALL logger_error( " DEL VAR NAME: file structure unknown ")824 CALL logger_debug( " DEL VAR NAME: you should have used file_init before "//&914 CALL logger_error( " FILE DEL VAR NAME: file structure unknown ") 915 CALL logger_debug( " FILE DEL VAR NAME: you should have used file_init before "//& 825 916 & "running file_del_var" ) 826 917 … … 829 920 IF( td_file%i_nvar /= 0 )THEN 830 921 831 ! get the variable i d, in file variable structure832 il_ varid=0922 ! get the variable index, in file variable structure 923 il_ind=0 833 924 IF( ASSOCIATED(td_file%t_var) )THEN 834 il_ varid=var_get_id(td_file%t_var(:), cd_name )925 il_ind=var_get_index(td_file%t_var(:), cd_name ) 835 926 ENDIF 836 IF( il_varid /= 0 )THEN 927 928 IF( il_ind /= 0 )THEN 837 929 838 CALL file_del_var(td_file, td_file%t_var(il_ varid))930 CALL file_del_var(td_file, td_file%t_var(il_ind)) 839 931 840 932 ELSE 841 933 842 934 CALL logger_warn( & 843 & " DEL VAR NAME: there is no variable with name or "//&935 & " FILE DEL VAR NAME: there is no variable with name or "//& 844 936 & "standard name "//TRIM(cd_name)//" in file "//& 845 937 & TRIM(td_file%c_name)) … … 848 940 849 941 ELSE 850 CALL logger_debug( " DEL VAR NAME: no variable associated to file "//& 851 & TRIM(td_file%c_name) ) 942 CALL logger_debug( " FILE DEL VAR NAME: "//& 943 & "no variable associated to file "//& 944 & TRIM(td_file%c_name) ) 852 945 ENDIF 853 946 … … 855 948 856 949 END SUBROUTINE file__del_var_name 857 !> @endcode858 950 !------------------------------------------------------------------- 859 951 !> @brief This subroutine delete a variable structure 860 952 !> 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 953 !> 954 !> @author J.Paul 955 !> - November, 2013- Initial Version 956 !> 957 !> @param[inout] td_file file structure 958 !> @param[in] td_var variable structure 959 !------------------------------------------------------------------- 873 960 SUBROUTINE file__del_var_str(td_file, td_var) 874 961 IMPLICIT NONE … … 880 967 ! local variable 881 968 INTEGER(i4) :: il_status 882 INTEGER(i4) :: il_ varid969 INTEGER(i4) :: il_ind 883 970 INTEGER(i4) :: il_rec 884 971 TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var … … 889 976 890 977 ! check if file opened 891 !IF( TRIM(td_file%c_name) == "unknown" )THEN892 978 IF( TRIM(td_file%c_name) == '' )THEN 893 979 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" )980 CALL logger_error( " FILE DEL VAR: file structure unknown ") 981 CALL logger_debug( " FILE DEL VAR: you should have used "//& 982 & "file_init before running file_del_var" ) 897 983 898 984 ELSE 899 985 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 986 ! check if variable is member of a file 987 IF( td_var%l_file )THEN 988 CALL logger_warn( & 989 & " FILE DEL VAR: variable "//TRIM(td_var%c_name)//& 990 & ", belong to file "//TRIM(td_file%c_name)//& 991 & " and can not be removed.") 992 ELSE 993 ! check if variable already in file structure 994 il_ind=0 995 IF( ASSOCIATED(td_file%t_var) )THEN 996 il_ind=var_get_index( td_file%t_var(:), td_var%c_name, & 997 & td_var%c_stdname ) 998 ENDIF 999 1000 IF( il_ind == 0 )THEN 1001 1002 CALL logger_warn( "FILE DEL VAR: no variable "//& 1003 & TRIM(td_var%c_name)//", in file "//TRIM(td_file%c_name) ) 1004 1005 DO ji=1,td_file%i_nvar 1006 CALL logger_debug( "FILE DEL VAR: in file "//& 1007 & TRIM(td_file%t_var(ji)%c_name)//", standard name "//& 1008 & TRIM(td_file%t_var(ji)%c_stdname) ) 1009 ENDDO 1010 1011 ELSE 1012 1013 CALL logger_trace( "FILE DEL VAR: delete variable "//& 1014 & TRIM(td_var%c_name)//", from file "//TRIM(td_file%c_name) ) 1015 1016 ALLOCATE( tl_var(td_file%i_nvar-1), stat=il_status ) 1017 IF(il_status /= 0 )THEN 1018 1019 CALL logger_error( & 1020 & " FILE DEL VAR: not enough space to put variables from "//& 1021 & TRIM(td_file%c_name)//" in temporary variable structure") 1022 1023 ELSE 1024 1025 ! save temporary variable's file structure 1026 IF( il_ind > 1 )THEN 1027 tl_var(1:il_ind-1)=var_copy(td_file%t_var(1:il_ind-1)) 1028 ENDIF 1029 1030 IF( il_ind < td_file%i_nvar )THEN 1031 tl_var(il_ind:)=var_copy(td_file%t_var(il_ind+1:)) 1032 ENDIF 1033 1034 ! new number of variable in file 1035 td_file%i_nvar=td_file%i_nvar-1 1036 1037 SELECT CASE(td_var%i_ndim) 1038 CASE(0) 1039 td_file%i_n0d=td_file%i_n0d-1 1040 il_rec=0 1041 CASE(1) 1042 td_file%i_n1d=td_file%i_n1d-1 1043 il_rec=1 1044 CASE(2) 1045 td_file%i_n2d=td_file%i_n2d-1 1046 il_rec=1 1047 CASE(3,4) 1048 td_file%i_n3d=td_file%i_n3d-1 1049 il_rec=td_file%t_dim(3)%i_len 1050 END SELECT 1051 1052 CALL var_clean( td_file%t_var(:) ) 1053 DEALLOCATE(td_file%t_var) 1054 1055 IF( td_file%i_nvar > 0 )THEN 1056 ALLOCATE( td_file%t_var(td_file%i_nvar), stat=il_status ) 1057 IF(il_status /= 0 )THEN 1058 1059 CALL logger_error( " FILE DEL VAR: not enough space"//& 1060 & "to put variables in file structure "//& 1061 & TRIM(td_file%c_name) ) 1062 1063 ENDIF 1064 1065 ! copy attribute in file before 1066 td_file%t_var(:)=var_copy(tl_var(:)) 1067 1068 ! update dimension used 1069 td_file%t_dim(:)%l_use=.FALSE. 1070 DO ji=1,ip_maxdim 1071 IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN 1072 td_file%t_dim(ji)%l_use=.TRUE. 1073 ENDIF 1074 ENDDO 1075 1076 ! update number of dimension 1077 td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use) 1078 1079 ENDIF 1080 1081 ! clean 1082 CALL var_clean(tl_var(:)) 1083 DEALLOCATE(tl_var) 1084 1085 ENDIF 1086 ENDIF 1087 ENDIF 1088 ENDIF 1089 1090 END SUBROUTINE file__del_var_str 1091 !------------------------------------------------------------------- 1092 !> @brief This subroutine overwrite variable structure 1093 !> in file structure. 1094 ! 1095 !> @warning change variable id in file structure. 1096 ! 1097 !> @author J.Paul 1098 !> - November, 2013- Initial Version 1099 ! 1100 !> @param[inout] td_file file structure 1101 !> @param[in] td_var variable structure 1102 !------------------------------------------------------------------- 1103 SUBROUTINE file_move_var(td_file, td_var) 1104 IMPLICIT NONE 1105 1106 ! Argument 1107 TYPE(TFILE), INTENT(INOUT) :: td_file 1108 TYPE(TVAR), INTENT(IN) :: td_var 1109 1110 ! local variable 1111 TYPE(TVAR) :: tl_var 1112 !---------------------------------------------------------------- 1113 1114 ! copy variable 1115 tl_var=var_copy(td_var) 1116 1117 ! remove variable with same name or standard name 1118 CALL file_del_var(td_file, tl_var) 1119 1120 ! add new variable 1121 CALL file_add_var(td_file, tl_var) 1122 1123 ! clean 1124 CALL var_clean(tl_var) 1125 1126 END SUBROUTINE file_move_var 1127 !------------------------------------------------------------------- 1128 !> @brief This subroutine add a global attribute 1129 !> in a file structure.<br/> 1130 !> Do not overwrite, if attribute already in file structure. 1131 ! 1132 !> @author J.Paul 1133 !> - November, 2013- Initial Version 1134 ! 1135 !> @param[inout] td_file file structure 1136 !> @param[in] td_att attribute structure 1137 !------------------------------------------------------------------- 1138 SUBROUTINE file_add_att(td_file, td_att) 1139 IMPLICIT NONE 1140 1141 ! Argument 1142 TYPE(TFILE), INTENT(INOUT) :: td_file 1143 TYPE(TATT), INTENT(IN) :: td_att 1144 1145 ! local variable 1146 INTEGER(i4) :: il_status 1147 INTEGER(i4) :: il_ind 1148 TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att 1149 1150 ! loop indices 1151 INTEGER(i4) :: ji 1152 !---------------------------------------------------------------- 1153 1154 ! check if file opened 1155 IF( TRIM(td_file%c_name) == '' )THEN 1156 1157 CALL logger_error( " FILE ADD ATT: file structure unknown ") 1158 CALL logger_debug( " FILE ADD ATT: you should have used file_init before "//& 1159 & "running file_add_att" ) 1160 1161 ELSE 1162 1163 ! check if attribute already in file structure 1164 il_ind=0 1165 IF( ASSOCIATED(td_file%t_att) )THEN 1166 il_ind=att_get_index( td_file%t_att(:), td_att%c_name ) 1167 ENDIF 1168 1169 IF( il_ind /= 0 )THEN 1170 904 1171 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 var1172 & " FILE ADD ATT: attribute "//TRIM(td_att%c_name)//& 1173 & ", already in file "//TRIM(td_file%c_name) ) 1174 1175 DO ji=1,td_file%i_natt 909 1176 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) ) 1177 & " FILE ADD ATT: in file "//TRIM(td_file%t_att(ji)%c_name) ) 912 1178 ENDDO 913 1179 … … 915 1181 916 1182 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)//& 1183 & " FILE ADD ATT: add attribute "//TRIM(td_att%c_name)//& 1102 1184 & ", in file "//TRIM(td_file%c_name) ) 1103 1185 … … 1108 1190 1109 1191 CALL logger_error( & 1110 & " ADD ATT: not enough space to put attributes from "//&1192 & " FILE ADD ATT: not enough space to put attributes from "//& 1111 1193 & TRIM(td_file%c_name)//" in temporary attribute structure") 1112 1194 … … 1114 1196 1115 1197 ! save temporary global attribute's file structure 1116 tl_att(:)=td_file%t_att(:) 1117 1118 DEALLOCATE( td_file%t_att ) 1198 tl_att(:)=att_copy(td_file%t_att(:)) 1199 1200 CALL att_clean( td_file%t_att(:) ) 1201 DEALLOCATE(td_file%t_att) 1119 1202 ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status ) 1120 1203 IF(il_status /= 0 )THEN 1121 1204 1122 1205 CALL logger_error( & 1123 & " ADD ATT: not enough space to put attributes "//&1206 & " FILE ADD ATT: not enough space to put attributes "//& 1124 1207 & "in file structure "//TRIM(td_file%c_name) ) 1125 1208 … … 1127 1210 1128 1211 ! copy attribute in file before 1129 td_file%t_att(1:td_file%i_natt)=tl_att(:) 1130 1212 td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:)) 1213 1214 ! clean 1215 CALL att_clean(tl_att(:)) 1131 1216 DEALLOCATE(tl_att) 1217 1132 1218 ENDIF 1133 1219 ELSE 1134 1220 ! no attribute in file structure 1135 1221 IF( ASSOCIATED(td_file%t_att) )THEN 1222 CALL att_clean(td_file%t_att(:)) 1136 1223 DEALLOCATE(td_file%t_att) 1137 1224 ENDIF 1138 CALL logger_debug(" natt "//TRIM(fct_str(td_file%i_natt)) ) 1225 1139 1226 ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status ) 1140 1227 IF(il_status /= 0 )THEN 1141 1228 1142 1229 CALL logger_error( & 1143 & " ADD ATT: not enough space to put attributes "//&1230 & " FILE ADD ATT: not enough space to put attributes "//& 1144 1231 & "in file structure "//TRIM(td_file%c_name) ) 1145 1232 1146 1233 ENDIF 1147 1234 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 1235 ! add new attribute 1236 td_file%t_att(td_file%i_natt+1)=att_copy(td_att) 1153 1237 1154 1238 ! update number of attribute … … 1158 1242 1159 1243 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 1244 !------------------------------------------------------------------- 1245 !> @brief This subroutine delete a global attribute structure 1246 !> in file structure, given attribute name. 1247 ! 1248 !> @author J.Paul 1249 !> - November, 2013- Initial Version 1250 ! 1251 !> @param[inout] td_file file structure 1252 !> @param[in] cd_name attribute name 1253 !------------------------------------------------------------------- 1174 1254 SUBROUTINE file__del_att_name(td_file, cd_name ) 1175 1255 IMPLICIT NONE … … 1180 1260 1181 1261 ! local variable 1182 INTEGER(i4) :: il_ attid1262 INTEGER(i4) :: il_ind 1183 1263 !---------------------------------------------------------------- 1184 1264 … … 1186 1266 IF( TRIM(td_file%c_name) == '' )THEN 1187 1267 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" )1268 CALL logger_error( " FILE DEL ATT NAME: file structure unknown ") 1269 CALL logger_debug( " FILE DEL ATT NAME: you should have "//& 1270 & "used file_init before running file_del_att" ) 1191 1271 1192 1272 ELSE … … 1195 1275 1196 1276 ! get the variable id, in file variable structure 1197 il_ attid=01277 il_ind=0 1198 1278 IF( ASSOCIATED(td_file%t_att) )THEN 1199 il_ attid=att_get_id(td_file%t_att(:), cd_name )1279 il_ind=att_get_index(td_file%t_att(:), cd_name ) 1200 1280 ENDIF 1201 IF( il_attid /= 0 )THEN 1281 1282 IF( il_ind /= 0 )THEN 1202 1283 1203 CALL file_del_att(td_file, td_file%t_att(il_ attid))1284 CALL file_del_att(td_file, td_file%t_att(il_ind)) 1204 1285 1205 1286 ELSE 1206 1287 1207 1288 CALL logger_warn( & 1208 & " DEL ATT NAME: there is no attribute with name "//&1289 & " FILE DEL ATT NAME: there is no attribute with name "//& 1209 1290 & TRIM(cd_name)//" in file "//TRIM(td_file%c_name)) 1210 1291 … … 1212 1293 1213 1294 ELSE 1214 CALL logger_debug( " DEL ATT NAME: no attribute associated to file "//&1215 & 1295 CALL logger_debug( " FILE DEL ATT NAME: no attribute "//& 1296 & "associated to file "//TRIM(td_file%c_name) ) 1216 1297 ENDIF 1217 1298 … … 1219 1300 1220 1301 END SUBROUTINE file__del_att_name 1221 !> @endcode1222 1302 !------------------------------------------------------------------- 1223 1303 !> @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 1304 !> from file structure, given attribute structure. 1305 ! 1306 !> @author J.Paul 1307 !> - November, 2013- Initial Version 1308 ! 1309 !> @param[inout] td_file file structure 1310 !> @param[in] td_att attribute structure 1311 !------------------------------------------------------------------- 1235 1312 SUBROUTINE file__del_att_str(td_file, td_att) 1236 1313 IMPLICIT NONE … … 1242 1319 ! local variable 1243 1320 INTEGER(i4) :: il_status 1244 INTEGER(i4) :: il_ attid1321 INTEGER(i4) :: il_ind 1245 1322 TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att 1246 1323 1247 1324 ! loop indices 1248 INTEGER(i4) :: ji1249 1325 !---------------------------------------------------------------- 1250 1326 1251 1327 ! check if file opened 1252 !IF( TRIM(td_file%c_name) == "unknown" )THEN1253 1328 IF( TRIM(td_file%c_name) == '' )THEN 1254 1329 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" )1330 CALL logger_error( " FILE DEL ATT: file structure unknown ") 1331 CALL logger_debug( " FILE DEL ATT: you should have used "//& 1332 & "file_init before running file_del_att" ) 1258 1333 1259 1334 ELSE 1260 1335 1261 1336 ! check if attribute already in file structure 1262 il_ attid=01337 il_ind=0 1263 1338 IF( ASSOCIATED(td_file%t_att) )THEN 1264 il_ attid=att_get_id( td_file%t_att(:), td_att%c_name )1265 ENDIF 1266 1267 IF( il_ attid == 0 )THEN1339 il_ind=att_get_index( td_file%t_att(:), td_att%c_name ) 1340 ENDIF 1341 1342 IF( il_ind == 0 )THEN 1268 1343 1269 1344 CALL logger_error( & 1270 & " DEL ATT: no attribute "//TRIM(td_att%c_name)//&1345 & " FILE DEL ATT: no attribute "//TRIM(td_att%c_name)//& 1271 1346 & ", in file "//TRIM(td_file%c_name) ) 1272 1347 1273 1348 ELSE 1274 1349 1275 CALL logger_ debug( &1276 & " DEL ATT: del attribute "//TRIM(td_att%c_name)//&1350 CALL logger_trace( & 1351 & " FILE DEL ATT: del attribute "//TRIM(td_att%c_name)//& 1277 1352 & ", in file "//TRIM(td_file%c_name) ) 1278 1353 … … 1281 1356 1282 1357 CALL logger_error( & 1283 & " ADD ATT: not enough space to put attributes from "//&1358 & " FILE ADD ATT: not enough space to put attributes from "//& 1284 1359 & TRIM(td_file%c_name)//" in temporary attribute structure") 1285 1360 … … 1287 1362 1288 1363 ! 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 ) 1364 IF( il_ind > 1 )THEN 1365 tl_att(1:il_ind-1)=att_copy(td_file%t_att(1:il_ind-1)) 1366 ENDIF 1367 1368 IF( il_ind < td_file%i_natt )THEN 1369 tl_att(il_ind:)=att_copy(td_file%t_att(il_ind+1:)) 1370 ENDIF 1371 1372 CALL att_clean( td_file%t_att(:) ) 1373 DEALLOCATE(td_file%t_att) 1293 1374 1294 1375 ! new number of attribute in file … … 1299 1380 1300 1381 CALL logger_error( & 1301 & " ADD ATT: not enough space to put attributes "//&1382 & " FILE ADD ATT: not enough space to put attributes "//& 1302 1383 & "in file structure "//TRIM(td_file%c_name) ) 1303 1384 … … 1305 1386 1306 1387 ! 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 1388 td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:)) 1389 1390 ! clean 1391 CALL att_clean(tl_att(:)) 1314 1392 DEALLOCATE(tl_att) 1393 1315 1394 ENDIF 1316 1395 ENDIF … … 1318 1397 1319 1398 END SUBROUTINE file__del_att_str 1320 !> @endcode1321 1399 !------------------------------------------------------------------- 1322 1400 !> @brief This subroutine move a global attribute structure 1323 1401 !> 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 1402 !> @warning change attribute id in file structure. 1403 ! 1404 !> @author J.Paul 1405 !> - November, 2013- Initial Version 1406 ! 1407 !> @param[inout] td_file file structure 1408 !> @param[in] td_att attribute structure 1409 !------------------------------------------------------------------- 1336 1410 SUBROUTINE file_move_att(td_file, td_att) 1337 1411 IMPLICIT NONE … … 1343 1417 ! local variable 1344 1418 TYPE(TATT) :: tl_att 1345 INTEGER(i4) :: il_ attid1419 INTEGER(i4) :: il_ind 1346 1420 !---------------------------------------------------------------- 1347 1421 1348 1422 ! copy attribute 1349 tl_att= td_att1423 tl_att=att_copy(td_att) 1350 1424 1351 1425 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 )THEN1426 il_ind=att_get_index(td_file%t_att(:),TRIM(tl_att%c_name)) 1427 IF( il_ind /= 0 )THEN 1354 1428 ! remove attribute with same name 1355 1429 CALL file_del_att(td_file, tl_att) … … 1360 1434 CALL file_add_att(td_file, tl_att) 1361 1435 1436 ! clean 1437 CALL att_clean(tl_att) 1438 1362 1439 END SUBROUTINE file_move_att 1363 !> @endcode1364 1440 !------------------------------------------------------------------- 1365 1441 !> @brief This subroutine add a dimension structure in file … … 1367 1443 !> Do not overwrite, if dimension already in file structure. 1368 1444 ! 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 1445 !> @author J.Paul 1446 !> - November, 2013- Initial Version 1447 !> @date September, 2014 1448 !> - do not reorder dimension, before put in file 1449 ! 1450 !> @param[inout] td_file file structure 1451 !> @param[in] td_dim dimension structure 1452 !------------------------------------------------------------------- 1380 1453 SUBROUTINE file_add_dim(td_file, td_dim) 1381 1454 IMPLICIT NONE 1382 1455 1383 1456 ! Argument 1384 TYPE(TFILE), INTENT(INOUT) :: td_file 1385 TYPE(TDIM), INTENT(IN) :: td_dim 1386 1387 ! local variable 1388 INTEGER(i4) :: il_dimid 1457 TYPE(TFILE) , INTENT(INOUT) :: td_file 1458 TYPE(TDIM) , INTENT(IN ) :: td_dim 1459 1460 ! local variable 1461 INTEGER(i4) :: il_ind 1462 1463 ! loop indices 1464 INTEGER(i4) :: ji 1389 1465 !---------------------------------------------------------------- 1390 1466 ! check if file opened 1391 !IF( TRIM(td_file%c_name) == "unknown" )THEN1392 1467 IF( TRIM(td_file%c_name) == '' )THEN 1393 1468 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" )1469 CALL logger_error( " FILE ADD DIM: file structure unknown ") 1470 CALL logger_debug( " FILE ADD DIM: you should have used "//& 1471 & "file_init before running file_add_dim" ) 1397 1472 1398 1473 ELSE 1399 1474 1400 IF( td_file%i_ndim <= 4)THEN1475 IF( td_file%i_ndim <= ip_maxdim )THEN 1401 1476 1402 1477 ! 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 1478 il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname) 1479 IF( il_ind /= 0 )THEN 1480 IF( td_file%t_dim(il_ind)%l_use )THEN 1411 1481 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 ") 1482 & "FILE ADD DIM: dimension "//TRIM(td_dim%c_name)//& 1483 & ", short name "//TRIM(td_dim%c_sname)//& 1484 & ", already used in file "//TRIM(td_file%c_name) ) 1485 ELSE 1486 ! replace dimension 1487 td_file%t_dim(il_ind)=dim_copy(td_dim) 1488 td_file%t_dim(il_ind)%i_id=il_ind 1489 td_file%t_dim(il_ind)%l_use=.TRUE. 1415 1490 ENDIF 1416 1417 1491 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 )THEN1492 IF( td_file%i_ndim == ip_maxdim )THEN 1493 CALL logger_error( & 1494 & "FILE ADD DIM: can not add dimension "//TRIM(td_dim%c_name)//& 1495 & ", short name "//TRIM(td_dim%c_sname)//& 1496 & ", in file "//TRIM(td_file%c_name)//". Already "//& 1497 & TRIM(fct_str(ip_maxdim))//" dimensions." ) 1498 ELSE 1425 1499 ! 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. 1500 DO ji=1,ip_maxdim 1501 IF( td_file%t_dim(ji)%i_id == 0 )THEN 1502 il_ind=ji 1503 EXIT 1504 ENDIF 1505 ENDDO 1506 1507 ! add new dimension 1508 td_file%t_dim(il_ind)=dim_copy(td_dim) 1439 1509 ! update number of attribute 1440 1510 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 1511 1512 td_file%t_dim(il_ind)%i_id=td_file%i_ndim 1513 td_file%t_dim(il_ind)%l_use=.TRUE. 1514 ENDIF 1446 1515 ENDIF 1516 1447 1517 ELSE 1448 1518 CALL logger_error( & 1449 & " ADD DIM: too much dimension in file "//&1519 & " FILE ADD DIM: too much dimension in file "//& 1450 1520 & TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")") 1451 1521 ENDIF … … 1454 1524 1455 1525 END SUBROUTINE file_add_dim 1456 !> @endcode1457 1526 !------------------------------------------------------------------- 1458 1527 !> @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 1528 !> structure. 1529 !> 1530 !> @author J.Paul 1531 !> - November, 2013- Initial Version 1532 ! 1533 !> @param[inout] td_file file structure 1534 !> @param[in] td_dim dimension structure 1535 !------------------------------------------------------------------- 1472 1536 SUBROUTINE file_del_dim(td_file, td_dim) 1473 1537 IMPLICIT NONE 1474 1538 1475 1539 ! Argument 1476 TYPE(TFILE) , INTENT(INOUT) :: td_file1477 TYPE(TDIM) , INTENT(IN):: td_dim1540 TYPE(TFILE) , INTENT(INOUT) :: td_file 1541 TYPE(TDIM) , INTENT(IN ) :: td_dim 1478 1542 1479 1543 ! local variable 1480 1544 INTEGER(i4) :: il_status 1481 INTEGER(i4) :: il_dimid 1545 INTEGER(i4) :: il_ind 1546 1482 1547 TYPE(TDIM), DIMENSION(:), ALLOCATABLE :: tl_dim 1548 1549 ! loop indices 1550 INTEGER(i4) :: ji 1483 1551 !---------------------------------------------------------------- 1484 1552 ! check if file opened 1485 !IF( TRIM(td_file%c_name) == "unknown" )THEN1486 1553 IF( TRIM(td_file%c_name) == '' )THEN 1487 1554 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" )1555 CALL logger_error( " FILE DEL DIM: file structure unknown ") 1556 CALL logger_debug( " FILE DEL DIM: you should have used "//& 1557 & "file_init before running file_del_dim" ) 1491 1558 1492 1559 ELSE 1493 1560 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 1561 ! check if dimension already in file structure 1562 il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname) 1563 IF( il_ind == 0 )THEN 1564 1565 CALL logger_error( & 1566 & "FILE DEL DIM: no dimension "//TRIM(td_dim%c_name)//& 1567 & ", short name "//TRIM(td_dim%c_sname)//& 1568 & ", in file "//TRIM(td_file%c_name) ) 1569 1570 ELSE 1571 ALLOCATE( tl_dim(td_file%i_ndim-1), stat=il_status ) 1572 IF(il_status /= 0 )THEN 1499 1573 1500 1574 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 1575 & "FILE DEL DIM: not enough space to put dimensions from "//& 1576 & TRIM(td_file%c_name)//" in temporary dimension structure") 1577 1578 ELSE 1579 ! save temporary dimension's mpp structure 1580 tl_dim( 1 : il_ind-1 ) = dim_copy(td_file%t_dim(1 : il_ind-1)) 1581 tl_dim( il_ind : td_file%i_ndim-1 ) = & 1582 & dim_copy(td_file%t_dim(il_ind+1 : td_file%i_ndim)) 1583 1584 ! remove dimension from file 1585 CALL dim_clean(td_file%t_dim(:)) 1586 ! copy dimension in file, except one 1587 td_file%t_dim(1:td_file%i_ndim)=dim_copy(tl_dim(:)) 1588 1589 ! update number of dimension 1590 td_file%i_ndim=td_file%i_ndim-1 1591 1592 ! update dimension id 1593 DO ji=1,td_file%i_ndim 1594 td_file%t_dim(ji)%i_id=ji 1595 ENDDO 1596 1597 ! clean 1598 CALL dim_clean(tl_dim(:)) 1599 DEALLOCATE(tl_dim) 1562 1600 ENDIF 1563 ELSE 1564 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 ENDIF 1568 1601 ENDIF 1569 1602 ENDIF 1570 1603 1571 1604 END SUBROUTINE file_del_dim 1572 !> @endcode1573 1605 !------------------------------------------------------------------- 1574 1606 !> @brief This subroutine move a dimension structure 1575 1607 !> 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 1608 !> @warning change dimension order in file structure. 1609 ! 1610 !> @author J.Paul 1611 !> - November, 2013- Initial Version 1612 ! 1613 !> @param[inout] td_file file structure 1614 !> @param[in] td_dim dimension structure 1615 !------------------------------------------------------------------- 1588 1616 SUBROUTINE file_move_dim(td_file, td_dim) 1589 1617 IMPLICIT NONE 1590 1618 1591 1619 ! Argument 1592 TYPE(TFILE) , INTENT(INOUT) :: td_file1593 TYPE(TDIM) , INTENT(IN):: td_dim1594 1595 ! local variable 1596 TYPE(TDIM) :: tl_dim1620 TYPE(TFILE) , INTENT(INOUT) :: td_file 1621 TYPE(TDIM) , INTENT(IN ) :: td_dim 1622 1623 ! local variable 1624 INTEGER(i4) :: il_ind 1597 1625 INTEGER(i4) :: il_dimid 1598 1626 !---------------------------------------------------------------- 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) 1627 IF( td_file%i_ndim <= ip_maxdim )THEN 1628 1629 ! check if dimension already in mpp structure 1630 il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname) 1631 IF( il_ind /= 0 )THEN 1632 1633 il_dimid=td_file%t_dim(il_ind)%i_id 1634 ! replace dimension 1635 td_file%t_dim(il_ind)=dim_copy(td_dim) 1636 td_file%t_dim(il_ind)%i_id=il_dimid 1637 td_file%t_dim(il_ind)%l_use=.TRUE. 1638 1639 ELSE 1640 CALL file_add_dim(td_file, td_dim) 1641 ENDIF 1642 1643 ELSE 1644 CALL logger_error( & 1645 & "FILE MOVE DIM: too much dimension in mpp "//& 1646 & TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")") 1647 ENDIF 1612 1648 1613 1649 END SUBROUTINE file_move_dim 1614 !> @endcode1615 1650 !------------------------------------------------------------------- 1616 1651 !> @brief This subroutine print some information about file strucutre. 1617 1652 ! 1618 1653 !> @author J.Paul 1619 !> - Nov, 2013- Initial Version 1620 ! 1621 !> @param[in] td_file : file structure 1622 !------------------------------------------------------------------- 1623 !> @code 1654 !> - November, 2013- Initial Version 1655 ! 1656 !> @param[in] td_file file structure 1657 !------------------------------------------------------------------- 1624 1658 SUBROUTINE file_print(td_file) 1625 1659 IMPLICIT NONE … … 1688 1722 1689 1723 END SUBROUTINE file_print 1690 !> @endcode1691 1724 !------------------------------------------------------------------- 1692 1725 !> @brief This function get suffix of file name. 1693 1726 !> @details 1694 1727 !> we assume suffix is define as alphanumeric character following the 1695 !> last '.' in file name 1728 !> last '.' in file name.<br/> 1696 1729 !> If no suffix is found, return empty character. 1697 1730 ! 1698 1731 !> @author J.Paul 1699 !> - Nov , 2013- Initial Version1700 ! 1701 !> @param[in] cd_file :file structure1732 !> - November, 2013- Initial Version 1733 ! 1734 !> @param[in] cd_file file structure 1702 1735 !> @return suffix 1703 1736 !------------------------------------------------------------------- 1704 !> @code1705 1737 CHARACTER(LEN=lc) FUNCTION file__get_suffix(cd_file) 1706 1738 IMPLICIT NONE … … 1713 1745 !---------------------------------------------------------------- 1714 1746 1715 CALL logger_trace( " GET SUFFIX: look for suffix in file name "//&1747 CALL logger_trace( "FILE GET SUFFIX: look for suffix in file name "//& 1716 1748 & TRIM(cd_file) ) 1717 1749 … … 1721 1753 READ( cd_file(il_ind:),'(a)' ) file__get_suffix 1722 1754 1723 IF( fct_is_num(file__get_suffix ) )THEN1755 IF( fct_is_num(file__get_suffix(2:)) )THEN 1724 1756 file__get_suffix='' 1725 1757 ENDIF … … 1730 1762 1731 1763 END FUNCTION file__get_suffix 1732 !> @endcode1733 1764 !------------------------------------------------------------------- 1734 1765 !> @brief This function get number in file name without suffix. 1735 1766 !> @details 1736 1767 !> 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 1768 !> separator could be '.' or '_'. 1769 ! 1770 !> @author J.Paul 1771 !> - November, 2013- Initial Version 1772 ! 1773 !> @param[in] cd_file file name (without suffix) 1774 !> @return character file number. 1775 !------------------------------------------------------------------- 1746 1776 CHARACTER(LEN=lc) FUNCTION file__get_number(cd_file) 1747 1777 IMPLICIT NONE … … 1760 1790 ! get number position in file name 1761 1791 il_indmax=0 1762 DO ji=1,i g_nsep1763 il_ind=INDEX(TRIM(cd_file),TRIM(c g_sep(ji)),BACK=.TRUE.)1792 DO ji=1,ip_nsep 1793 il_ind=INDEX(TRIM(cd_file),TRIM(cp_sep(ji)),BACK=.TRUE.) 1764 1794 IF( il_ind > il_indmax )THEN 1765 1795 il_indmax=il_ind … … 1779 1809 1780 1810 END FUNCTION file__get_number 1781 !> @endcode 1782 !------------------------------------------------------------------- 1783 !> @brief This function rename file name. 1811 !------------------------------------------------------------------- 1812 !> @brief This function rename file name, given processor number. 1784 1813 !> @details 1785 1814 !> If no processor number is given, return file name without number … … 1787 1816 ! 1788 1817 !> @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 1818 !> - November, 2013- Initial Version 1819 ! 1820 !> @param[in] td_file file structure 1821 !> @param[in] id_num processor number (start to 1) 1822 !> @return file name 1823 !------------------------------------------------------------------- 1796 1824 CHARACTER(LEN=lc) FUNCTION file__rename_char(cd_file, id_num) 1797 1825 IMPLICIT NONE … … 1841 1869 WRITE(file__rename_char,'(a,a)') TRIM(cl_base),TRIM(cl_suffix) 1842 1870 ENDIF 1843 CALL logger_trace(" RENAME : "//TRIM(file__rename_char))1871 CALL logger_trace(" FILE RENAME : "//TRIM(file__rename_char)) 1844 1872 1845 1873 END FUNCTION file__rename_char 1846 !> @endcode1847 1874 !------------------------------------------------------------------- 1848 1875 !> @brief This function rename file name, given file structure. … … 1852 1879 ! 1853 1880 !> @author J.Paul 1854 !> - Nov , 2013- Initial Version1855 ! 1856 !> @param[in] td_file :file structure1857 !> @param[in] id_num :processor number (start to 1)1881 !> - November, 2013- Initial Version 1882 ! 1883 !> @param[in] td_file file structure 1884 !> @param[in] id_num processor number (start to 1) 1858 1885 !> @return file structure 1859 1886 !------------------------------------------------------------------- 1860 !> @code1861 1887 TYPE(TFILE) FUNCTION file__rename_str(td_file, id_num) 1862 1888 IMPLICIT NONE … … 1876 1902 1877 1903 END FUNCTION file__rename_str 1878 !> @endcode1879 1904 !------------------------------------------------------------------- 1880 1905 !> @brief This function add suffix to file name. 1881 1906 ! 1882 1907 !> @author J.Paul 1883 !> - Nov, 2013- Initial Version 1884 ! 1885 !> @param[in] td_file : file structure 1886 !> @return file structure 1887 !------------------------------------------------------------------- 1888 !> @code 1908 !> - November, 2013- Initial Version 1909 ! 1910 !> @param[in] td_file file structure 1911 !> @return file name 1912 !------------------------------------------------------------------- 1889 1913 CHARACTER(LEN=lc) FUNCTION file_add_suffix(cd_file, cd_type) 1890 1914 IMPLICIT NONE … … 1918 1942 ENDIF 1919 1943 CASE DEFAULT 1920 CALL logger_error( " ADD SUFFIX: type unknown "//TRIM(cd_type))1944 CALL logger_error(" FILE ADD SUFFIX: type unknown "//TRIM(cd_type)) 1921 1945 END SELECT 1922 1946 1923 1947 END FUNCTION file_add_suffix 1924 !> @endcode1925 1948 !------------------------------------------------------------------- 1926 1949 !> @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 ) 1950 !> This subroutine clean file strcuture. 1951 ! 1952 !> @author J.Paul 1953 !> @date November, 2013 - Inital version 1954 ! 1955 !> @param[inout] td_file file strcuture 1956 !------------------------------------------------------------------- 1957 SUBROUTINE file__clean_unit( td_file ) 1936 1958 IMPLICIT NONE 1937 1959 ! Argument … … 1942 1964 1943 1965 ! loop indices 1944 INTEGER(i4) :: ji 1945 !---------------------------------------------------------------- 1946 1947 CALL logger_info( & 1948 & " CLEAN: reset file "//TRIM(td_file%c_name) ) 1966 !---------------------------------------------------------------- 1967 1968 CALL logger_trace( & 1969 & " FILE CLEAN: reset file "//TRIM(td_file%c_name) ) 1949 1970 1950 1971 ! del attribute 1951 1972 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 ) 1973 CALL att_clean( td_file%t_att(:) ) 1974 DEALLOCATE(td_file%t_att) 1956 1975 ENDIF 1957 1976 1958 1977 ! del dimension 1959 1978 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 1979 CALL dim_clean( td_file%t_dim(:) ) 1963 1980 ENDIF 1964 1981 1965 1982 ! del variable 1966 1983 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 ) 1984 CALL var_clean( td_file%t_var(:) ) 1985 DEALLOCATE(td_file%t_var) 1971 1986 ENDIF 1972 1987 1973 1988 ! 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 1989 td_file=file_copy(tl_file) 1990 1991 END SUBROUTINE file__clean_unit 1992 !------------------------------------------------------------------- 1993 !> @brief 1994 !> This subroutine clean file array of file strcuture. 1995 ! 1996 !> @author J.Paul 1997 !> @date Marsh, 2014 - Inital version 1998 ! 1999 !> @param[inout] td_file array file strcuture 2000 !------------------------------------------------------------------- 2001 SUBROUTINE file__clean_arr( td_file ) 2002 IMPLICIT NONE 2003 ! Argument 2004 TYPE(TFILE), DIMENSION(:), INTENT(INOUT) :: td_file 2005 2006 ! local variable 2007 ! loop indices 2008 INTEGER(i4) :: ji 2009 !---------------------------------------------------------------- 2010 2011 DO ji=SIZE(td_file(:)),1,-1 2012 CALL file_clean(td_file(ji)) 2013 ENDDO 2014 2015 END SUBROUTINE file__clean_arr 2016 !------------------------------------------------------------------- 2017 !> @brief This function return the file id, in a array of file 2018 !> structure, given file name. 2019 ! 2020 !> @author J.Paul 2021 !> - November, 2013- Initial Version 2022 ! 2023 !> @param[in] td_file array of file structure 2024 !> @param[in] cd_name file name 2025 !> @return file id in array of file structure (0 if not found) 2026 !------------------------------------------------------------------- 1990 2027 INTEGER(i4) FUNCTION file_get_id(td_file, cd_name) 1991 2028 IMPLICIT NONE … … 2003 2040 il_size=SIZE(td_file(:)) 2004 2041 2005 ! check if file is in tableof file structure2042 ! check if file is in array of file structure 2006 2043 DO ji=1,il_size 2007 2044 ! look for file name 2008 CALL logger_debug(" cd_name "//TRIM(fct_lower(cd_name)) )2009 2045 IF( fct_lower(td_file(ji)%c_name) == fct_lower(cd_name) )THEN 2010 2046 2011 file_get_id= ji2047 file_get_id=td_file(ji)%i_id 2012 2048 EXIT 2013 2049 … … 2016 2052 2017 2053 END FUNCTION file_get_id 2018 !> @endcode 2054 !------------------------------------------------------------------- 2055 !> @brief 2056 !> This function get the next unused unit in array of file structure. 2057 !> 2058 !> @author J.Paul 2059 !> - September, 2014- Initial Version 2060 ! 2061 !> @param[in] td_file array of file 2062 !------------------------------------------------------------------- 2063 FUNCTION file_get_unit(td_file) 2064 IMPLICIT NONE 2065 ! Argument 2066 TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_file 2067 2068 ! function 2069 INTEGER(i4) :: file_get_unit 2070 2071 ! local variable 2072 ! loop indices 2073 !---------------------------------------------------------------- 2074 2075 file_get_unit=MAXVAL(td_file(:)%i_id)+1 2076 2077 END FUNCTION file_get_unit 2019 2078 END MODULE file 2020 2079
Note: See TracChangeset
for help on using the changeset viewer.