source: LMDZ6/branches/LMDZ_ECRad/libf/phydev/iophy.F90 @ 5456

Last change on this file since 5456 was 4727, checked in by idelkadi, 15 months ago

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