source: LMDZ5/branches/Cold_pool_death/libf/phydev/iophy.F90 @ 5224

Last change on this file since 5224 was 2594, checked in by Laurent Fairhead, 8 years ago

Merged trunk changes r2545:2589 into testing branch
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:keywords set to Id
File size: 13.0 KB
Line 
1!
2! $Id: iophy.F90 2594 2016-07-18 19:41:10Z abarral $
3!
4module iophy
5 
6! abd  REAL,private,allocatable,dimension(:),save :: io_lat
7! abd  REAL,private,allocatable,dimension(:),save :: io_lon
8  REAL,allocatable,dimension(:),save :: io_lat
9  REAL,allocatable,dimension(:),save :: io_lon
10  INTEGER, save :: phys_domain_id
11  INTEGER, save :: npstn
12  INTEGER, allocatable, dimension(:), save :: nptabij
13 
14
15#ifdef CPP_XIOS
16! interfaces for both IOIPSL and XIOS
17  INTERFACE histwrite_phy
18    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_xios,histwrite3d_xios
19  END INTERFACE
20#else
21! interfaces for IOIPSL
22  INTERFACE histwrite_phy
23    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy
24  END INTERFACE
25#endif
26
27#ifdef CPP_XIOS
28! interfaces for both IOIPSL and XIOS
29  INTERFACE histbeg_phy_all
30    MODULE PROCEDURE histbeg_phy, histbeg_phyxios
31  END INTERFACE
32#else
33! interfaces for IOIPSL
34  INTERFACE histbeg_phy_all
35    MODULE PROCEDURE histbeg_phy
36  END INTERFACE
37#endif
38
39contains
40
41  subroutine init_iophy_new(rlat,rlon)
42  USE dimphy, only: klon
43  USE mod_phys_lmdz_para, only: gather, bcast, &
44                                jj_nb, jj_begin, jj_end, ii_begin, ii_end, &
45                                mpi_size, mpi_rank, klon_mpi, &
46                                is_sequential, is_south_pole_dyn
47  USE mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, klon_glo
48  USE print_control_mod, ONLY: lunout, prt_level
49  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
50#ifdef CPP_IOIPSL
51  USE ioipsl, only: flio_dom_set
52#endif
53#ifdef CPP_XIOS
54  use wxios, only: wxios_domain_param
55#endif
56  implicit none
57    real,dimension(klon),intent(in) :: rlon
58    real,dimension(klon),intent(in) :: rlat
59
60    REAL,dimension(klon_glo)        :: rlat_glo
61    REAL,dimension(klon_glo)        :: rlon_glo
62   
63    INTEGER,DIMENSION(2) :: ddid
64    INTEGER,DIMENSION(2) :: dsg
65    INTEGER,DIMENSION(2) :: dsl
66    INTEGER,DIMENSION(2) :: dpf
67    INTEGER,DIMENSION(2) :: dpl
68    INTEGER,DIMENSION(2) :: dhs
69    INTEGER,DIMENSION(2) :: dhe
70    INTEGER :: i   
71    integer :: data_ibegin,data_iend
72
73    CALL gather(rlat,rlat_glo)
74    CALL bcast(rlat_glo)
75    CALL gather(rlon,rlon_glo)
76    CALL bcast(rlon_glo)
77   
78!$OMP MASTER 
79    ALLOCATE(io_lat(nbp_lat))
80    io_lat(1)=rlat_glo(1)
81    io_lat(nbp_lat)=rlat_glo(klon_glo)
82    IF ((nbp_lon*nbp_lat) > 1) then
83      DO i=2,nbp_lat-1
84        io_lat(i)=rlat_glo(2+(i-2)*nbp_lon)
85      ENDDO
86    ENDIF
87
88    ALLOCATE(io_lon(nbp_lon))
89    IF ((nbp_lon*nbp_lat) > 1) THEN
90      io_lon(:)=rlon_glo(2:nbp_lon+1)
91    ELSE
92      io_lon(1)=rlon_glo(1)
93    ENDIF
94!! (I) dtnb   : total number of domains
95!! (I) dnb    : domain number
96!! (I) did(:) : distributed dimensions identifiers
97!!              (up to 5 dimensions are supported)
98!! (I) dsg(:) : total number of points for each dimension
99!! (I) dsl(:) : local number of points for each dimension
100!! (I) dpf(:) : position of first local point for each dimension
101!! (I) dpl(:) : position of last local point for each dimension
102!! (I) dhs(:) : start halo size for each dimension
103!! (I) dhe(:) : end halo size for each dimension
104!! (C) cdnm   : Model domain definition name.
105!!              The names actually supported are :
106!!              "BOX", "APPLE", "ORANGE".
107!!              These names are case insensitive.
108    ddid=(/ 1,2 /)
109    dsg=(/ nbp_lon, nbp_lat /)
110    dsl=(/ nbp_lon, jj_nb /)
111    dpf=(/ 1,jj_begin /)
112    dpl=(/ nbp_lon, jj_end /)
113    dhs=(/ ii_begin-1,0 /)
114    if (mpi_rank==mpi_size-1) then
115      dhe=(/0,0/)
116    else
117      dhe=(/ nbp_lon-ii_end,0 /) 
118    endif
119   
120#ifndef CPP_IOIPSL_NO_OUTPUT
121    call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
122                      'APPLE',phys_domain_id)
123#endif
124#ifdef CPP_XIOS
125    ! Set values for the mask:
126    IF (mpi_rank == 0) THEN
127        data_ibegin = 0
128    ELSE
129        data_ibegin = ii_begin - 1
130    END IF
131
132    IF (mpi_rank == mpi_size-1) THEN
133        data_iend = nbp_lon
134    ELSE
135        data_iend = ii_end + 1
136    END IF
137
138    if (prt_level>=10) then
139      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," iibegin=",ii_begin , " ii_end=",ii_end," jjbegin=",jj_begin," jj_nb=",jj_nb," jj_end=",jj_end
140      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," nbp_lon=",nbp_lon," nbp_lat=",nbp_lat
141      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
142      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
143      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole=",is_south_pole_dyn
144    endif
145
146    ! Initialize the XIOS domain coreesponding to this process:
147    CALL wxios_domain_param("dom_glo", is_sequential, nbp_lon, jj_nb, nbp_lon, nbp_lat, &
148                            1, nbp_lon, ii_begin, ii_end, jj_begin, jj_end,             &
149                            klon_mpi+2*(nbp_lon-1), data_ibegin, data_iend,             &
150                            io_lat, io_lon,is_south_pole_dyn,mpi_rank)
151#endif
152!$OMP END MASTER
153     
154  END SUBROUTINE init_iophy_new
155 
156!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
157 
158  subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
159  USE mod_phys_lmdz_para, only: is_sequential, jj_begin, jj_end, jj_nb
160  use ioipsl, only: histbeg
161  USE print_control_mod, ONLY: prt_level, lunout
162  USE mod_grid_phy_lmdz, ONLY: nbp_lon
163  implicit none
164   
165    character*(*), intent(IN) :: name
166    integer, intent(in) :: itau0
167    real,intent(in) :: zjulian
168    real,intent(in) :: dtime
169    integer,intent(out) :: nhori
170    integer,intent(out) :: nid_day
171
172!$OMP MASTER   
173    if (is_sequential) then
174      call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
175                   1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
176    else
177      call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
178                   1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
179    endif
180!$OMP END MASTER
181 
182  end subroutine histbeg_phy
183
184!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
185
186#ifdef CPP_XIOS
187
188! SUBROUTINE histbeg_phyxios(name,itau0,zjulian,dtime,ffreq,lev,nhori,nid_day)
189 SUBROUTINE histbeg_phyxios(name,ffreq,lev)
190  USE mod_phys_lmdz_para, only: is_using_mpi, is_mpi_root
191  use wxios, only: wxios_add_file
192  IMPLICIT NONE
193   
194    character*(*), INTENT(IN) :: name
195!    integer, INTENT(IN) :: itau0
196!    REAL,INTENT(IN) :: zjulian
197!    REAL,INTENT(IN) :: dtime
198    character(LEN=*), INTENT(IN) :: ffreq
199    INTEGER,INTENT(IN) :: lev
200!    integer,intent(out) :: nhori
201!    integer,intent(out) :: nid_day
202
203!$OMP MASTER   
204
205    ! ug OMP en chantier...
206    IF((.NOT. is_using_mpi) .OR. is_mpi_root) THEN
207        ! ug Création du fichier
208        CALL wxios_add_file(name, ffreq, lev)
209    END IF
210
211!$OMP END MASTER
212 
213  END SUBROUTINE histbeg_phyxios
214
215#endif
216
217!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
218 
219  subroutine histwrite2d_phy(nid,lpoint,name,itau,field)
220  USE dimphy, only: klon
221  USE mod_phys_lmdz_para, only: Gather_omp, grid1Dto2D_mpi, &
222                                is_sequential, klon_mpi_begin, klon_mpi_end, &
223                                jj_nb, klon_mpi
224  USE ioipsl, only: histwrite
225  USE mod_grid_phy_lmdz, ONLY: nbp_lon
226  implicit none
227   
228    integer,intent(in) :: nid
229    logical,intent(in) :: lpoint
230    character*(*), intent(IN) :: name
231    integer, intent(in) :: itau
232    real,dimension(:),intent(in) :: field
233    REAL,dimension(klon_mpi) :: buffer_omp
234    INTEGER, allocatable, dimension(:) :: index2d
235    REAL :: Field2d(nbp_lon,jj_nb)
236
237    integer :: ip
238    real,allocatable,dimension(:) :: fieldok
239
240    IF (size(field)/=klon) CALL abort_physic('iophy::histwrite2d','Field first dimension not equal to klon',1)
241   
242    CALL Gather_omp(field,buffer_omp)   
243!$OMP MASTER
244    CALL grid1Dto2D_mpi(buffer_omp,Field2d)
245    if(.NOT.lpoint) THEN
246     ALLOCATE(index2d(nbp_lon*jj_nb))
247     ALLOCATE(fieldok(nbp_lon*jj_nb))
248     CALL histwrite(nid,name,itau,Field2d,nbp_lon*jj_nb,index2d)
249    else
250     ALLOCATE(fieldok(npstn))
251     ALLOCATE(index2d(npstn))
252
253     if(is_sequential) then
254!     klon_mpi_begin=1
255!     klon_mpi_end=klon
256      DO ip=1, npstn
257       fieldok(ip)=buffer_omp(nptabij(ip))
258      ENDDO
259     else
260      DO ip=1, npstn
261!     print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
262       IF(nptabij(ip).GE.klon_mpi_begin.AND. &
263          nptabij(ip).LE.klon_mpi_end) THEN
264         fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
265       ENDIF
266      ENDDO
267     endif
268     CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
269!
270    endif
271    deallocate(index2d)
272    deallocate(fieldok)
273!$OMP END MASTER   
274  end subroutine histwrite2d_phy
275
276!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
277
278  subroutine histwrite3d_phy(nid,lpoint,name,itau,field)
279  USE dimphy, only: klon
280  USE mod_phys_lmdz_para, only: Gather_omp, grid1Dto2D_mpi, &
281                                is_sequential, klon_mpi_begin, klon_mpi_end, &
282                                jj_nb, klon_mpi
283  USE ioipsl, only: histwrite
284  USE mod_grid_phy_lmdz, ONLY: nbp_lon
285  implicit none
286   
287    integer,intent(in) :: nid
288    logical,intent(in) :: lpoint
289    character*(*), intent(IN) :: name
290    integer, intent(in) :: itau
291    real,dimension(:,:),intent(in) :: field  ! --> field(klon,:)
292    REAL,dimension(klon_mpi,size(field,2)) :: buffer_omp
293    REAL :: Field3d(nbp_lon,jj_nb,size(field,2))
294    INTEGER :: ip, n, nlev
295    INTEGER, ALLOCATABLE, dimension(:) :: index3d
296    real,allocatable, dimension(:,:) :: fieldok
297
298    IF (size(field,1)/=klon) CALL abort_physic('iophy::histwrite3d','Field first dimension not equal to klon',1)
299    nlev=size(field,2)
300
301    CALL Gather_omp(field,buffer_omp)
302!$OMP MASTER
303    CALL grid1Dto2D_mpi(buffer_omp,field3d)
304    if(.NOT.lpoint) THEN
305     ALLOCATE(index3d(nbp_lon*jj_nb*nlev))
306     ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
307     CALL histwrite(nid,name,itau,Field3d,nbp_lon*jj_nb*nlev,index3d)
308    else
309      nlev=size(field,2)
310      ALLOCATE(index3d(npstn*nlev))
311      ALLOCATE(fieldok(npstn,nlev))
312
313      if(is_sequential) then
314!      klon_mpi_begin=1
315!      klon_mpi_end=klon
316       DO n=1, nlev
317       DO ip=1, npstn
318        fieldok(ip,n)=buffer_omp(nptabij(ip),n)
319       ENDDO
320       ENDDO
321      else
322       DO n=1, nlev
323       DO ip=1, npstn
324        IF(nptabij(ip).GE.klon_mpi_begin.AND. &
325         nptabij(ip).LE.klon_mpi_end) THEN
326         fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
327        ENDIF
328       ENDDO
329       ENDDO
330      endif
331      CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
332    endif
333  deallocate(index3d)
334  deallocate(fieldok)
335!$OMP END MASTER   
336  end subroutine histwrite3d_phy
337
338!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
339
340! VERSION DES HISTWRITE DEDIEES AU TOUT-XIOS-XML DEJA UTILISEE DANS PHYDEV
341#ifdef CPP_XIOS
342  SUBROUTINE histwrite2d_xios(field_name,field)
343  USE dimphy, only: klon
344  USE mod_phys_lmdz_para, only: gather_omp, grid1Dto2D_mpi, &
345                                jj_nb, klon_mpi
346  USE xios, only: xios_send_field
347  USE print_control_mod, ONLY: prt_level, lunout
348  USE mod_grid_phy_lmdz, ONLY: nbp_lon
349  IMPLICIT NONE
350
351    CHARACTER(LEN=*), INTENT(IN) :: field_name
352    REAL, DIMENSION(:), INTENT(IN) :: field
353     
354    REAL,DIMENSION(klon_mpi) :: buffer_omp
355    REAL :: Field2d(nbp_lon,jj_nb)
356
357    IF (prt_level >= 10) WRITE(lunout,*)'Begin histrwrite2d_xios ',trim(field_name)
358
359    IF (SIZE(field)/=klon) CALL abort_physic('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon',1)
360   
361    CALL Gather_omp(field,buffer_omp)   
362!$OMP MASTER
363    CALL grid1Dto2D_mpi(buffer_omp,Field2d)
364   
365    CALL xios_send_field(field_name, Field2d)
366!$OMP END MASTER   
367
368    IF (prt_level >= 10) WRITE(lunout,*)'End histrwrite2d_xios ',trim(field_name)
369  END SUBROUTINE histwrite2d_xios
370#endif
371
372!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
373
374! VERSION DES HISTWRITE DEDIEES AU TOUT-XIOS-XML DEJA UTILISEE DANS PHYDEV
375#ifdef CPP_XIOS
376  SUBROUTINE histwrite3d_xios(field_name, field)
377  USE dimphy, only: klon, klev
378  USE mod_phys_lmdz_para, only: gather_omp, grid1Dto2D_mpi, &
379                                jj_nb, klon_mpi
380  USE xios, only: xios_send_field
381  USE print_control_mod, ONLY: prt_level,lunout
382  USE mod_grid_phy_lmdz, ONLY: nbp_lon
383
384  IMPLICIT NONE
385
386    CHARACTER(LEN=*), INTENT(IN) :: field_name
387    REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
388
389    REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
390    REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2))
391    INTEGER :: ip, n, nlev
392
393  IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d_xios ',trim(field_name)
394
395    !Et on.... écrit
396    IF (SIZE(field,1)/=klon) CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
397    nlev=SIZE(field,2)
398
399
400    CALL Gather_omp(field,buffer_omp)
401!$OMP MASTER
402    CALL grid1Dto2D_mpi(buffer_omp,field3d)
403
404    CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
405!$OMP END MASTER   
406
407    IF (prt_level >= 10) write(lunout,*)'End histrwrite3d_xios ',trim(field_name)
408  END SUBROUTINE histwrite3d_xios
409#endif
410
411end module iophy
Note: See TracBrowser for help on using the repository browser.