source: dynamico_lmdz/aquaplanet/LMDZ5/libf/phydev/iophy.F90 @ 4080

Last change on this file since 4080 was 4028, checked in by millour, 8 years ago

Rearrange ICOSAGCM/Physics interface so that multiple different LMDZ physics packages may be used.
So far only interfaces with 'lmd' and 'dev' physics are handled.
Added a 'DEV_PHYSICS' directory with sample def and xml files to test correct integration with 'dev' physics.
EM

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