1 | !---------------------------------------------------------------------- |
---|
2 | ! NEMO system team, System and Interface for oceanic RElocable Nesting |
---|
3 | !---------------------------------------------------------------------- |
---|
4 | ! |
---|
5 | ! DESCRIPTION: |
---|
6 | !> This module manage multi file structure. |
---|
7 | !> |
---|
8 | !> @details |
---|
9 | !> define type TMULTI:<br/> |
---|
10 | !> @code |
---|
11 | !> TYPE(TMULTI) :: tl_multi |
---|
12 | !> @endcode |
---|
13 | !> |
---|
14 | !> to initialize a multi-file structure:<br/> |
---|
15 | !> @code |
---|
16 | !> tl_multi=multi_init(cd_varfile(:)) |
---|
17 | !> @endcode |
---|
18 | !> - cd_varfile : array of variable with file path |
---|
19 | !> ('var1:file1','var2:file2')<br/> |
---|
20 | !> file path could be replaced by a matrix of value.<br/> |
---|
21 | !> separators used to defined matrix are: |
---|
22 | !> - ',' for line |
---|
23 | !> - '/' for row |
---|
24 | !> - '\' for level<br/> |
---|
25 | !> Example:<br/> |
---|
26 | !> - 'var1:3,2,3/1,4,5' |
---|
27 | !> - 3,2,3/1,4,5 => |
---|
28 | !> @f$ \left( \begin{array}{ccc} |
---|
29 | !> 3 & 2 & 3 \\ |
---|
30 | !> 1 & 4 & 5 \end{array} \right) @f$<br/> |
---|
31 | !> |
---|
32 | !> to get the number of mpp file in mutli file structure:<br/> |
---|
33 | !> - tl_multi\%i_nmpp |
---|
34 | !> |
---|
35 | !> to get the total number of variable in mutli file structure:<br/> |
---|
36 | !> - tl_multi\%i_nvar |
---|
37 | !> |
---|
38 | !> @note number of variable and number of file could differ cause several variable |
---|
39 | !> could be in the same file. |
---|
40 | !> |
---|
41 | !> to get array of mpp structure in mutli file structure:<br/> |
---|
42 | !> - tl_multi\%t_mpp(:) |
---|
43 | !> |
---|
44 | !> to print information about multi structure:<br/> |
---|
45 | !> @code |
---|
46 | !> CALL multi_print(td_multi) |
---|
47 | !> @endcode |
---|
48 | !> |
---|
49 | !> to clean multi file strucutre:<br/> |
---|
50 | !> @code |
---|
51 | !> CALL multi_clean(td_multi) |
---|
52 | !> @endcode |
---|
53 | !> - td_multi is multi file structure |
---|
54 | !> |
---|
55 | !> @author |
---|
56 | !> J.Paul |
---|
57 | !> |
---|
58 | !> @date November, 2013 - Initial Version |
---|
59 | !> @date October, 2014 |
---|
60 | !> - use mpp file structure instead of file |
---|
61 | !> @date November, 2014 |
---|
62 | !> - Fix memory leaks bug |
---|
63 | !> |
---|
64 | !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) |
---|
65 | !---------------------------------------------------------------------- |
---|
66 | MODULE multi |
---|
67 | |
---|
68 | USE kind ! F90 kind parameter |
---|
69 | USE logger ! log file manager |
---|
70 | USE fct ! basic useful function |
---|
71 | USE dim ! dimension manager |
---|
72 | USE var ! variable manager |
---|
73 | USE file ! file manager |
---|
74 | USE iom ! I/O manager |
---|
75 | USE mpp ! MPP manager |
---|
76 | USE iom_mpp ! MPP I/O manager |
---|
77 | |
---|
78 | IMPLICIT NONE |
---|
79 | ! NOTE_avoid_public_variables_if_possible |
---|
80 | |
---|
81 | ! type and variable |
---|
82 | PUBLIC :: TMULTI !< multi file structure |
---|
83 | |
---|
84 | ! function and subroutine |
---|
85 | PUBLIC :: multi_copy !< copy multi structure |
---|
86 | PUBLIC :: multi_init !< initialise multi structure |
---|
87 | PUBLIC :: multi_clean !< clean multi strcuture |
---|
88 | PUBLIC :: multi_print !< print information about milti structure |
---|
89 | |
---|
90 | PRIVATE :: multi__add_mpp !< add file strucutre to multi file structure |
---|
91 | PRIVATE :: multi__copy_unit !< copy multi file structure |
---|
92 | PRIVATE :: multi__get_perio !< read periodicity from namelist |
---|
93 | |
---|
94 | TYPE TMULTI !< multi file structure |
---|
95 | ! general |
---|
96 | INTEGER(i4) :: i_nmpp = 0 !< number of mpp files |
---|
97 | INTEGER(i4) :: i_nvar = 0 !< total number of variables |
---|
98 | TYPE(TMPP) , DIMENSION(:), POINTER :: t_mpp => NULL() !< mpp files composing multi |
---|
99 | END TYPE |
---|
100 | |
---|
101 | INTERFACE multi_copy |
---|
102 | MODULE PROCEDURE multi__copy_unit ! copy multi file structure |
---|
103 | END INTERFACE |
---|
104 | |
---|
105 | CONTAINS |
---|
106 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
107 | FUNCTION multi__copy_unit(td_multi) & |
---|
108 | & RESULT (tf_multi) |
---|
109 | !------------------------------------------------------------------- |
---|
110 | !> @brief |
---|
111 | !> This function copy multi mpp structure in another one |
---|
112 | !> @details |
---|
113 | !> file variable value are copied in a temporary array, |
---|
114 | !> so input and output file structure value do not point on the same |
---|
115 | !> "memory cell", and so on are independant. |
---|
116 | !> |
---|
117 | !> @warning do not use on the output of a function who create or read an |
---|
118 | !> attribute (ex: tl_att=att_copy(att_init()) is forbidden). |
---|
119 | !> This will create memory leaks. |
---|
120 | !> @warning to avoid infinite loop, do not use any function inside |
---|
121 | !> this subroutine |
---|
122 | !> |
---|
123 | !> @author J.Paul |
---|
124 | !> @date November, 2013 - Initial Version |
---|
125 | !> @date November, 2014 |
---|
126 | !> - use function instead of overload assignment operator (to avoid memory leak) |
---|
127 | !> |
---|
128 | !> @param[in] td_multi mpp structure |
---|
129 | !> @return copy of input multi structure |
---|
130 | !------------------------------------------------------------------- |
---|
131 | |
---|
132 | IMPLICIT NONE |
---|
133 | |
---|
134 | ! Argument |
---|
135 | TYPE(TMULTI), INTENT(IN) :: td_multi |
---|
136 | |
---|
137 | ! function |
---|
138 | TYPE(TMULTI) :: tf_multi |
---|
139 | |
---|
140 | ! local variable |
---|
141 | TYPE(TMPP) :: tl_mpp |
---|
142 | |
---|
143 | ! loop indices |
---|
144 | INTEGER(i4) :: ji |
---|
145 | !---------------------------------------------------------------- |
---|
146 | |
---|
147 | tf_multi%i_nmpp = td_multi%i_nmpp |
---|
148 | tf_multi%i_nvar = td_multi%i_nvar |
---|
149 | |
---|
150 | ! copy variable structure |
---|
151 | IF( ASSOCIATED(tf_multi%t_mpp) )THEN |
---|
152 | CALL mpp_clean(tf_multi%t_mpp(:)) |
---|
153 | DEALLOCATE(tf_multi%t_mpp) |
---|
154 | ENDIF |
---|
155 | IF( ASSOCIATED(td_multi%t_mpp) .AND. tf_multi%i_nmpp > 0 )THEN |
---|
156 | ALLOCATE( tf_multi%t_mpp(tf_multi%i_nmpp) ) |
---|
157 | DO ji=1,tf_multi%i_nmpp |
---|
158 | tl_mpp = mpp_copy(td_multi%t_mpp(ji)) |
---|
159 | tf_multi%t_mpp(ji) = mpp_copy(tl_mpp) |
---|
160 | ENDDO |
---|
161 | ! clean |
---|
162 | CALL mpp_clean(tl_mpp) |
---|
163 | ENDIF |
---|
164 | |
---|
165 | END FUNCTION multi__copy_unit |
---|
166 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
167 | FUNCTION multi_init(cd_varfile) & |
---|
168 | & RESULT (tf_multi) |
---|
169 | !------------------------------------------------------------------- |
---|
170 | !> @brief This subroutine initialize multi file structure. |
---|
171 | !> |
---|
172 | !> @details |
---|
173 | !> if variable name is 'all', add all the variable of the file in mutli file |
---|
174 | !> structure. |
---|
175 | !> Optionnaly, periodicity could be read behind filename. |
---|
176 | !> |
---|
177 | !> @note if first character of filename is numeric, assume matrix is given as |
---|
178 | !> input.<br/> |
---|
179 | !> create pseudo file named 'data-*', with matrix read as variable value. |
---|
180 | !> |
---|
181 | !> @author J.Paul |
---|
182 | !> @date November, 2013 - Initial Version |
---|
183 | !> @date July, 2015 |
---|
184 | !> - check if variable to be read is in file |
---|
185 | !> @date January, 2016 |
---|
186 | !> - read variable dimensions |
---|
187 | !> @date July, 2016 |
---|
188 | !> - get variable to be read and associated file first |
---|
189 | !> @date August, 2017 |
---|
190 | !> - get perio from namelist |
---|
191 | !> @date January, 2019 |
---|
192 | !> - create and clean file structure to avoid memory leaks |
---|
193 | !> - fill value read from array of variable structure |
---|
194 | !> @date May, 2019 |
---|
195 | !> - compare each elt of cl_tabfile to cl_file |
---|
196 | !> @date August, 2019 |
---|
197 | !> - use periodicity read from namelist, and store in multi structure |
---|
198 | !> |
---|
199 | !> @param[in] cd_varfile variable location information (from namelist) |
---|
200 | !> @return multi file structure |
---|
201 | !------------------------------------------------------------------- |
---|
202 | |
---|
203 | IMPLICIT NONE |
---|
204 | |
---|
205 | ! Argument |
---|
206 | CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_varfile |
---|
207 | |
---|
208 | ! function |
---|
209 | TYPE(TMULTI) :: tf_multi |
---|
210 | |
---|
211 | ! parameters |
---|
212 | INTEGER(i4) , PARAMETER :: ip_nmaxfiles = 50 |
---|
213 | INTEGER(i4) , PARAMETER :: ip_nmaxvars = 100 |
---|
214 | |
---|
215 | ! local variable |
---|
216 | INTEGER(i4) :: il_nvar |
---|
217 | INTEGER(i4) :: il_nvarin |
---|
218 | INTEGER(i4) :: il_nfiles |
---|
219 | INTEGER(i4) :: il_varid |
---|
220 | INTEGER(i4) :: il_perio |
---|
221 | |
---|
222 | REAL(dp) :: dl_fill |
---|
223 | CHARACTER(LEN=lc) :: cl_name |
---|
224 | CHARACTER(LEN=lc) :: cl_varname |
---|
225 | CHARACTER(LEN=lc) :: cl_lower |
---|
226 | CHARACTER(LEN=lc) :: cl_file |
---|
227 | CHARACTER(LEN=lc) :: cl_matrix |
---|
228 | |
---|
229 | CHARACTER(LEN=lc), DIMENSION(ip_nmaxfiles) :: cl_tabfile |
---|
230 | CHARACTER(LEN=lc), DIMENSION(ip_nmaxfiles, ip_nmaxvars) :: cl_tabvar |
---|
231 | |
---|
232 | LOGICAL :: ll_dim |
---|
233 | |
---|
234 | TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim |
---|
235 | |
---|
236 | TYPE(TVAR) :: tl_var |
---|
237 | TYPE(TVAR) , DIMENSION(:), ALLOCATABLE :: tl_varin |
---|
238 | |
---|
239 | TYPE(TMPP) :: tl_mpp |
---|
240 | |
---|
241 | TYPE(TFILE) :: tl_file |
---|
242 | |
---|
243 | ! loop indices |
---|
244 | INTEGER(i4) :: ji |
---|
245 | INTEGER(i4) :: jj |
---|
246 | INTEGER(i4) :: jk |
---|
247 | INTEGER(i4) :: jl |
---|
248 | INTEGER(i4) :: jf |
---|
249 | INTEGER(i4) , DIMENSION(ip_nmaxvars) :: jv |
---|
250 | !---------------------------------------------------------------- |
---|
251 | |
---|
252 | ji=1 |
---|
253 | jf=0 |
---|
254 | jv(:)=0 |
---|
255 | cl_tabfile(:)='' |
---|
256 | DO WHILE( TRIM(cd_varfile(ji)) /= '' ) |
---|
257 | |
---|
258 | cl_name=fct_split(cd_varfile(ji),1,':') |
---|
259 | IF( TRIM(cl_name) == '' )THEN |
---|
260 | CALL logger_error("MULTI INIT: variable name "//& |
---|
261 | & "is empty. check namelist.") |
---|
262 | ENDIF |
---|
263 | |
---|
264 | cl_file=fct_split(cd_varfile(ji),2,':') |
---|
265 | IF( TRIM(cl_file) == '' )THEN |
---|
266 | CALL logger_error("MULTI INIT: file name matching variable "//& |
---|
267 | & TRIM(cl_name)//" is empty. check namelist.") |
---|
268 | ENDIF |
---|
269 | IF( LEN(TRIM(cl_file)) >= lc )THEN |
---|
270 | CALL logger_fatal("MULTI INIT: file name too long (>"//& |
---|
271 | & TRIM(fct_str(lc))//"). check namelist.") |
---|
272 | ENDIF |
---|
273 | |
---|
274 | IF( TRIM(cl_file) /= '' )THEN |
---|
275 | jk=0 |
---|
276 | DO jj=1,jf |
---|
277 | IF( TRIM(cl_file) == TRIM(cl_tabfile(jj)) )THEN |
---|
278 | jk=jj |
---|
279 | EXIT |
---|
280 | ENDIF |
---|
281 | ENDDO |
---|
282 | IF ( jk /= 0 )then |
---|
283 | jv(jk)=jv(jk)+1 |
---|
284 | cl_tabvar(jk,jv(jk))=TRIM(cl_name) |
---|
285 | ELSE ! jk == 0 |
---|
286 | jf=jf+1 |
---|
287 | IF( jf > ip_nmaxfiles )THEN |
---|
288 | CALL logger_fatal("MULTI INIT: too much files in "//& |
---|
289 | & "varfile (>"//TRIM(fct_str(ip_nmaxfiles))//& |
---|
290 | & "). check namelist.") |
---|
291 | ENDIF |
---|
292 | cl_tabfile(jf)=TRIM(cl_file) |
---|
293 | jv(jf)=jv(jf)+1 |
---|
294 | cl_tabvar(jf,jv(jf))=TRIM(cl_name) |
---|
295 | ENDIF |
---|
296 | ENDIF |
---|
297 | |
---|
298 | ji=ji+1 |
---|
299 | ENDDO |
---|
300 | |
---|
301 | !print *,'============' |
---|
302 | !print *,jf,' files ','============' |
---|
303 | !DO ji=1,jf |
---|
304 | ! print *,'file ',trim(cl_tabfile(ji)) |
---|
305 | ! print *,jv(ji),' vars ' |
---|
306 | ! DO jj=1,jv(ji) |
---|
307 | ! print *,'var ',trim(cl_tabvar(ji,jj)) |
---|
308 | ! ENDDO |
---|
309 | !ENDDO |
---|
310 | !print *,'============' |
---|
311 | |
---|
312 | |
---|
313 | il_nfiles=jf |
---|
314 | il_nvar=0 |
---|
315 | DO ji=1,il_nfiles |
---|
316 | cl_file=TRIM(cl_tabfile(ji)) |
---|
317 | |
---|
318 | cl_matrix='' |
---|
319 | IF( fct_is_num(cl_file(1:1)) )THEN |
---|
320 | cl_matrix=TRIM(cl_file) |
---|
321 | WRITE(cl_file,'(a,i2.2)')'data-',ji |
---|
322 | |
---|
323 | DO jj=1,jv(ji) |
---|
324 | cl_name=TRIM(cl_tabvar(ji,jv(ji))) |
---|
325 | cl_lower=TRIM(fct_lower(cl_name)) |
---|
326 | |
---|
327 | tl_var=var_init(TRIM(cl_name)) |
---|
328 | CALL var_read_matrix(tl_var, cl_matrix) |
---|
329 | |
---|
330 | IF( jj == 1 )THEN |
---|
331 | ! create mpp structure |
---|
332 | tl_mpp=mpp_init(TRIM(cl_file), tl_var) |
---|
333 | ENDIF |
---|
334 | |
---|
335 | ! add variable |
---|
336 | CALL mpp_add_var(tl_mpp,tl_var) |
---|
337 | ! number of variable |
---|
338 | il_nvar=il_nvar+1 |
---|
339 | |
---|
340 | ENDDO |
---|
341 | |
---|
342 | ELSE |
---|
343 | CALL multi__get_perio(cl_file, il_perio) |
---|
344 | |
---|
345 | tl_file=file_init(TRIM(cl_file), id_perio=il_perio) |
---|
346 | tl_mpp=mpp_init( tl_file, id_perio=il_perio ) |
---|
347 | ! clean |
---|
348 | CALL file_clean(tl_file) |
---|
349 | |
---|
350 | il_nvarin=tl_mpp%t_proc(1)%i_nvar |
---|
351 | ALLOCATE(tl_varin(il_nvarin)) |
---|
352 | DO jj=1,il_nvarin |
---|
353 | tl_varin(jj)=var_copy(tl_mpp%t_proc(1)%t_var(jj)) |
---|
354 | DO jl=1,ip_maxdim |
---|
355 | IF( tl_varin(jj)%t_dim(jl)%l_use )THEN |
---|
356 | tl_varin(jj)%t_dim(jl)=dim_copy(tl_mpp%t_dim(jl)) |
---|
357 | ENDIF |
---|
358 | ENDDO |
---|
359 | ENDDO |
---|
360 | |
---|
361 | ! clean all varible |
---|
362 | CALL mpp_del_var(tl_mpp) |
---|
363 | |
---|
364 | DO jj=1,jv(ji) |
---|
365 | cl_name=TRIM(cl_tabvar(ji,jj)) |
---|
366 | cl_lower=TRIM(fct_lower(cl_name)) |
---|
367 | ! define variable |
---|
368 | IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN |
---|
369 | |
---|
370 | ! check if variable is in file |
---|
371 | il_varid=var_get_index(tl_varin(:),cl_lower) |
---|
372 | IF( il_varid == 0 )THEN |
---|
373 | CALL logger_fatal("MULTI INIT: variable "//& |
---|
374 | & TRIM(cl_name)//" not in file "//& |
---|
375 | & TRIM(cl_file) ) |
---|
376 | ENDIF |
---|
377 | |
---|
378 | ! get (global) variable dimension |
---|
379 | tl_dim(jp_I)=dim_copy(tl_varin(il_varid)%t_dim(jp_I)) |
---|
380 | tl_dim(jp_J)=dim_copy(tl_varin(il_varid)%t_dim(jp_J)) |
---|
381 | tl_dim(jp_K)=dim_copy(tl_varin(il_varid)%t_dim(jp_K)) |
---|
382 | tl_dim(jp_L)=dim_copy(tl_varin(il_varid)%t_dim(jp_L)) |
---|
383 | |
---|
384 | cl_varname=tl_varin(il_varid)%c_name |
---|
385 | dl_fill=tl_varin(il_varid)%d_fill |
---|
386 | |
---|
387 | tl_var=var_init(TRIM(cl_varname), td_dim=tl_dim(:), & |
---|
388 | & dd_fill=dl_fill) |
---|
389 | |
---|
390 | ! add variable |
---|
391 | CALL mpp_add_var(tl_mpp,tl_var) |
---|
392 | |
---|
393 | ! number of variable |
---|
394 | il_nvar=il_nvar+1 |
---|
395 | |
---|
396 | ! clean structure |
---|
397 | CALL var_clean(tl_var) |
---|
398 | |
---|
399 | ELSE ! cl_lower == 'all' |
---|
400 | |
---|
401 | DO jk=il_nvarin,1,-1 |
---|
402 | |
---|
403 | ! check if variable is dimension |
---|
404 | ll_dim=.FALSE. |
---|
405 | DO jl=1,ip_maxdim |
---|
406 | IF( TRIM(tl_mpp%t_proc(1)%t_dim(jl)%c_name) == & |
---|
407 | & TRIM(tl_varin(jk)%c_name) )THEN |
---|
408 | ll_dim=.TRUE. |
---|
409 | CALL logger_trace("MULTI INIT: "//& |
---|
410 | & TRIM(tl_varin(jk)%c_name)//& |
---|
411 | & ' is var dimension') |
---|
412 | EXIT |
---|
413 | ENDIF |
---|
414 | ENDDO |
---|
415 | ! do not use variable dimension |
---|
416 | IF( ll_dim )THEN |
---|
417 | tl_var=var_init( TRIM(tl_varin(jk)%c_name) ) |
---|
418 | ! delete variable |
---|
419 | CALL mpp_del_var(tl_mpp,tl_var) |
---|
420 | ! clean structure |
---|
421 | CALL var_clean(tl_var) |
---|
422 | ELSE |
---|
423 | ! add variable |
---|
424 | CALL mpp_add_var(tl_mpp, tl_varin(jk)) |
---|
425 | ! number of variable |
---|
426 | il_nvar=il_nvar+1 |
---|
427 | ENDIF |
---|
428 | |
---|
429 | ENDDO |
---|
430 | |
---|
431 | ENDIF |
---|
432 | ENDDO |
---|
433 | ! clean structure |
---|
434 | CALL var_clean(tl_varin) |
---|
435 | DEALLOCATE(tl_varin) |
---|
436 | |
---|
437 | ENDIF |
---|
438 | |
---|
439 | CALL multi__add_mpp(tf_multi, tl_mpp) |
---|
440 | |
---|
441 | ! update total number of variable |
---|
442 | tf_multi%i_nvar=tf_multi%i_nvar+tl_mpp%t_proc(1)%i_nvar |
---|
443 | |
---|
444 | ! clean |
---|
445 | CALL mpp_clean(tl_mpp) |
---|
446 | |
---|
447 | ENDDO |
---|
448 | |
---|
449 | END FUNCTION multi_init |
---|
450 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
451 | SUBROUTINE multi_clean(td_multi) |
---|
452 | !------------------------------------------------------------------- |
---|
453 | !> @brief This subroutine clean multi file strucutre. |
---|
454 | !> |
---|
455 | !> @author J.Paul |
---|
456 | !> @date November, 2013 - Initial Version |
---|
457 | !> @date January, 2019 |
---|
458 | !> - nullify mpp structure in multi file structure |
---|
459 | !> |
---|
460 | !> @param[in] td_multi multi file structure |
---|
461 | !------------------------------------------------------------------- |
---|
462 | |
---|
463 | IMPLICIT NONE |
---|
464 | |
---|
465 | ! Argument |
---|
466 | TYPE(TMULTI), INTENT(INOUT) :: td_multi |
---|
467 | |
---|
468 | ! local variable |
---|
469 | TYPE(TMULTI) :: tl_multi ! empty multi file structure |
---|
470 | |
---|
471 | ! loop indices |
---|
472 | !---------------------------------------------------------------- |
---|
473 | |
---|
474 | CALL logger_info( " CLEAN: reset multi file " ) |
---|
475 | |
---|
476 | IF( ASSOCIATED( td_multi%t_mpp ) )THEN |
---|
477 | CALL mpp_clean(td_multi%t_mpp(:)) |
---|
478 | DEALLOCATE(td_multi%t_mpp) |
---|
479 | NULLIFY(td_multi%t_mpp) |
---|
480 | ENDIF |
---|
481 | |
---|
482 | ! replace by empty structure |
---|
483 | td_multi=multi_copy(tl_multi) |
---|
484 | |
---|
485 | END SUBROUTINE multi_clean |
---|
486 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
487 | SUBROUTINE multi_print(td_multi) |
---|
488 | !------------------------------------------------------------------- |
---|
489 | !> @brief This subroutine print some information about mpp strucutre. |
---|
490 | !> |
---|
491 | !> @author J.Paul |
---|
492 | !> @date November, 2013 - Initial Version |
---|
493 | !> @date January, 2019 |
---|
494 | !> - print periodicity |
---|
495 | !> @date May, 2019 |
---|
496 | !> - specify format output |
---|
497 | !> |
---|
498 | !> @param[in] td_multi multi file structure |
---|
499 | !------------------------------------------------------------------- |
---|
500 | |
---|
501 | IMPLICIT NONE |
---|
502 | |
---|
503 | ! Argument |
---|
504 | TYPE(TMULTI), INTENT(IN) :: td_multi |
---|
505 | |
---|
506 | ! local variable |
---|
507 | |
---|
508 | ! loop indices |
---|
509 | INTEGER(i4) :: ji |
---|
510 | INTEGER(i4) :: jj |
---|
511 | !---------------------------------------------------------------- |
---|
512 | |
---|
513 | ! print file |
---|
514 | IF( td_multi%i_nmpp /= 0 .AND. ASSOCIATED(td_multi%t_mpp) )THEN |
---|
515 | WRITE(*,'(/a,i3)') 'MULTI: total number of file(s): ',& |
---|
516 | & td_multi%i_nmpp |
---|
517 | WRITE(*,'(6x,a,i3)') ' total number of variable(s): ',& |
---|
518 | & td_multi%i_nvar |
---|
519 | DO ji=1,td_multi%i_nmpp |
---|
520 | WRITE(*,'(3x,3a)') 'FILE ',TRIM(td_multi%t_mpp(ji)%c_name),& |
---|
521 | & ' CONTAINS' |
---|
522 | DO jj=1,td_multi%t_mpp(ji)%t_proc(1)%i_nvar |
---|
523 | IF( ASSOCIATED(td_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN |
---|
524 | WRITE(*,'(6x,a)') & |
---|
525 | & TRIM(td_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) |
---|
526 | !WRITE(*,'(6x,a,i0)') 'perio ',td_multi%t_mpp(ji)%t_proc(1)%i_perio |
---|
527 | ENDIF |
---|
528 | ENDDO |
---|
529 | ENDDO |
---|
530 | ENDIF |
---|
531 | |
---|
532 | END SUBROUTINE multi_print |
---|
533 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
534 | SUBROUTINE multi__add_mpp(td_multi, td_mpp) |
---|
535 | !------------------------------------------------------------------- |
---|
536 | !> @brief |
---|
537 | !> This subroutine add file to multi file structure. |
---|
538 | !> |
---|
539 | !> @detail |
---|
540 | !> |
---|
541 | !> @author J.Paul |
---|
542 | !> @date November, 2013 - Initial Version |
---|
543 | !> @date October, 2014 |
---|
544 | !> - use mpp file structure instead of file |
---|
545 | !> @date January, 2019 |
---|
546 | !> - deallocate mpp structure whatever happens |
---|
547 | !> |
---|
548 | !> @param[inout] td_multi multi mpp file strcuture |
---|
549 | !> @param[in] td_mpp mpp file strcuture |
---|
550 | !> @return mpp file id in multi mpp file structure |
---|
551 | !------------------------------------------------------------------- |
---|
552 | |
---|
553 | IMPLICIT NONE |
---|
554 | |
---|
555 | ! Argument |
---|
556 | TYPE(TMULTI), INTENT(INOUT) :: td_multi |
---|
557 | TYPE(TMPP) , INTENT(IN) :: td_mpp |
---|
558 | |
---|
559 | ! local variable |
---|
560 | INTEGER(i4) :: il_status |
---|
561 | INTEGER(i4) :: il_mppid |
---|
562 | |
---|
563 | TYPE(TMPP), DIMENSION(:), ALLOCATABLE :: tl_mpp |
---|
564 | |
---|
565 | ! loop indices |
---|
566 | INTEGER(i4) :: ji |
---|
567 | !---------------------------------------------------------------- |
---|
568 | |
---|
569 | il_mppid=0 |
---|
570 | IF( ASSOCIATED(td_multi%t_mpp) )THEN |
---|
571 | il_mppid=mpp_get_index(td_multi%t_mpp(:),TRIM(td_mpp%c_name)) |
---|
572 | ENDIF |
---|
573 | |
---|
574 | IF( il_mppid /= 0 )THEN |
---|
575 | |
---|
576 | CALL logger_debug( " MULTI ADD FILE: mpp file "//TRIM(td_mpp%c_name)//& |
---|
577 | & " already in multi mpp file structure") |
---|
578 | |
---|
579 | ! add new variable |
---|
580 | DO ji=1,td_mpp%t_proc(1)%i_nvar |
---|
581 | CALL mpp_add_var(td_multi%t_mpp(il_mppid), td_mpp%t_proc(1)%t_var(ji)) |
---|
582 | ENDDO |
---|
583 | |
---|
584 | ELSE |
---|
585 | |
---|
586 | CALL logger_trace("MULTI ADD MPP: add mpp "//& |
---|
587 | & TRIM(td_mpp%c_name)//" in multi mpp file structure") |
---|
588 | |
---|
589 | IF( td_multi%i_nmpp > 0 )THEN |
---|
590 | ! |
---|
591 | ! already other mpp file in multi file structure |
---|
592 | ALLOCATE( tl_mpp(td_multi%i_nmpp), stat=il_status ) |
---|
593 | IF(il_status /= 0 )THEN |
---|
594 | |
---|
595 | CALL logger_error( " MULTI ADD MPP FILE: not enough space to put & |
---|
596 | & mpp file in multi mpp file structure") |
---|
597 | |
---|
598 | ELSE |
---|
599 | ! save temporary multi file structure |
---|
600 | tl_mpp(:)=mpp_copy(td_multi%t_mpp(:)) |
---|
601 | |
---|
602 | CALL mpp_clean(td_multi%t_mpp(:)) |
---|
603 | DEALLOCATE( td_multi%t_mpp ) |
---|
604 | ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status) |
---|
605 | IF(il_status /= 0 )THEN |
---|
606 | |
---|
607 | CALL logger_error( " MULTI ADD MPP FILE: not enough space "//& |
---|
608 | & "to put mpp file in multi mpp file structure ") |
---|
609 | |
---|
610 | ENDIF |
---|
611 | |
---|
612 | ! copy mpp file in multi mpp file before |
---|
613 | td_multi%t_mpp(1:td_multi%i_nmpp) = mpp_copy(tl_mpp(:)) |
---|
614 | |
---|
615 | ! clean |
---|
616 | CALL mpp_clean(tl_mpp(:)) |
---|
617 | ENDIF |
---|
618 | DEALLOCATE(tl_mpp) |
---|
619 | |
---|
620 | ELSE |
---|
621 | ! no file in multi file structure |
---|
622 | IF( ASSOCIATED(td_multi%t_mpp) )THEN |
---|
623 | CALL mpp_clean(td_multi%t_mpp(:)) |
---|
624 | DEALLOCATE(td_multi%t_mpp) |
---|
625 | ENDIF |
---|
626 | ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status ) |
---|
627 | IF(il_status /= 0 )THEN |
---|
628 | |
---|
629 | CALL logger_error( " MULTI ADD MPP FILE: not enough space "//& |
---|
630 | & "to put mpp file in multi mpp file structure " ) |
---|
631 | |
---|
632 | ENDIF |
---|
633 | ENDIF |
---|
634 | |
---|
635 | ! update number of mpp |
---|
636 | td_multi%i_nmpp=td_multi%i_nmpp+1 |
---|
637 | |
---|
638 | ! add new mpp |
---|
639 | td_multi%t_mpp(td_multi%i_nmpp)=mpp_copy(td_mpp) |
---|
640 | |
---|
641 | ENDIF |
---|
642 | |
---|
643 | END SUBROUTINE multi__add_mpp |
---|
644 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
645 | SUBROUTINE multi__get_perio(cd_file, id_perio) |
---|
646 | !------------------------------------------------------------------- |
---|
647 | !> @brief |
---|
648 | !> This subroutine check if variable file, read in namelist, contains |
---|
649 | !> periodicity value and return it if true. |
---|
650 | !> |
---|
651 | !> @details |
---|
652 | !> periodicity value is assume to follow string "perio =" |
---|
653 | !> |
---|
654 | !> @author J.Paul |
---|
655 | !> @date January, 2019 - Initial Version |
---|
656 | !> @date August, 209 |
---|
657 | !> - rewrite function to subroutine |
---|
658 | !> - output filename string contains only filename (no more periodicity if |
---|
659 | !> given) |
---|
660 | !> |
---|
661 | !> @param[inout] cd_file file name |
---|
662 | !> @param[ out] id_perio NEMO periodicity |
---|
663 | !------------------------------------------------------------------- |
---|
664 | |
---|
665 | IMPLICIT NONE |
---|
666 | |
---|
667 | ! Argument |
---|
668 | CHARACTER(LEN=*), INTENT(INOUT) :: cd_file |
---|
669 | INTEGER(i4) , INTENT( OUT) :: id_perio |
---|
670 | |
---|
671 | ! local variable |
---|
672 | CHARACTER(LEN=lc) :: cl_tmp |
---|
673 | CHARACTER(LEN=lc) :: cl_perio |
---|
674 | |
---|
675 | INTEGER(i4) :: il_ind |
---|
676 | |
---|
677 | ! loop indices |
---|
678 | INTEGER(i4) :: ji |
---|
679 | INTEGER(i4) :: jj |
---|
680 | !---------------------------------------------------------------- |
---|
681 | |
---|
682 | ! init |
---|
683 | cl_perio='' |
---|
684 | id_perio=-1 |
---|
685 | |
---|
686 | ji=1 |
---|
687 | cl_tmp=fct_split(cd_file,ji,';') |
---|
688 | DO WHILE( TRIM(cl_tmp) /= '' ) |
---|
689 | il_ind=INDEX(TRIM(cl_tmp),'perio') |
---|
690 | IF( il_ind /= 0 )THEN |
---|
691 | ! check character just after |
---|
692 | jj=il_ind+LEN('perio') |
---|
693 | IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & |
---|
694 | & TRIM(cl_tmp(jj:jj)) == '=' )THEN |
---|
695 | cl_perio=fct_split(cl_tmp,2,'=') |
---|
696 | EXIT |
---|
697 | ENDIF |
---|
698 | ENDIF |
---|
699 | ji=ji+1 |
---|
700 | cl_tmp=fct_split(cd_file,ji,';') |
---|
701 | ENDDO |
---|
702 | cd_file=fct_split(cd_file,1,';') |
---|
703 | |
---|
704 | IF( TRIM(cl_perio) /= '' )THEN |
---|
705 | IF( fct_is_num(cl_perio) )THEN |
---|
706 | READ(cl_perio,*) id_perio |
---|
707 | CALL logger_debug("MULTI GET PERIO: will use periodicity value of "//& |
---|
708 | & TRIM(fct_str(id_perio))//" for file "//TRIM(cd_file) ) |
---|
709 | ELSE |
---|
710 | CALL logger_error("MULTI GET PERIO: invalid periodicity value ("//& |
---|
711 | & TRIM(cl_perio)//") for file "//TRIM(cd_file)//& |
---|
712 | & ". check namelist." ) |
---|
713 | ENDIF |
---|
714 | ENDIF |
---|
715 | |
---|
716 | END SUBROUTINE multi__get_perio |
---|
717 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
718 | END MODULE multi |
---|
719 | |
---|