New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
multi.f90 in branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/TOOLS/SIREN/src/multi.f90 @ 5581

Last change on this file since 5581 was 5581, checked in by timgraham, 9 years ago

Merged head of trunk into branch

File size: 16.0 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5! MODULE: multi
6!
7! DESCRIPTION:
8!> This module manage multi file structure.
9!
10!> @details
11!>    define type TMULTI:<br/>
12!> @code
13!>    TYPE(TMULTI) :: tl_multi
14!> @endcode
15!>
16!>    to initialize a multi-file structure:<br/>
17!> @code
18!>    tl_multi=multi_init(cd_varfile(:))
19!> @endcode
20!>       - cd_varfile : array of variable with file path
21!>       ('var1:file1','var2:file2')<br/>
22!>          file path could be replaced by a matrix of value.<br/>
23!>          separators used to defined matrix are:
24!>             - ',' for line
25!>             - '/' for row
26!>             - '\' for level<br/>
27!>             Example:<br/>
28!>                - 'var1:3,2,3/1,4,5'
29!>                - 3,2,3/1,4,5  => 
30!>                      @f$ \left( \begin{array}{ccc}
31!>                           3 & 2 & 3 \\
32!>                           1 & 4 & 5 \end{array} \right) @f$<br/>
33!>
34!>    to get the number of mpp file in mutli file structure:<br/>
35!>    - tl_multi\%i_nmpp
36!>
37!>    to get the total number of variable in mutli file structure:<br/>
38!>    - tl_multi\%i_nvar
39!>
40!>    @note number of variable and number of file could differ cause several variable
41!>    could be in the same file.
42!>
43!>    to get array of mpp structure in mutli file structure:<br/>
44!>    - tl_multi\%t_mpp(:)
45!>
46!>    to print information about multi structure:<br/>
47!> @code
48!>    CALL multi_print(td_multi)
49!> @endcode
50!>
51!>    to clean multi file strucutre:<br/>
52!> @code
53!>    CALL multi_clean(td_multi)
54!> @endcode
55!>       - td_multi is multi file structure
56!>
57!> @author
58!>  J.Paul
59! REVISION HISTORY:
60!> @date November, 2013 - Initial Version
61!> @date October, 2014
62!> - use mpp file structure instead of file
63!> @date November, 2014 - Fix memory leaks bug
64!
65!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
66!----------------------------------------------------------------------
67MODULE multi
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   PUBLIC :: multi__add_mpp    !< add file strucutre to multi file structure
91   PRIVATE :: multi__copy_unit !< copy multi file structure
92
93   TYPE TMULTI !< multi file structure
94      ! general
95      INTEGER(i4)                         :: i_nmpp  = 0         !< number of mpp files
96      INTEGER(i4)                         :: i_nvar  = 0         !< total number of variables
97      TYPE(TMPP) , DIMENSION(:), POINTER  :: t_mpp => NULL()     !< mpp files composing multi
98   END TYPE
99
100   INTERFACE multi_copy
101      MODULE PROCEDURE multi__copy_unit   ! copy multi file structure
102   END INTERFACE   
103
104CONTAINS
105   !-------------------------------------------------------------------
106   !> @brief
107   !> This function copy multi mpp structure in another one
108   !> @details
109   !> file variable value are copied in a temporary array,
110   !> so input and output file structure value do not point on the same
111   !> "memory cell", and so on are independant.
112   !>
113   !> @warning do not use on the output of a function who create or read an
114   !> attribute (ex: tl_att=att_copy(att_init()) is forbidden).
115   !> This will create memory leaks.
116   !> @warning to avoid infinite loop, do not use any function inside
117   !> this subroutine
118   !>   
119   !> @author J.Paul
120   !> - November, 2013- Initial Version
121   !> @date November, 2014
122   !>    - use function instead of overload assignment operator (to avoid memory leak)
123   !>
124   !> @param[in] td_multi    mpp structure
125   !> @return copy of input multi structure
126   !-------------------------------------------------------------------
127   FUNCTION multi__copy_unit( td_multi )
128      IMPLICIT NONE
129      ! Argument
130      TYPE(TMULTI), INTENT(IN)  :: td_multi
131      ! function
132      TYPE(TMULTI) :: multi__copy_unit
133
134      ! local variable
135      TYPE(TMPP) :: tl_mpp
136
137      ! loop indices
138      INTEGER(i4) :: ji
139      !----------------------------------------------------------------
140
141      multi__copy_unit%i_nmpp = td_multi%i_nmpp
142      multi__copy_unit%i_nvar = td_multi%i_nvar
143
144      ! copy variable structure
145      IF( ASSOCIATED(multi__copy_unit%t_mpp) )THEN
146         CALL mpp_clean(multi__copy_unit%t_mpp(:))
147         DEALLOCATE(multi__copy_unit%t_mpp)
148      ENDIF
149      IF( ASSOCIATED(td_multi%t_mpp) .AND. multi__copy_unit%i_nmpp > 0 )THEN
150         ALLOCATE( multi__copy_unit%t_mpp(multi__copy_unit%i_nmpp) )
151         DO ji=1,multi__copy_unit%i_nmpp
152            tl_mpp = mpp_copy(td_multi%t_mpp(ji))
153            multi__copy_unit%t_mpp(ji) = mpp_copy(tl_mpp)
154         ENDDO
155         ! clean
156         CALL mpp_clean(tl_mpp)
157      ENDIF
158
159   END FUNCTION multi__copy_unit
160   !-------------------------------------------------------------------
161   !> @brief This subroutine initialize multi file structure.
162   !>
163   !> @details
164   !> if variable name is 'all', add all the variable of the file in mutli file
165   !> structure.
166   !> @note if first character of filename is numeric, assume matrix is given as
167   !> input.<br/>
168   !> create pseudo file named 'data-*', with matrix read as variable value.
169   !>
170   !> @author J.Paul
171   !> - November, 2013- Initial Version
172   !>
173   !> @param[in] cd_varfile   variable location information (from namelist)
174   !> @return multi file structure
175   !-------------------------------------------------------------------
176   FUNCTION multi_init(cd_varfile)
177      IMPLICIT NONE
178
179      ! Argument
180      CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_varfile
181
182      ! function
183      TYPE(TMULTI) :: multi_init
184
185      ! local variable
186      CHARACTER(LEN=lc) :: cl_name
187      CHARACTER(LEN=lc) :: cl_lower
188      CHARACTER(LEN=lc) :: cl_file
189      CHARACTER(LEN=lc) :: cl_matrix
190
191      INTEGER(i4)       :: il_nvar
192
193      LOGICAL           :: ll_dim
194
195      TYPE(TVAR)        :: tl_var
196
197      TYPE(TMPP)        :: tl_mpp
198
199      ! loop indices
200      INTEGER(i4) :: ji
201      INTEGER(i4) :: jj
202      INTEGER(i4) :: jk
203      !----------------------------------------------------------------
204
205      ji=1
206      DO WHILE( TRIM(cd_varfile(ji)) /= '' )
207
208         il_nvar=0
209         cl_name=fct_split(cd_varfile(ji),1,':')
210         cl_lower=fct_lower(cl_name)
211         cl_file=fct_split(cd_varfile(ji),2,':')
212
213         IF( LEN(TRIM(cl_file)) == lc )THEN
214            CALL logger_fatal("MULTI INIT: file name too long (==256)."//&
215            &  " check namelist.")
216         ENDIF
217
218         IF( TRIM(cl_lower) /= '' )THEN
219            IF( TRIM(cl_file) /= '' )THEN
220               cl_matrix=''
221               IF( fct_is_num(cl_file(1:1)) )THEN
222                  cl_matrix=TRIM(cl_file)
223                  WRITE(cl_file,'(a,i2.2)')'data-',ji
224
225                  tl_var=var_init(TRIM(cl_name))
226                  CALL var_read_matrix(tl_var, cl_matrix)
227
228                  ! create mpp structure
229                  tl_mpp=mpp_init(TRIM(cl_file), tl_var)
230
231                  ! add variable
232                  CALL mpp_add_var(tl_mpp,tl_var)
233
234                  ! number of variable
235                  il_nvar=il_nvar+1
236
237               ELSE
238
239                  !
240                  tl_mpp=mpp_init( file_init(TRIM(cl_file)) )
241
242                  ! define variable
243                  IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN
244
245                     ! clean var
246                     CALL mpp_del_var(tl_mpp)
247
248                     tl_var=var_init(TRIM(cl_lower))
249
250                     ! add variable
251                     CALL mpp_add_var(tl_mpp,tl_var)
252
253                     ! number of variable
254                     il_nvar=il_nvar+1
255
256                     ! clean structure
257                     CALL var_clean(tl_var)
258
259                  ELSE ! cl_lower == 'all'
260
261                     DO jk=tl_mpp%t_proc(1)%i_nvar,1,-1
262                       
263                        ! check if variable is dimension
264                        ll_dim=.FALSE.
265                        DO jj=1,ip_maxdim
266                           IF( TRIM(tl_mpp%t_proc(1)%t_dim(jj)%c_name) == &
267                           &   TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name) )THEN
268                              ll_dim=.TRUE.
269                              CALL logger_trace("MULTI INIT: "//&
270                              &  TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name)//&
271                              &  ' is var dimension')
272                              EXIT
273                           ENDIF
274                        ENDDO
275                        ! do not use variable dimension
276                        IF( ll_dim )THEN
277                           tl_var=var_init( &
278                           &  TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name) )
279                           ! delete variable
280                           CALL mpp_del_var(tl_mpp,tl_var)
281                           ! clean structure
282                           CALL var_clean(tl_var)
283                        ELSE
284                           ! number of variable
285                           il_nvar=il_nvar+1
286                        ENDIF
287
288                     ENDDO
289
290                  ENDIF
291
292               ENDIF
293
294               CALL multi__add_mpp(multi_init, tl_mpp) 
295
296               ! update total number of variable
297               multi_init%i_nvar=multi_init%i_nvar+il_nvar
298
299               ! clean
300               CALL mpp_clean(tl_mpp)
301
302            ELSE
303               CALL logger_error("MULTI INIT: file name matching variable "//&
304               &                 TRIM(cl_name)//" is empty. check namelist.")
305            ENDIF
306         ELSE
307            CALL logger_error("MULTI INIT: variable name "//&
308            &                 "is empty. check namelist.")
309         ENDIF
310
311         ji=ji+1
312      ENDDO
313
314   END FUNCTION multi_init
315   !-------------------------------------------------------------------
316   !> @brief This subroutine clean multi file strucutre.
317   !
318   !> @author J.Paul
319   !> - November, 2013- Initial Version
320   !
321   !> @param[in] td_multi  multi file structure
322   !-------------------------------------------------------------------
323   SUBROUTINE multi_clean(td_multi)
324      IMPLICIT NONE
325
326      ! Argument     
327      TYPE(TMULTI), INTENT(INOUT) :: td_multi
328
329      ! local variable
330      TYPE(TMULTI) :: tl_multi ! empty multi file structure
331
332      ! loop indices
333      !----------------------------------------------------------------
334
335      CALL logger_info( " CLEAN: reset multi file " )
336
337      IF( ASSOCIATED( td_multi%t_mpp ) )THEN
338         CALL mpp_clean(td_multi%t_mpp(:))
339         DEALLOCATE(td_multi%t_mpp)
340      ENDIF
341
342      ! replace by empty structure
343      td_multi=multi_copy(tl_multi)
344
345   END SUBROUTINE multi_clean
346   !-------------------------------------------------------------------
347   !> @brief This subroutine print some information about mpp strucutre.
348   !
349   !> @author J.Paul
350   !> - November, 2013- Initial Version
351   !
352   !> @param[in] td_multi multi file structure
353   !-------------------------------------------------------------------
354   SUBROUTINE multi_print(td_multi)
355      IMPLICIT NONE
356
357      ! Argument     
358      TYPE(TMULTI), INTENT(IN) :: td_multi
359
360      ! local variable
361
362      ! loop indices
363      INTEGER(i4) :: ji
364      INTEGER(i4) :: jj
365      !----------------------------------------------------------------
366
367      ! print file
368      IF( td_multi%i_nmpp /= 0 .AND. ASSOCIATED(td_multi%t_mpp) )THEN
369         WRITE(*,'(/a,i3)') 'MULTI: total number of mpp: ',&
370         &  td_multi%i_nmpp
371         WRITE(*,'(6x,a,i3)') ' total number of variable: ',&
372         &  td_multi%i_nvar
373         DO ji=1,td_multi%i_nmpp
374            WRITE(*,'(3x,3a)') 'MPP FILE ',TRIM(td_multi%t_mpp(ji)%c_name),&
375            & ' CONTAINS'
376            DO jj=1,td_multi%t_mpp(ji)%t_proc(1)%i_nvar
377               IF( ASSOCIATED(td_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
378                  WRITE(*,'(6x,a)') &
379                  &  TRIM(td_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
380               ENDIF
381            ENDDO
382         ENDDO
383      ENDIF
384
385   END SUBROUTINE multi_print
386   !-------------------------------------------------------------------
387   !> @brief
388   !>    This subroutine add file to multi file structure.
389   !>
390   !> @detail
391   !
392   !> @author J.Paul
393   !> - November, 2013- Initial Version
394   !> @date October, 2014
395   !> - use mpp file structure instead of file
396   !
397   !> @param[inout] td_multi  multi mpp file strcuture
398   !> @param[in]    td_mpp    mpp file strcuture
399   !> @return mpp file id in multi mpp file structure
400   !-------------------------------------------------------------------
401   SUBROUTINE multi__add_mpp( td_multi, td_mpp )
402      IMPLICIT NONE
403      ! Argument
404      TYPE(TMULTI), INTENT(INOUT) :: td_multi
405      TYPE(TMPP)  , INTENT(IN)    :: td_mpp
406
407      ! local variable
408      INTEGER(i4) :: il_status
409      INTEGER(i4) :: il_mppid
410     
411      TYPE(TMPP), DIMENSION(:), ALLOCATABLE :: tl_mpp
412
413      ! loop indices
414      INTEGER(i4) :: ji
415      !----------------------------------------------------------------
416
417      il_mppid=0
418      IF( ASSOCIATED(td_multi%t_mpp) )THEN
419         il_mppid=mpp_get_index(td_multi%t_mpp(:),TRIM(td_mpp%c_name))
420      ENDIF
421
422      IF( il_mppid /= 0 )THEN
423
424            CALL logger_debug( " MULTI ADD FILE: mpp file "//TRIM(td_mpp%c_name)//&
425            &               " already in multi mpp file structure")
426
427            ! add new variable
428            DO ji=1,td_mpp%t_proc(1)%i_nvar
429               CALL mpp_add_var(td_multi%t_mpp(il_mppid), td_mpp%t_proc(1)%t_var(ji))
430            ENDDO
431
432      ELSE
433 
434         CALL logger_trace("MULTI ADD MPP: add mpp "//&
435         &               TRIM(td_mpp%c_name)//" in multi mpp file structure")
436
437         IF( td_multi%i_nmpp > 0 )THEN
438            !
439            ! already other mpp file in multi file structure
440            ALLOCATE( tl_mpp(td_multi%i_nmpp), stat=il_status )
441            IF(il_status /= 0 )THEN
442
443               CALL logger_error( " MULTI ADD MPP FILE: not enough space to put &
444               &               mpp file in multi mpp file structure")
445
446            ELSE
447               ! save temporary multi file structure
448               tl_mpp(:)=mpp_copy(td_multi%t_mpp(:))
449
450               CALL mpp_clean(td_multi%t_mpp(:))
451               DEALLOCATE( td_multi%t_mpp )
452               ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status)
453               IF(il_status /= 0 )THEN
454
455                  CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
456                  &  "to put mpp file in multi mpp file structure ")
457
458               ENDIF
459
460               ! copy mpp file in multi mpp file before
461               td_multi%t_mpp(1:td_multi%i_nmpp) = mpp_copy(tl_mpp(:))
462
463               ! clean
464               CALL mpp_clean(tl_mpp(:))
465               DEALLOCATE(tl_mpp)
466            ENDIF
467
468         ELSE
469            ! no file in multi file structure
470            IF( ASSOCIATED(td_multi%t_mpp) )THEN
471               CALL mpp_clean(td_multi%t_mpp(:))
472               DEALLOCATE(td_multi%t_mpp)
473            ENDIF
474            ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status )
475            IF(il_status /= 0 )THEN
476
477               CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
478               &  "to put mpp file in multi mpp file structure " )
479
480            ENDIF
481         ENDIF
482
483         ! update number of mpp
484         td_multi%i_nmpp=td_multi%i_nmpp+1
485
486         ! add new mpp
487         td_multi%t_mpp(td_multi%i_nmpp)=mpp_copy(td_mpp)
488
489      ENDIF
490   END SUBROUTINE multi__add_mpp
491END MODULE multi
492
Note: See TracBrowser for help on using the repository browser.