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.
iom_mpp.f90 in utils/tools/SIREN/src – NEMO

source: utils/tools/SIREN/src/iom_mpp.f90 @ 12080

Last change on this file since 12080 was 12080, checked in by jpaul, 4 years ago

update nemo trunk

File size: 32.4 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5! DESCRIPTION:
6!> @brief This module manage massively parallel processing Input/Output manager.
7!> Library to read/write mpp files.
8!>
9!> @details
10!>    to open mpp files (only file to be used (see mpp_get_use)
11!>    will be open):<br/>
12!> @code
13!>    CALL iom_mpp_open(td_mpp)
14!> @endcode
15!>       - td_mpp is a mpp structure
16!>
17!>    to creates mpp files:<br/>
18!> @code
19!>    CALL iom_mpp_create(td_mpp)
20!> @endcode
21!>       - td_mpp is a mpp structure
22!>
23!>    to write in mpp files :<br/>
24!> @code
25!>    CALL  iom_mpp_write_file(td_mpp)
26!> @endcode
27!>       - td_mpp is a mpp structure
28!>
29!>    to close mpp files:<br/>
30!> @code
31!>    CALL iom_mpp_close(td_mpp)
32!> @endcode
33!>
34!>    to read one variable in an mpp files:<br/>
35!> @code
36!>    tl_var=iom_mpp_read_var( td_mpp, id_varid, [id_start, id_count] [,id_ew] )
37!> @endcode
38!>    or
39!> @code
40!>    tl_var=iom_mpp_read_var( td_mpp, cd_name, [id_start, id_count] [,id_ew] )
41!> @endcode
42!>       - td_mpp is a mpp structure
43!>       - id_varid is a variable id
44!>       - cd_name is variable name or standard name
45!>       - id_start is a integer(4) 1D array of index from which the data
46!>          values will be read [optional]
47!>       - id_count is a integer(4) 1D array of the number of indices selected
48!>          along each dimension [optional]
49!>       - id_ew East West overlap [optional]
50!>
51!>    to fill variable value in mpp structure:<br/>
52!> @code
53!>    CALL iom_mpp_fill_var(td_mpp, id_varid, [id_start, id_count] [,id_ew] )
54!> @endcode
55!>    or<br/>
56!> @code
57!>    CALL iom_mpp_fill_var(td_mpp, cd_name, [id_start, id_count] [,id_ew] )
58!> @endcode
59!>       - td_mpp is mpp structure
60!>       - id_varid is variable id
61!>       - cd_name is variable name or standard name
62!>       - id_start is a integer(4) 1D array of index from which the data
63!>          values will be read [optional]
64!>       - id_count is a integer(4) 1D array of the number of indices selected
65!>          along each dimension [optional]
66!>       - id_ew East West overlap [optional]
67!>
68!>    to fill all variable in mpp structure:<br/>
69!> @code
70!>    CALL iom_mpp_fill_var(td_mpp, [id_start, id_count] [,id_ew] )
71!> @endcode
72!>       - td_mpp is mpp structure
73!>       - id_start is a integer(4) 1D array of index from which the data
74!>          values will be read [optional]
75!>       - id_count is a integer(4) 1D array of the number of indices selected
76!>          along each dimension [optional]
77!>       - id_ew East West overlap
78!>
79!>    to write files composong mpp strucutre:<br/>
80!> @code
81!>    CALL iom_mpp_write_file(td_mpp)
82!> @endcode
83!>
84!> @author
85!> J.Paul
86!>
87!> @date November, 2013 - Initial Version
88!>
89!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
90!----------------------------------------------------------------------
91MODULE iom_mpp
92
93   USE netcdf                          ! nf90 library
94   USE global                          ! global parameter
95   USE kind                            ! F90 kind parameter
96   USE fct                             ! basic useful function
97   USE logger                          ! log file manager
98   USE dim                             ! dimension manager
99   USE att                             ! attribute manager
100   USE var                             ! variable manager
101   USE file                            ! file manager
102   USE iom                             ! I/O manager
103   USE mpp                             ! mpp manager
104
105   IMPLICIT NONE
106   ! NOTE_avoid_public_variables_if_possible
107
108   ! function and subroutine
109   PUBLIC :: iom_mpp_open                    !< open all files composing mpp structure
110   PUBLIC :: iom_mpp_create                  !< creates files composing mpp structure
111   PUBLIC :: iom_mpp_close                   !< close file composing mpp structure
112   PUBLIC :: iom_mpp_read_var                !< read one variable in an mpp structure
113   PUBLIC :: iom_mpp_write_file              !< write mpp structure in files
114
115   PRIVATE :: iom_mpp__read_var_id           ! read one variable in an mpp structure, given variable id
116   PRIVATE :: iom_mpp__read_var_name         ! read one variable in an mpp structure, given variable name
117   PRIVATE :: iom_mpp__read_var_value        ! read variable value in an mpp structure
118
119   INTERFACE iom_mpp_read_var                   ! read one variable in an mpp structure
120      MODULE PROCEDURE iom_mpp__read_var_id     ! given variable id
121      MODULE PROCEDURE iom_mpp__read_var_name   ! given variable name
122   END INTERFACE iom_mpp_read_var
123
124CONTAINS
125   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
126   SUBROUTINE iom_mpp_open(td_mpp, id_perio, id_ew)
127   !-------------------------------------------------------------------
128   !> @brief This subroutine open files composing mpp structure to be used.
129   !> @details
130   !> If try to open a file in write mode that did not exist, create it.<br/>
131   !>
132   !> If file already exist, get information about:
133   !> - the number of variables
134   !> - the number of dimensions
135   !> - the number of global attributes
136   !> - the ID of the unlimited dimension
137   !> - the file format
138   !> and finally read dimensions.
139   !>
140   !> @author J.Paul
141   !> @date November, 2013 - Initial Version
142   !> @date August, 2017
143   !> - handle use of domain decomposition for monoproc file
144   !>
145   !> @param[inout] td_mpp mpp structure
146   !-------------------------------------------------------------------
147
148      IMPLICIT NONE
149
150      ! Argument     
151      TYPE(TMPP) , INTENT(INOUT)  :: td_mpp
152      INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
153      INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
154
155      ! local variable
156      CHARACTER(LEN=lc) :: cl_name
157      INTEGER(i4) :: il_pid 
158      INTEGER(i4) :: il_impp 
159      INTEGER(i4) :: il_jmpp 
160      INTEGER(i4) :: il_lci 
161      INTEGER(i4) :: il_lcj 
162      INTEGER(i4) :: il_ldi 
163      INTEGER(i4) :: il_ldj 
164      INTEGER(i4) :: il_lei 
165      INTEGER(i4) :: il_lej 
166      LOGICAL     :: ll_ctr 
167      LOGICAL     :: ll_use 
168      LOGICAL     :: ll_create 
169      INTEGER(i4) :: il_iind 
170      INTEGER(i4) :: il_jind 
171
172      ! loop indices
173      INTEGER(i4) :: ji
174      !----------------------------------------------------------------
175      ! check if mpp exist
176      IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
177
178         CALL logger_error( " IOM MPP OPEN: domain decomposition not define "//&
179         &               " in mpp strcuture "//TRIM(td_mpp%c_name))
180
181      ELSE
182         !
183         td_mpp%i_id=1
184
185         ! if no processor file selected
186         ! force to open all files
187         IF( .NOT. ANY( td_mpp%t_proc(:)%l_use ) )THEN
188            td_mpp%t_proc(:)%l_use=.TRUE.
189         ENDIF
190
191         ! add suffix to mpp name
192         td_mpp%c_name=file_add_suffix( TRIM(td_mpp%c_name), &
193                                      & TRIM(td_mpp%c_type) )
194
195         td_mpp%t_proc(:)%c_type=TRIM(td_mpp%c_type) 
196         IF( td_mpp%i_nproc > 1 .AND. td_mpp%l_usempp )THEN
197            DO ji=1,td_mpp%i_nproc
198               IF( td_mpp%t_proc(ji)%l_use )THEN
199
200                  SELECT CASE(TRIM(td_mpp%c_type))
201                  CASE('cdf')
202                     cl_name=TRIM( file_rename(td_mpp%c_name, ji-1) )
203                  CASE('dimg')
204                     cl_name=TRIM( file_rename(td_mpp%c_name, ji) )
205                  CASE DEFAULT
206                     CALL logger_fatal("IOM MPP OPEN: can not open file "//&
207                     &  "of type "//TRIM(td_mpp%c_type))
208                  END SELECT
209
210                  td_mpp%t_proc(ji)%c_name=TRIM(cl_name)
211
212                  CALL iom_open(td_mpp%t_proc(ji))
213
214               ENDIF
215            ENDDO
216         ELSE ! td_mpp%i_nproc == 1
217               cl_name=TRIM( file_rename(td_mpp%c_name) )
218               td_mpp%t_proc(1)%c_name=TRIM(cl_name)
219
220               CALL iom_open(td_mpp%t_proc(1))
221
222               IF( .NOT. td_mpp%l_usempp )THEN
223                  ! copy file structure of first proc, except layout decomposition
224                  ! do not do it when creating output file.
225                  ll_create=( ALL(td_mpp%t_proc(:)%l_wrt) .AND. &
226                  &           ALL(td_mpp%t_proc(:)%l_use) )
227                  IF( .NOT. ll_create )THEN
228                     DO ji=2,td_mpp%i_nproc
229                        IF( td_mpp%t_proc(ji)%l_use )THEN
230                           il_pid  = td_mpp%t_proc(ji)%i_pid 
231                           il_impp = td_mpp%t_proc(ji)%i_impp 
232                           il_jmpp = td_mpp%t_proc(ji)%i_jmpp 
233                           il_lci  = td_mpp%t_proc(ji)%i_lci 
234                           il_lcj  = td_mpp%t_proc(ji)%i_lcj 
235                           il_ldi  = td_mpp%t_proc(ji)%i_ldi 
236                           il_ldj  = td_mpp%t_proc(ji)%i_ldj 
237                           il_lei  = td_mpp%t_proc(ji)%i_lei 
238                           il_lej  = td_mpp%t_proc(ji)%i_lej 
239                           ll_ctr  = td_mpp%t_proc(ji)%l_ctr 
240                           ll_use  = td_mpp%t_proc(ji)%l_use 
241                           il_iind = td_mpp%t_proc(ji)%i_iind 
242                           il_jind = td_mpp%t_proc(ji)%i_jind 
243
244                           td_mpp%t_proc(ji)=file_copy(td_mpp%t_proc(1))
245                           td_mpp%t_proc(ji)%i_id=td_mpp%t_proc(1)%i_id
246                           td_mpp%t_proc(ji)%l_def=.FALSE.
247
248                           td_mpp%t_proc(ji)%i_pid  = il_pid 
249                           td_mpp%t_proc(ji)%i_impp = il_impp 
250                           td_mpp%t_proc(ji)%i_jmpp = il_jmpp 
251                           td_mpp%t_proc(ji)%i_lci  = il_lci 
252                           td_mpp%t_proc(ji)%i_lcj  = il_lcj 
253                           td_mpp%t_proc(ji)%i_ldi  = il_ldi 
254                           td_mpp%t_proc(ji)%i_ldj  = il_ldj 
255                           td_mpp%t_proc(ji)%i_lei  = il_lei 
256                           td_mpp%t_proc(ji)%i_lej  = il_lej 
257                           td_mpp%t_proc(ji)%l_ctr  = ll_ctr 
258                           td_mpp%t_proc(ji)%l_use  = ll_use 
259                           td_mpp%t_proc(ji)%i_iind = il_iind 
260                           td_mpp%t_proc(ji)%i_jind = il_jind 
261                        ENDIF
262                     ENDDO
263                  ELSE
264                     ! keep file id
265                     DO ji=2,td_mpp%i_nproc
266                        IF( td_mpp%t_proc(ji)%l_use )THEN
267                           td_mpp%t_proc(ji)%i_id=td_mpp%t_proc(1)%i_id
268                           td_mpp%t_proc(ji)%l_def=.FALSE.
269                        ENDIF
270                     ENDDO
271                  ENDIF
272               ENDIF
273
274         ENDIF
275
276         IF( PRESENT(id_ew) )THEN
277            td_mpp%i_ew=id_ew
278            ! add east west overlap to each variable
279            DO ji=1,td_mpp%i_nproc
280               WHERE(td_mpp%t_proc(ji)%t_var(:)%t_dim(1)%l_use)
281                  td_mpp%t_proc(ji)%t_var(:)%i_ew=td_mpp%i_ew
282               ENDWHERE
283            ENDDO
284         ENDIF
285
286         IF( PRESENT(id_perio) )THEN
287            td_mpp%i_perio=id_perio
288         ENDIF
289
290      ENDIF
291
292   END SUBROUTINE iom_mpp_open
293   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
294   SUBROUTINE iom_mpp_create(td_mpp)
295   !-------------------------------------------------------------------
296   !> @brief This subroutine create files, composing mpp structure to be used,
297   !> in write mode.
298   !>
299   !> @author J.Paul
300   !> @date November, 2013 - Initial Version
301   !>
302   !> @param[inout] td_mpp mpp structure
303   !-------------------------------------------------------------------
304
305      IMPLICIT NONE
306
307      ! Argument     
308      TYPE(TMPP), INTENT(INOUT)  :: td_mpp
309      !----------------------------------------------------------------
310      ! check if mpp exist
311      IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
312
313         CALL logger_error( " IOM MPP CREATE: domain decomposition not define "//&
314         &               " in mpp strcuture "//TRIM(td_mpp%c_name))
315
316      ELSE
317         ! forced to open in write mode
318         td_mpp%t_proc(:)%l_wrt=.TRUE.
319         td_mpp%t_proc(:)%l_use=.TRUE.
320         CALL iom_mpp_open(td_mpp)
321      ENDIF
322
323   END SUBROUTINE iom_mpp_create
324   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
325   SUBROUTINE iom_mpp_close(td_mpp)
326   !-------------------------------------------------------------------
327   !> @brief This subroutine close files composing mpp structure.
328   !>
329   !> @author J.Paul
330   !> @date November, 2013 - Initial Version
331   !>
332   !> @param[in] td_mpp mpp structure
333   !-------------------------------------------------------------------
334
335      IMPLICIT NONE
336
337      ! Argument     
338      TYPE(TMPP), INTENT(INOUT) :: td_mpp
339
340      ! loop indices
341      INTEGER(i4) :: ji
342      !----------------------------------------------------------------
343      ! check if mpp exist
344      IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
345
346         CALL logger_error( " IOM MPP CLOSE: domain decomposition not define "//&
347         &               " in mpp strcuture "//TRIM(td_mpp%c_name))
348
349      ELSE
350         !
351         td_mpp%i_id=0         
352
353         IF( td_mpp%l_usempp )THEN
354            DO ji=1,td_mpp%i_nproc
355               IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN
356                  CALL iom_close(td_mpp%t_proc(ji))
357               ENDIF
358            ENDDO
359         ELSE
360            IF( td_mpp%t_proc(1)%i_id /= 0 )THEN
361               CALL iom_close(td_mpp%t_proc(1))
362               td_mpp%t_proc(:)%i_id=0
363            ENDIF
364         ENDIF
365         td_mpp%t_proc(:)%l_use=.FALSE.
366
367      ENDIF
368
369   END SUBROUTINE iom_mpp_close
370   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
371   FUNCTION iom_mpp__read_var_id(td_mpp, id_varid, id_start, id_count) &
372         & RESULT (tf_var)
373   !-------------------------------------------------------------------
374   !> @brief This function read variable value in opened mpp files,
375   !> given variable id.
376   !>
377   !> @details
378   !> Optionally start indices and number of point to be read could be specify.
379   !> as well as East West ovelap of the global domain.
380   !>
381   !> @author J.Paul
382   !> @date November, 2013 - Initial Version
383   !> @date October, 2014
384   !> - use start and count array instead of domain structure.
385   !>
386   !> @param[in] td_mpp    mpp structure
387   !> @param[in] id_varid  variable id
388   !> @param[in] id_start  index in the variable from which the data values
389   !> will be read
390   !> @param[in] id_count  number of indices selected along each dimension
391   !> @return  variable structure
392   !-------------------------------------------------------------------
393
394      IMPLICIT NONE
395
396      ! Argument     
397      TYPE(TMPP),                INTENT(IN) :: td_mpp
398      INTEGER(i4),               INTENT(IN) :: id_varid
399      INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
400      INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count     
401
402      ! function
403      TYPE(TVAR)                            :: tf_var
404
405      ! local variable
406      INTEGER(i4), DIMENSION(1) :: il_ind
407      !----------------------------------------------------------------
408      ! check if mpp exist
409      IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
410
411         CALL logger_error( " IOM MPP READ VAR: domain decomposition not define "//&
412         &               " in mpp strcuture "//TRIM(td_mpp%c_name))
413
414      ELSEIF( td_mpp%i_id == 0 )THEN
415
416         CALL logger_error( " IOM MPP READ VAR: mpp structure not opened. "//&
417         &               " can not read variable in "//TRIM(td_mpp%c_name))   
418     
419      ELSE
420
421
422         IF( ANY(td_mpp%t_proc(:)%i_id /= 0) )THEN
423            ! look for variable id
424            il_ind(:)=MINLOC( td_mpp%t_proc(1)%t_var(:)%i_id, &
425            &           mask=(td_mpp%t_proc(1)%t_var(:)%i_id==id_varid))
426            IF( il_ind(1) /= 0 )THEN
427
428               tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_ind(1)))
429
430               !!! read variable value
431               CALL iom_mpp__read_var_value(td_mpp, tf_var, id_start, id_count)
432
433            ELSE
434               CALL logger_error( &
435               &  " IOM MPP READ VAR: there is no variable with id "//&
436               &  TRIM(fct_str(id_varid))//" in processor/file "//&
437               &  TRIM(td_mpp%t_proc(1)%c_name))
438            ENDIF
439         ELSE
440            CALL logger_error(" IOM MPP READ VAR: can't read variable, mpp "//&
441            &  TRIM(td_mpp%c_name)//" not opened")
442         ENDIF
443
444      ENDIF
445
446   END FUNCTION iom_mpp__read_var_id
447   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
448   FUNCTION iom_mpp__read_var_name(td_mpp, cd_name, id_start, id_count) &
449         & RESULT (tf_var)
450   !-------------------------------------------------------------------
451   !> @brief This function read variable value in opened mpp files,
452   !> given variable name or standard name.
453   !>
454   !> @details
455   !> Optionally start indices and number of point to be read could be specify.
456   !> as well as East West ovelap of the global domain.
457   !>
458   !> look first for variable name. If it doesn't
459   !> exist in file, look for variable standard name.<br/>
460   !> If variable name is not present, check variable standard name.<br/>
461   !>
462   !> @author J.Paul
463   !> @date November, 2013 - Initial Version
464   !> @date October, 2014
465   !> - use start and count array instead of domain structure.
466   !>
467   !> @param[in] td_mpp    mpp structure
468   !> @param[in] cd_name   variable name
469   !> @param[in] id_start  index in the variable from which the data values
470   !> will be read
471   !> @param[in] id_count  number of indices selected along each dimension
472   !> @return  variable structure
473   !-------------------------------------------------------------------
474
475      IMPLICIT NONE
476
477      ! Argument     
478      TYPE(TMPP),                INTENT(IN) :: td_mpp
479      CHARACTER(LEN=*),          INTENT(IN) :: cd_name
480      INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_start
481      INTEGER(i4), DIMENSION(:), INTENT(IN), OPTIONAL :: id_count
482
483      ! function
484      TYPE(TVAR)                            :: tf_var
485
486      ! local variable
487      INTEGER(i4)       :: il_ind
488      !----------------------------------------------------------------
489      ! check if mpp exist
490      IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
491
492         CALL logger_error( " IOM MPP READ VAR: domain decomposition not define "//&
493         &               " in mpp strcuture "//TRIM(td_mpp%c_name))
494
495      ELSEIF( td_mpp%i_id == 0 )THEN
496
497         CALL logger_error( " IOM MPP READ VAR: mpp structure not opened. "//&
498         &               " can not read variable in "//TRIM(td_mpp%c_name))   
499 
500      ELSE
501
502            il_ind=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name)
503            IF( il_ind /= 0 )THEN
504
505               tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_ind))
506
507               !!! read variable value
508               CALL iom_mpp__read_var_value( td_mpp, tf_var, id_start, id_count)
509
510            ELSE
511
512               CALL logger_fatal( &
513               &  " IOM MPP READ VAR: there is no variable with "//&
514               &  "name or standard name "//TRIM(cd_name)//&
515               &  " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name))
516            ENDIF
517
518      ENDIF
519     
520   END FUNCTION iom_mpp__read_var_name
521   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522   SUBROUTINE iom_mpp__read_var_value(td_mpp, td_var, id_start, id_count)
523   !-------------------------------------------------------------------
524   !> @brief This subroutine read variable value
525   !> in an mpp structure.
526   !>
527   !> @details
528   !> Optionally start indices and number of point to be read could be specify.
529   !> as well as East West ovelap of the global domain.
530   !>
531   !> @author J.Paul
532   !> @date November, 2013 - Initial Version
533   !> @date October, 2014
534   !> - use start and count array instead of domain structure.
535   !>
536   !> @param[in] td_mpp    mpp structure
537   !> @param[inout] td_var variable structure
538   !> @param[in] id_start  index in the variable from which the data values
539   !> will be read
540   !> @param[in] id_count  number of indices selected along each dimension
541   !-------------------------------------------------------------------
542
543      IMPLICIT NONE
544
545      ! Argument     
546      TYPE(TMPP)               , INTENT(IN   ) :: td_mpp
547      TYPE(TVAR)               , INTENT(INOUT) :: td_var
548      INTEGER(i4), DIMENSION(:), INTENT(IN   ), OPTIONAL :: id_start
549      INTEGER(i4), DIMENSION(:), INTENT(IN   ), OPTIONAL :: id_count     
550
551      ! local variable
552      INTEGER(i4)                       :: il_status
553      INTEGER(i4), DIMENSION(4)         :: il_ind
554      INTEGER(i4)                       :: il_i1p
555      INTEGER(i4)                       :: il_i2p
556      INTEGER(i4)                       :: il_j1p
557      INTEGER(i4)                       :: il_j2p
558      INTEGER(i4)                       :: il_i1
559      INTEGER(i4)                       :: il_i2
560      INTEGER(i4)                       :: il_j1
561      INTEGER(i4)                       :: il_j2
562
563      INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
564      INTEGER(i4), DIMENSION(ip_maxdim) :: il_end
565      INTEGER(i4), DIMENSION(ip_maxdim) :: il_count     
566
567      INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt
568      INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt     
569
570      TYPE(TATT)                        :: tl_att
571      TYPE(TVAR)                        :: tl_var
572
573      ! loop indices
574      INTEGER(i4) :: jk
575      !----------------------------------------------------------------
576
577      il_start(:)=1
578      IF( PRESENT(id_start) ) il_start(:)=id_start(:)
579
580      il_count(:)=td_mpp%t_dim(:)%i_len
581      IF( PRESENT(id_count) ) il_count(:)=id_count(:)
582
583      CALL logger_debug("IOM MPP READ VAR VALUE: start "//&
584               &  TRIM(fct_str(il_start(jp_I)))//","//&
585               &  TRIM(fct_str(il_start(jp_J)))//","//&
586               &  TRIM(fct_str(il_start(jp_K)))//","//&
587               &  TRIM(fct_str(il_start(jp_L))) )
588      CALL logger_debug("IOM MPP READ VAR VALUE: count "//&
589               &  TRIM(fct_str(il_count(jp_I)))//","//&
590               &  TRIM(fct_str(il_count(jp_J)))//","//&
591               &  TRIM(fct_str(il_count(jp_K)))//","//&
592               &  TRIM(fct_str(il_count(jp_L))) )
593
594      !IF( td_mpp%l_usempp .AND. (PRESENT(id_start) .OR. PRESENT(id_count)))THEN
595      !   CALL logger_fatal("IOM MPP READ VAR VALUE: should not use"//&
596      !      &  " start or count arguments when usempp is False.")
597      !ENDIF
598
599      DO jk=1,ip_maxdim
600         IF( .NOT. td_var%t_dim(jk)%l_use )THEN
601            il_start(jk) = 1
602            il_count(jk) = 1
603         ENDIF
604
605         il_end(jk)=il_start(jk)+il_count(jk)-1
606      ENDDO
607
608      IF( ANY(il_end(:) > td_mpp%t_dim(:)%i_len) )THEN
609            CALL logger_debug("IOM MPP READ VAR VALUE: start + count "//&
610               &  TRIM(fct_str(il_end(jp_I)))//","//&
611               &  TRIM(fct_str(il_end(jp_J)))//","//&
612               &  TRIM(fct_str(il_end(jp_K)))//","//&
613               &  TRIM(fct_str(il_end(jp_L))) )
614            CALL logger_debug("IOM MPP READ VAR VALUE: dimension "//&
615               &  TRIM(fct_str(td_mpp%t_dim(jp_I)%i_len))//","//&
616               &  TRIM(fct_str(td_mpp%t_dim(jp_J)%i_len))//","//&
617               &  TRIM(fct_str(td_mpp%t_dim(jp_K)%i_len))//","//&
618               &  TRIM(fct_str(td_mpp%t_dim(jp_L)%i_len)) )
619            CALL logger_fatal("IOM MPP READ VAR VALUE: start + count "//&
620            &                 "exceed dimension bound.")
621      ENDIF
622
623      ! use domain dimension
624      td_var%t_dim(:)%i_len=il_count(:)
625
626      ! Allocate space to hold variable value in structure
627      IF( ASSOCIATED(td_var%d_value) )THEN
628         DEALLOCATE(td_var%d_value)   
629      ENDIF
630
631      ALLOCATE(td_var%d_value( il_count(1), &
632      &                        il_count(2), &
633      &                        il_count(3), &
634      &                        il_count(4)),&
635      &        stat=il_status)
636      IF(il_status /= 0 )THEN
637
638        CALL logger_error( &
639         &  " IOM MPP READ VAR VALUE: not enough space to put variable "//&
640         &  TRIM(td_var%c_name)//&
641         &  " in variable structure")
642
643      ENDIF
644
645      CALL logger_debug("IOM MPP READ VAR VALUE: shape ("//&
646      &  TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=1)))//","//&
647      &  TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=2)))//","//&
648      &  TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=3)))//","//&
649      &  TRIM(fct_str(SIZE(td_var%d_value(:,:,:,:),DIM=4)))//")" )
650      ! FillValue by default
651      td_var%d_value(:,:,:,:)=td_var%d_fill
652
653      ! read processor
654      DO jk=1,td_mpp%i_nproc
655         IF( td_mpp%t_proc(jk)%l_use )THEN
656             
657            ! get processor indices
658            il_ind(:)=mpp_get_proc_index( td_mpp, jk )
659            il_i1p = il_ind(1)
660            il_i2p = il_ind(2)
661            il_j1p = il_ind(3)
662            il_j2p = il_ind(4)
663 
664            IF( .NOT. td_var%t_dim(1)%l_use )THEN
665               il_i1p=il_start(1) ; il_i2p=il_end(1)
666            ENDIF
667            IF( .NOT. td_var%t_dim(2)%l_use )THEN
668               il_j1p=il_start(2) ; il_j2p=il_end(2)
669            ENDIF           
670           
671            il_i1=MAX(il_i1p, il_start(1))
672            il_i2=MIN(il_i2p, il_end(1))
673
674            il_j1=MAX(il_j1p, il_start(2))
675            il_j2=MIN(il_j2p, il_end(2))
676
677            IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN
678               IF( td_mpp%l_usempp )THEN
679                  il_strt(:)=(/ il_i1-il_i1p+1, &
680                  &             il_j1-il_j1p+1, &
681                  &             1,1 /)
682               ELSE
683                  il_strt(:)=(/ il_i1, &
684                  &             il_j1, &
685                  &             1,1 /)
686               ENDIF
687
688               il_cnt(:)=(/ il_i2-il_i1+1,         &
689               &            il_j2-il_j1+1,         &
690               &            td_var%t_dim(3)%i_len, &
691               &            td_var%t_dim(4)%i_len /)
692
693               tl_var=iom_read_var( td_mpp%t_proc(jk), td_var%c_name,&
694               &                    il_strt(:), il_cnt(:) )
695               ! replace value in output variable structure
696               td_var%d_value( il_i1 - il_start(1) + 1 : &
697               &               il_i2 - il_start(1) + 1,  &
698               &               il_j1 - il_start(2) + 1 : &
699               &               il_j2 - il_start(2) + 1,  &
700               &               :,:) = tl_var%d_value(:,:,:,:)
701
702               ! clean
703               CALL var_clean(tl_var)
704            ENDIF
705
706         ENDIF
707      ENDDO
708
709      IF( td_var%t_dim(1)%l_use .AND. &
710      &   td_var%t_dim(1)%i_len == td_mpp%t_dim(1)%i_len )THEN
711         IF( td_mpp%i_ew >= 0 )THEN
712            tl_att=att_init("ew_overlap",td_mpp%i_ew)
713            CALL var_move_att(td_var,tl_att)
714            ! clean
715            CALL att_clean(tl_att)
716         ENDIF
717      ENDIF
718
719      ! force to change _FillValue to avoid mistake
720      ! with dummy zero _FillValue
721      IF( td_var%d_fill == 0._dp )THEN
722         CALL var_chg_FillValue(td_var)
723      ENDIF     
724
725   END SUBROUTINE iom_mpp__read_var_value
726   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
727   SUBROUTINE iom_mpp_write_file(td_mpp, cd_dimorder)
728   !-------------------------------------------------------------------
729   !> @brief This subroutine write files composing mpp structure.
730   !>
731   !> @details
732   !> optionally, you could specify the dimension order (default 'xyzt')
733   !>
734   !> @author J.Paul
735   !> @date November, 2013 - Initial Version
736   !> @date July, 2015
737   !> - add dimension order option
738   !> @date August, 2017
739   !> - handle use of domain decomposition for monoproc file
740   !>
741   !> @param[inout] td_mpp mpp structure
742   !> @param[in] cd_dimorder dimension order
743   !-------------------------------------------------------------------
744
745      IMPLICIT NONE
746
747      ! Argument     
748      TYPE(TMPP)      , INTENT(INOUT) :: td_mpp
749      CHARACTER(LEN=*), INTENT(IN   ), OPTIONAL :: cd_dimorder
750
751      ! local variable
752      ! loop indices
753      INTEGER(i4) :: ji
754      !----------------------------------------------------------------
755
756      ! check if mpp exist
757      IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
758
759         CALL logger_error( " MPP WRITE: domain decomposition not define "//&
760         &               " in mpp strcuture "//TRIM(td_mpp%c_name))
761
762      ELSE
763         IF( td_mpp%l_usempp )THEN
764            DO ji=1, td_mpp%i_nproc
765               IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN
766                  CALL logger_debug("MPP WRITE: proc "//TRIM(fct_str(ji)))
767                  CALL iom_write_file(td_mpp%t_proc(ji), cd_dimorder)
768               ELSE
769                  CALL logger_debug( " MPP WRITE: no id associated to file "//&
770                  &              TRIM(td_mpp%t_proc(ji)%c_name) )
771               ENDIF
772            ENDDO
773         ELSE
774            CALL iom_write_header(td_mpp%t_proc(1), cd_dimorder, td_mpp%t_dim(:))
775
776            CALL iom_mpp__write_var(td_mpp, cd_dimorder)
777         ENDIF
778      ENDIF
779
780   END SUBROUTINE iom_mpp_write_file
781   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
782   SUBROUTINE iom_mpp__write_var(td_mpp, cd_dimorder)
783   !-------------------------------------------------------------------
784   !> @brief This subroutine write variables from mpp structure in one output
785   !> file.
786   !>
787   !> @details
788   !> optionally, you could specify the dimension order (default 'xyzt')
789   !>
790   !> @author J.Paul
791   !> @date August, 2017 - Initial Version
792   !>
793   !> @param[inout] td_mpp mpp structure
794   !> @param[in] cd_dimorder dimension order
795   !-------------------------------------------------------------------
796
797      IMPLICIT NONE
798
799      ! Argument     
800      TYPE(TMPP)      , INTENT(INOUT) :: td_mpp
801      CHARACTER(LEN=*), INTENT(IN   ), OPTIONAL :: cd_dimorder
802
803      ! local variable
804      INTEGER(i4), DIMENSION(4)         :: il_ind
805      INTEGER(i4)                       :: il_i1p
806      INTEGER(i4)                       :: il_i2p
807      INTEGER(i4)                       :: il_j1p
808      INTEGER(i4)                       :: il_j2p
809      INTEGER(i4)                       :: il_i1
810      INTEGER(i4)                       :: il_i2
811      INTEGER(i4)                       :: il_j1
812      INTEGER(i4)                       :: il_j2
813
814      INTEGER(i4), DIMENSION(ip_maxdim) :: il_start
815      INTEGER(i4), DIMENSION(ip_maxdim) :: il_count     
816
817      INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt
818      INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt     
819
820      REAL(dp)                          :: dl_fill
821
822      TYPE(TFILE)                       :: tl_file
823
824      ! loop indices
825      INTEGER(i4) :: ji
826      INTEGER(i4) :: jj
827      !----------------------------------------------------------------
828
829      ! write variable in file
830      DO jj = 1, td_mpp%i_nproc
831         
832         ! link
833         tl_file=td_mpp%t_proc(jj)
834         CALL logger_debug("IOM MPP WRITE: proc "//fct_str(jj))
835
836         ! get processor indices
837         il_ind(:)=mpp_get_proc_index( td_mpp, jj )
838         il_i1p = il_ind(1)
839         il_i2p = il_ind(2)
840         il_j1p = il_ind(3)
841         il_j2p = il_ind(4)
842     
843         IF( jj > 1 )THEN
844            ! force to use id from variable write on first proc
845            tl_file%t_var(:)%i_id=td_mpp%t_proc(1)%t_var(:)%i_id
846         ENDIF
847
848         DO ji = 1, tl_file%i_nvar
849
850            IF( jj > 1 )THEN
851               ! check _FillValue
852               dl_fill=td_mpp%t_proc(1)%t_var(ji)%d_fill
853               IF( tl_file%t_var(ji)%d_fill /= dl_fill )THEN
854                  CALL var_chg_FillValue( tl_file%t_var(ji), dl_fill )
855               ENDIF
856            ENDIF
857
858            il_start(:)=1
859            il_count(:)=td_mpp%t_dim(:)%i_len
860
861            IF( .NOT. tl_file%t_var(ji)%t_dim(1)%l_use )THEN
862               il_i1p=1 ; il_i2p=1
863               il_count(1) = 1
864            ENDIF
865            IF( .NOT. tl_file%t_var(ji)%t_dim(2)%l_use )THEN
866               il_j1p=1 ; il_j2p=1
867               il_count(2) = 1
868            ENDIF           
869           
870            il_i1=MAX(il_i1p, il_start(1))
871            il_i2=MIN(il_i2p, il_count(1))
872
873            il_j1=MAX(il_j1p, il_start(2))
874            il_j2=MIN(il_j2p, il_count(2))
875         
876            IF( (il_i1<=il_i2).AND.(il_j1<=il_j2) )THEN
877               il_strt(:)=(/ il_i1, &
878               &             il_j1, &
879               &             1,1 /)
880
881               il_cnt(:)=(/ il_i2-il_i1+1,         &
882               &            il_j2-il_j1+1,         &
883               &            tl_file%t_var(ji)%t_dim(3)%i_len, &
884               &            tl_file%t_var(ji)%t_dim(4)%i_len /)
885
886               CALL iom_write_var(tl_file, cd_dimorder, &
887               &                  id_start=il_strt(:), &
888               &                  id_count=il_cnt(:))
889            ENDIF
890
891         ENDDO
892      ENDDO
893
894   END SUBROUTINE iom_mpp__write_var   
895   !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
896END MODULE iom_mpp
Note: See TracBrowser for help on using the repository browser.