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/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/UKMO/dev_r5518_obs_oper_update_icethick/NEMOGCM/TOOLS/SIREN/src/multi.f90 @ 9987

Last change on this file since 9987 was 9987, checked in by emmafiedler, 6 years ago

Merge with GO6 FOAMv14 package branch r9288

File size: 16.5 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
64!> - Fix memory leaks bug
65!
66!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
67!----------------------------------------------------------------------
68MODULE multi
69   USE kind                            ! F90 kind parameter
70   USE logger                          ! log file manager
71   USE fct                             ! basic useful function
72   USE dim                             ! dimension manager
73   USE var                             ! variable manager
74   USE file                            ! file manager
75   USE iom                             ! I/O manager
76   USE mpp                             ! MPP manager
77   USE iom_mpp                         ! MPP I/O manager
78
79   IMPLICIT NONE
80   ! NOTE_avoid_public_variables_if_possible
81
82   ! type and variable
83   PUBLIC :: TMULTI       !< multi file structure
84
85   ! function and subroutine
86   PUBLIC :: multi_copy        !< copy multi structure
87   PUBLIC :: multi_init        !< initialise multi structure
88   PUBLIC :: multi_clean       !< clean multi strcuture
89   PUBLIC :: multi_print       !< print information about milti structure
90
91   PUBLIC :: multi__add_mpp    !< add file strucutre to multi file structure
92   PRIVATE :: multi__copy_unit !< copy multi file structure
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
105CONTAINS
106   !-------------------------------------------------------------------
107   !> @brief
108   !> This function copy multi mpp structure in another one
109   !> @details
110   !> file variable value are copied in a temporary array,
111   !> so input and output file structure value do not point on the same
112   !> "memory cell", and so on are independant.
113   !>
114   !> @warning do not use on the output of a function who create or read an
115   !> attribute (ex: tl_att=att_copy(att_init()) is forbidden).
116   !> This will create memory leaks.
117   !> @warning to avoid infinite loop, do not use any function inside
118   !> this subroutine
119   !>   
120   !> @author J.Paul
121   !> @date November, 2013 - Initial Version
122   !> @date November, 2014
123   !>    - use function instead of overload assignment operator (to avoid memory leak)
124   !>
125   !> @param[in] td_multi    mpp structure
126   !> @return copy of input multi structure
127   !-------------------------------------------------------------------
128   FUNCTION multi__copy_unit( td_multi )
129      IMPLICIT NONE
130      ! Argument
131      TYPE(TMULTI), INTENT(IN)  :: td_multi
132      ! function
133      TYPE(TMULTI) :: multi__copy_unit
134
135      ! local variable
136      TYPE(TMPP) :: tl_mpp
137
138      ! loop indices
139      INTEGER(i4) :: ji
140      !----------------------------------------------------------------
141
142      multi__copy_unit%i_nmpp = td_multi%i_nmpp
143      multi__copy_unit%i_nvar = td_multi%i_nvar
144
145      ! copy variable structure
146      IF( ASSOCIATED(multi__copy_unit%t_mpp) )THEN
147         CALL mpp_clean(multi__copy_unit%t_mpp(:))
148         DEALLOCATE(multi__copy_unit%t_mpp)
149      ENDIF
150      IF( ASSOCIATED(td_multi%t_mpp) .AND. multi__copy_unit%i_nmpp > 0 )THEN
151         ALLOCATE( multi__copy_unit%t_mpp(multi__copy_unit%i_nmpp) )
152         DO ji=1,multi__copy_unit%i_nmpp
153            tl_mpp = mpp_copy(td_multi%t_mpp(ji))
154            multi__copy_unit%t_mpp(ji) = mpp_copy(tl_mpp)
155         ENDDO
156         ! clean
157         CALL mpp_clean(tl_mpp)
158      ENDIF
159
160   END FUNCTION multi__copy_unit
161   !-------------------------------------------------------------------
162   !> @brief This subroutine initialize multi file structure.
163   !>
164   !> @details
165   !> if variable name is 'all', add all the variable of the file in mutli file
166   !> structure.
167   !> @note if first character of filename is numeric, assume matrix is given as
168   !> input.<br/>
169   !> create pseudo file named 'data-*', with matrix read as variable value.
170   !>
171   !> @author J.Paul
172   !> @date November, 2013 - Initial Version
173   !> @date July, 2015
174   !> - check if variable to be read is in file
175   !>
176   !> @param[in] cd_varfile   variable location information (from namelist)
177   !> @return multi file structure
178   !-------------------------------------------------------------------
179   FUNCTION multi_init(cd_varfile)
180      IMPLICIT NONE
181
182      ! Argument
183      CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: cd_varfile
184
185      ! function
186      TYPE(TMULTI) :: multi_init
187
188      ! local variable
189      CHARACTER(LEN=lc) :: cl_name
190      CHARACTER(LEN=lc) :: cl_lower
191      CHARACTER(LEN=lc) :: cl_file
192      CHARACTER(LEN=lc) :: cl_matrix
193
194      INTEGER(i4)       :: il_nvar
195      INTEGER(i4)       :: il_varid
196
197      LOGICAL           :: ll_dim
198
199      TYPE(TVAR)        :: tl_var
200
201      TYPE(TMPP)        :: tl_mpp
202
203      ! loop indices
204      INTEGER(i4) :: ji
205      INTEGER(i4) :: jj
206      INTEGER(i4) :: jk
207      !----------------------------------------------------------------
208
209      ji=1
210      DO WHILE( TRIM(cd_varfile(ji)) /= '' )
211
212         il_nvar=0
213         cl_name=fct_split(cd_varfile(ji),1,':')
214         cl_lower=fct_lower(cl_name)
215         cl_file=fct_split(cd_varfile(ji),2,':')
216
217         IF( LEN(TRIM(cl_file)) == lc )THEN
218            CALL logger_fatal("MULTI INIT: file name too long (==256)."//&
219            &  " check namelist.")
220         ENDIF
221
222         IF( TRIM(cl_lower) /= '' )THEN
223            IF( TRIM(cl_file) /= '' )THEN
224               cl_matrix=''
225               IF( fct_is_num(cl_file(1:1)) )THEN
226                  cl_matrix=TRIM(cl_file)
227                  WRITE(cl_file,'(a,i2.2)')'data-',ji
228
229                  tl_var=var_init(TRIM(cl_name))
230                  CALL var_read_matrix(tl_var, cl_matrix)
231
232                  ! create mpp structure
233                  tl_mpp=mpp_init(TRIM(cl_file), tl_var)
234
235                  ! add variable
236                  CALL mpp_add_var(tl_mpp,tl_var)
237
238                  ! number of variable
239                  il_nvar=il_nvar+1
240
241               ELSE
242
243                  !
244                  tl_mpp=mpp_init( file_init(TRIM(cl_file)) )
245
246                  ! define variable
247                  IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN
248
249                     ! check if variable is in file
250                     il_varid=var_get_index(tl_mpp%t_proc(1)%t_var(:),cl_lower)
251                     IF( il_varid == 0 )THEN
252                        CALL logger_fatal("MULTI INIT: variable "//&
253                           & TRIM(cl_name)//" not in file "//&
254                           & TRIM(cl_file) )
255                     ENDIF
256
257                     ! clean var
258                     CALL mpp_del_var(tl_mpp)
259
260                     tl_var=var_init(TRIM(cl_lower))
261
262                     ! add variable
263                     CALL mpp_add_var(tl_mpp,tl_var)
264
265                     ! number of variable
266                     il_nvar=il_nvar+1
267
268                     ! clean structure
269                     CALL var_clean(tl_var)
270
271                  ELSE ! cl_lower == 'all'
272
273                     DO jk=tl_mpp%t_proc(1)%i_nvar,1,-1
274                       
275                        ! check if variable is dimension
276                        ll_dim=.FALSE.
277                        DO jj=1,ip_maxdim
278                           IF( TRIM(tl_mpp%t_proc(1)%t_dim(jj)%c_name) == &
279                           &   TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name) )THEN
280                              ll_dim=.TRUE.
281                              CALL logger_trace("MULTI INIT: "//&
282                              &  TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name)//&
283                              &  ' is var dimension')
284                              EXIT
285                           ENDIF
286                        ENDDO
287                        ! do not use variable dimension
288                        IF( ll_dim )THEN
289                           tl_var=var_init( &
290                           &  TRIM(tl_mpp%t_proc(1)%t_var(jk)%c_name) )
291                           ! delete variable
292                           CALL mpp_del_var(tl_mpp,tl_var)
293                           ! clean structure
294                           CALL var_clean(tl_var)
295                        ELSE
296                           ! number of variable
297                           il_nvar=il_nvar+1
298                        ENDIF
299
300                     ENDDO
301
302                  ENDIF
303
304               ENDIF
305
306               CALL multi__add_mpp(multi_init, tl_mpp) 
307
308               ! update total number of variable
309               multi_init%i_nvar=multi_init%i_nvar+il_nvar
310
311               ! clean
312               CALL mpp_clean(tl_mpp)
313
314            ELSE
315               CALL logger_error("MULTI INIT: file name matching variable "//&
316               &                 TRIM(cl_name)//" is empty. check namelist.")
317            ENDIF
318         ELSE
319            CALL logger_error("MULTI INIT: variable name "//&
320            &                 "is empty. check namelist.")
321         ENDIF
322
323         ji=ji+1
324      ENDDO
325
326   END FUNCTION multi_init
327   !-------------------------------------------------------------------
328   !> @brief This subroutine clean multi file strucutre.
329   !
330   !> @author J.Paul
331   !> @date November, 2013 - Initial Version
332   !
333   !> @param[in] td_multi  multi file structure
334   !-------------------------------------------------------------------
335   SUBROUTINE multi_clean(td_multi)
336      IMPLICIT NONE
337
338      ! Argument     
339      TYPE(TMULTI), INTENT(INOUT) :: td_multi
340
341      ! local variable
342      TYPE(TMULTI) :: tl_multi ! empty multi file structure
343
344      ! loop indices
345      !----------------------------------------------------------------
346
347      CALL logger_info( " CLEAN: reset multi file " )
348
349      IF( ASSOCIATED( td_multi%t_mpp ) )THEN
350         CALL mpp_clean(td_multi%t_mpp(:))
351         DEALLOCATE(td_multi%t_mpp)
352      ENDIF
353
354      ! replace by empty structure
355      td_multi=multi_copy(tl_multi)
356
357   END SUBROUTINE multi_clean
358   !-------------------------------------------------------------------
359   !> @brief This subroutine print some information about mpp strucutre.
360   !
361   !> @author J.Paul
362   !> @date November, 2013 - Initial Version
363   !
364   !> @param[in] td_multi multi file structure
365   !-------------------------------------------------------------------
366   SUBROUTINE multi_print(td_multi)
367      IMPLICIT NONE
368
369      ! Argument     
370      TYPE(TMULTI), INTENT(IN) :: td_multi
371
372      ! local variable
373
374      ! loop indices
375      INTEGER(i4) :: ji
376      INTEGER(i4) :: jj
377      !----------------------------------------------------------------
378
379      ! print file
380      IF( td_multi%i_nmpp /= 0 .AND. ASSOCIATED(td_multi%t_mpp) )THEN
381         WRITE(*,'(/a,i3)') 'MULTI: total number of mpp: ',&
382         &  td_multi%i_nmpp
383         WRITE(*,'(6x,a,i3)') ' total number of variable: ',&
384         &  td_multi%i_nvar
385         DO ji=1,td_multi%i_nmpp
386            WRITE(*,'(3x,3a)') 'MPP FILE ',TRIM(td_multi%t_mpp(ji)%c_name),&
387            & ' CONTAINS'
388            DO jj=1,td_multi%t_mpp(ji)%t_proc(1)%i_nvar
389               IF( ASSOCIATED(td_multi%t_mpp(ji)%t_proc(1)%t_var) )THEN
390                  WRITE(*,'(6x,a)') &
391                  &  TRIM(td_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name)
392               ENDIF
393            ENDDO
394         ENDDO
395      ENDIF
396
397   END SUBROUTINE multi_print
398   !-------------------------------------------------------------------
399   !> @brief
400   !>    This subroutine add file to multi file structure.
401   !>
402   !> @detail
403   !
404   !> @author J.Paul
405   !> @date November, 2013 - Initial Version
406   !> @date October, 2014
407   !> - use mpp file structure instead of file
408   !
409   !> @param[inout] td_multi  multi mpp file strcuture
410   !> @param[in]    td_mpp    mpp file strcuture
411   !> @return mpp file id in multi mpp file structure
412   !-------------------------------------------------------------------
413   SUBROUTINE multi__add_mpp( td_multi, td_mpp )
414      IMPLICIT NONE
415      ! Argument
416      TYPE(TMULTI), INTENT(INOUT) :: td_multi
417      TYPE(TMPP)  , INTENT(IN)    :: td_mpp
418
419      ! local variable
420      INTEGER(i4) :: il_status
421      INTEGER(i4) :: il_mppid
422     
423      TYPE(TMPP), DIMENSION(:), ALLOCATABLE :: tl_mpp
424
425      ! loop indices
426      INTEGER(i4) :: ji
427      !----------------------------------------------------------------
428
429      il_mppid=0
430      IF( ASSOCIATED(td_multi%t_mpp) )THEN
431         il_mppid=mpp_get_index(td_multi%t_mpp(:),TRIM(td_mpp%c_name))
432      ENDIF
433
434      IF( il_mppid /= 0 )THEN
435
436            CALL logger_debug( " MULTI ADD FILE: mpp file "//TRIM(td_mpp%c_name)//&
437            &               " already in multi mpp file structure")
438
439            ! add new variable
440            DO ji=1,td_mpp%t_proc(1)%i_nvar
441               CALL mpp_add_var(td_multi%t_mpp(il_mppid), td_mpp%t_proc(1)%t_var(ji))
442            ENDDO
443
444      ELSE
445 
446         CALL logger_trace("MULTI ADD MPP: add mpp "//&
447         &               TRIM(td_mpp%c_name)//" in multi mpp file structure")
448
449         IF( td_multi%i_nmpp > 0 )THEN
450            !
451            ! already other mpp file in multi file structure
452            ALLOCATE( tl_mpp(td_multi%i_nmpp), stat=il_status )
453            IF(il_status /= 0 )THEN
454
455               CALL logger_error( " MULTI ADD MPP FILE: not enough space to put &
456               &               mpp file in multi mpp file structure")
457
458            ELSE
459               ! save temporary multi file structure
460               tl_mpp(:)=mpp_copy(td_multi%t_mpp(:))
461
462               CALL mpp_clean(td_multi%t_mpp(:))
463               DEALLOCATE( td_multi%t_mpp )
464               ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status)
465               IF(il_status /= 0 )THEN
466
467                  CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
468                  &  "to put mpp file in multi mpp file structure ")
469
470               ENDIF
471
472               ! copy mpp file in multi mpp file before
473               td_multi%t_mpp(1:td_multi%i_nmpp) = mpp_copy(tl_mpp(:))
474
475               ! clean
476               CALL mpp_clean(tl_mpp(:))
477               DEALLOCATE(tl_mpp)
478            ENDIF
479
480         ELSE
481            ! no file in multi file structure
482            IF( ASSOCIATED(td_multi%t_mpp) )THEN
483               CALL mpp_clean(td_multi%t_mpp(:))
484               DEALLOCATE(td_multi%t_mpp)
485            ENDIF
486            ALLOCATE( td_multi%t_mpp(td_multi%i_nmpp+1), stat=il_status )
487            IF(il_status /= 0 )THEN
488
489               CALL logger_error( " MULTI ADD MPP FILE: not enough space "//&
490               &  "to put mpp file in multi mpp file structure " )
491
492            ENDIF
493         ENDIF
494
495         ! update number of mpp
496         td_multi%i_nmpp=td_multi%i_nmpp+1
497
498         ! add new mpp
499         td_multi%t_mpp(td_multi%i_nmpp)=mpp_copy(td_mpp)
500
501      ENDIF
502   END SUBROUTINE multi__add_mpp
503END MODULE multi
504
Note: See TracBrowser for help on using the repository browser.