source: LMDZ6/trunk/libf/phylmd/iophy.F90 @ 3006

Last change on this file since 3006 was 3003, checked in by Laurent Fairhead, 7 years ago

Modifications to the code and xml files to output Ap and B, the coefficients
of the hybrid coordinates as requested by the CMIP6 DataRequest?
LF (with guidance from A. Caubel and S. Senesi)

  • 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:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 47.8 KB
Line 
1!
2! $Id: iophy.F90 3003 2017-10-03 14:45:26Z fairhead $
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  INTEGER, SAVE :: itau_iophy
14
15!$OMP THREADPRIVATE(itau_iophy)
16
17#ifdef CPP_XIOS
18  INTERFACE histwrite_phy
19!#ifdef CPP_XIOSnew
20    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old,histwrite2d_xios,histwrite3d_xios,histwrite0d_xios
21!#else
22!    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old,histwrite2d_xios,histwrite3d_xios
23!#endif
24
25  END INTERFACE
26#else
27  INTERFACE histwrite_phy
28    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old
29  END INTERFACE
30#endif
31
32  INTERFACE histbeg_phy_all
33    MODULE PROCEDURE histbeg_phy,histbeg_phyxios,histbeg_phy_points
34  END INTERFACE
35
36
37CONTAINS
38
39! ug Routine pour définir itau_iophy depuis phys_output_write_mod:
40  SUBROUTINE set_itau_iophy(ito)
41      IMPLICIT NONE
42      INTEGER, INTENT(IN) :: ito
43      itau_iophy = ito
44  END SUBROUTINE
45
46  SUBROUTINE init_iophy_new(rlat,rlon)
47  USE dimphy, ONLY: klon
48  USE mod_phys_lmdz_para, ONLY: gather, bcast, &
49                                jj_nb, jj_begin, jj_end, ii_begin, ii_end, &
50                                mpi_size, mpi_rank, klon_mpi, &
51                                is_sequential, is_south_pole_dyn
52  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo
53  USE print_control_mod, ONLY: prt_level,lunout
54#ifdef CPP_IOIPSL
55  USE ioipsl, ONLY: flio_dom_set
56#endif
57#ifdef CPP_XIOS
58  USE wxios, ONLY: wxios_domain_param
59#endif
60  IMPLICIT NONE
61    REAL,DIMENSION(klon),INTENT(IN) :: rlon
62    REAL,DIMENSION(klon),INTENT(IN) :: rlat
63
64    REAL,DIMENSION(klon_glo)        :: rlat_glo
65    REAL,DIMENSION(klon_glo)        :: rlon_glo
66   
67    INTEGER,DIMENSION(2) :: ddid
68    INTEGER,DIMENSION(2) :: dsg
69    INTEGER,DIMENSION(2) :: dsl
70    INTEGER,DIMENSION(2) :: dpf
71    INTEGER,DIMENSION(2) :: dpl
72    INTEGER,DIMENSION(2) :: dhs
73    INTEGER,DIMENSION(2) :: dhe
74    INTEGER :: i   
75    INTEGER :: data_ibegin, data_iend
76
77    CALL gather(rlat,rlat_glo)
78    CALL bcast(rlat_glo)
79    CALL gather(rlon,rlon_glo)
80    CALL bcast(rlon_glo)
81   
82!$OMP MASTER 
83    ALLOCATE(io_lat(nbp_lat))
84    IF (klon_glo == 1) THEN
85      io_lat(1)=rlat_glo(1)
86    ELSE
87      io_lat(1)=rlat_glo(1)
88      io_lat(nbp_lat)=rlat_glo(klon_glo)
89      DO i=2,nbp_lat-1
90        io_lat(i)=rlat_glo(2+(i-2)*nbp_lon)
91      ENDDO
92    ENDIF
93
94    ALLOCATE(io_lon(nbp_lon))
95    IF (klon_glo == 1) THEN
96      io_lon(1)=rlon_glo(1)
97    ELSE
98      io_lon(1:nbp_lon)=rlon_glo(2:nbp_lon+1)
99    ENDIF
100
101!! (I) dtnb   : total number of domains
102!! (I) dnb    : domain number
103!! (I) did(:) : distributed dimensions identifiers
104!!              (up to 5 dimensions are supported)
105!! (I) dsg(:) : total number of points for each dimension
106!! (I) dsl(:) : local number of points for each dimension
107!! (I) dpf(:) : position of first local point for each dimension
108!! (I) dpl(:) : position of last local point for each dimension
109!! (I) dhs(:) : start halo size for each dimension
110!! (I) dhe(:) : end halo size for each dimension
111!! (C) cdnm   : Model domain definition name.
112!!              The names actually supported are :
113!!              "BOX", "APPLE", "ORANGE".
114!!              These names are case insensitive.
115
116    ddid=(/ 1,2 /)
117    dsg=(/ nbp_lon, nbp_lat /)
118    dsl=(/ nbp_lon, jj_nb /)
119    dpf=(/ 1,jj_begin /)
120    dpl=(/ nbp_lon, jj_end /)
121    dhs=(/ ii_begin-1,0 /)
122    IF (mpi_rank==mpi_size-1) THEN
123      dhe=(/0,0/)
124    ELSE
125      dhe=(/ nbp_lon-ii_end,0 /) 
126    ENDIF
127
128#ifndef CPP_IOIPSL_NO_OUTPUT   
129    CALL flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
130                      'APPLE',phys_domain_id)
131#endif
132#ifdef CPP_XIOS
133    ! Set values for the mask:
134    IF (mpi_rank == 0) THEN
135        data_ibegin = 0
136    ELSE
137        data_ibegin = ii_begin - 1
138    ENDIF
139
140    IF (mpi_rank == mpi_size-1) THEN
141        data_iend = nbp_lon
142    ELSE
143        data_iend = ii_end + 1
144    ENDIF
145
146    IF (prt_level>=10) THEN
147      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
148      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," nbp_lon=",nbp_lon," nbp_lat=",nbp_lat
149      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
150      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend
151      write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole=",is_south_pole_dyn
152    ENDIF
153
154    ! Initialize the XIOS domain coreesponding to this process:
155    CALL wxios_domain_param("dom_glo", is_sequential, nbp_lon, jj_nb, nbp_lon, nbp_lat, &
156                            1, nbp_lon, ii_begin, ii_end, jj_begin, jj_end,             &
157                            klon_mpi+2*(nbp_lon-1), data_ibegin, data_iend,             &
158                            io_lat, io_lon,is_south_pole_dyn,mpi_rank)
159#endif
160!$OMP END MASTER
161     
162  END SUBROUTINE init_iophy_new
163
164  SUBROUTINE init_iophy(lat,lon)
165  USE mod_phys_lmdz_para, ONLY: jj_begin, jj_end, ii_begin, ii_end, jj_nb, &
166                                mpi_size, mpi_rank
167  USE ioipsl, ONLY: flio_dom_set
168  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
169  IMPLICIT NONE
170    REAL,DIMENSION(nbp_lon),INTENT(IN) :: lon
171    REAL,DIMENSION(nbp_lat),INTENT(IN) :: lat
172
173    INTEGER,DIMENSION(2) :: ddid
174    INTEGER,DIMENSION(2) :: dsg
175    INTEGER,DIMENSION(2) :: dsl
176    INTEGER,DIMENSION(2) :: dpf
177    INTEGER,DIMENSION(2) :: dpl
178    INTEGER,DIMENSION(2) :: dhs
179    INTEGER,DIMENSION(2) :: dhe
180
181!$OMP MASTER 
182    ALLOCATE(io_lat(nbp_lat))
183    io_lat(:)=lat(:)
184    ALLOCATE(io_lon(nbp_lon))
185    io_lon(:)=lon(:)
186   
187    ddid=(/ 1,2 /)
188    dsg=(/ nbp_lon, nbp_lat /)
189    dsl=(/ nbp_lon, jj_nb /)
190    dpf=(/ 1,jj_begin /)
191    dpl=(/ nbp_lon, jj_end /)
192    dhs=(/ ii_begin-1,0 /)
193    IF (mpi_rank==mpi_size-1) THEN
194      dhe=(/0,0/)
195    ELSE
196      dhe=(/ nbp_lon-ii_end,0 /) 
197    ENDIF
198   
199#ifndef CPP_IOIPSL_NO_OUTPUT
200    call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
201                      'APPLE',phys_domain_id)
202#endif
203!$OMP END MASTER
204     
205  END SUBROUTINE init_iophy
206
207 SUBROUTINE histbeg_phyxios(name,itau0,zjulian,dtime,ffreq,lev,nhori,nid_day)
208!  USE dimphy
209  USE mod_phys_lmdz_para, ONLY: is_sequential, is_using_mpi, is_mpi_root, &
210                                jj_begin, jj_end, jj_nb
211  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
212  USE ioipsl, ONLY: histbeg
213#ifdef CPP_XIOS
214  USE wxios, ONLY: wxios_add_file
215#endif
216  IMPLICIT NONE
217  include 'clesphys.h'
218   
219    CHARACTER*(*), INTENT(IN) :: name
220    INTEGER, INTENT(IN) :: itau0
221    REAL,INTENT(IN) :: zjulian
222    REAL,INTENT(IN) :: dtime
223    CHARACTER(LEN=*), INTENT(IN) :: ffreq
224    INTEGER,INTENT(IN) :: lev
225    INTEGER,INTENT(OUT) :: nhori
226    INTEGER,INTENT(OUT) :: nid_day
227
228!$OMP MASTER   
229    IF (is_sequential) THEN
230      call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
231                   1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
232    ELSE
233      call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
234                   1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
235    ENDIF
236
237#ifdef CPP_XIOS
238    ! ug OMP en chantier...
239    IF((.NOT. is_using_mpi) .OR. is_mpi_root) THEN
240        ! ug Création du fichier
241      IF (.not. ok_all_xml) THEN
242        CALL wxios_add_file(name, ffreq, lev)
243      ENDIF
244    ENDIF
245#endif
246!$OMP END MASTER
247 
248  END SUBROUTINE histbeg_phyxios
249 
250  SUBROUTINE histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
251
252  USE mod_phys_lmdz_para, ONLY: jj_begin, jj_end, jj_nb, is_sequential
253  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
254  USE ioipsl, ONLY: histbeg
255
256  IMPLICIT NONE
257   
258    CHARACTER*(*), INTENT(IN) :: name
259    INTEGER, INTENT(IN) :: itau0
260    REAL,INTENT(IN) :: zjulian
261    REAL,INTENT(IN) :: dtime
262    INTEGER,INTENT(OUT) :: nhori
263    INTEGER,INTENT(OUT) :: nid_day
264
265!$OMP MASTER   
266#ifndef CPP_IOIPSL_NO_OUTPUT
267    IF (is_sequential) THEN
268      call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
269                   1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
270    ELSE
271      call histbeg(name,nbp_lon,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
272                   1,nbp_lon,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
273    ENDIF
274#endif
275!$OMP END MASTER
276 
277  END SUBROUTINE histbeg_phy
278
279
280  SUBROUTINE histbeg_phy_points(rlon,rlat,pim,tabij,ipt,jpt, &
281             plon,plat,plon_bounds,plat_bounds, &
282             nname,itau0,zjulian,dtime,nnhori,nnid_day)
283  USE dimphy, ONLY: klon
284  USE mod_phys_lmdz_para, ONLY: gather, bcast, &
285                                is_sequential, klon_mpi_begin, klon_mpi_end, &
286                                mpi_rank
287  USE mod_grid_phy_lmdz, ONLY: klon_glo, nbp_lon, nbp_lat
288  USE ioipsl, ONLY: histbeg
289
290  IMPLICIT NONE
291
292    REAL,DIMENSION(klon),INTENT(IN) :: rlon
293    REAL,DIMENSION(klon),INTENT(IN) :: rlat
294    INTEGER, INTENT(IN) :: itau0
295    REAL,INTENT(IN) :: zjulian
296    REAL,INTENT(IN) :: dtime
297    INTEGER, INTENT(IN) :: pim
298    INTEGER, intent(out) :: nnhori
299    CHARACTER(len=20), INTENT(IN) :: nname
300    INTEGER, INTENT(OUT) :: nnid_day
301    INTEGER :: i
302    REAL,DIMENSION(klon_glo)        :: rlat_glo
303    REAL,DIMENSION(klon_glo)        :: rlon_glo
304    INTEGER, DIMENSION(pim), INTENT(IN)  :: tabij
305    REAL,DIMENSION(pim), INTENT(IN) :: plat, plon
306    INTEGER,DIMENSION(pim), INTENT(IN) :: ipt, jpt
307    REAL,DIMENSION(pim,2), intent(out) :: plat_bounds, plon_bounds
308
309    INTEGER, SAVE :: tabprocbeg, tabprocend
310!$OMP THREADPRIVATE(tabprocbeg, tabprocend)
311    INTEGER :: ip
312    INTEGER, PARAMETER :: nip=1
313    INTEGER :: npproc
314    REAL, allocatable, DIMENSION(:) :: npplat, npplon
315    REAL, allocatable, DIMENSION(:,:) :: npplat_bounds, npplon_bounds
316    REAL, DIMENSION(nbp_lon,nbp_lat) :: zx_lon, zx_lat
317
318    CALL gather(rlat,rlat_glo)
319    CALL bcast(rlat_glo)
320    CALL gather(rlon,rlon_glo)
321    CALL bcast(rlon_glo)
322
323!$OMP MASTER
324    DO i=1,pim
325
326!    print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
327
328     plon_bounds(i,1)=rlon_glo(tabij(i)-1)
329     plon_bounds(i,2)=rlon_glo(tabij(i)+1)
330     IF (plon_bounds(i,2).LE.0..AND.plon_bounds(i,1).GE.0.) THEN
331      IF (rlon_glo(tabij(i)).GE.0.) THEN
332       plon_bounds(i,2)=-1*plon_bounds(i,2)
333      ENDIF
334     ENDIF
335     IF (plon_bounds(i,2).GE.0..AND.plon_bounds(i,1).LE.0.) THEN
336      IF (rlon_glo(tabij(i)).LE.0.) THEN
337       plon_bounds(i,2)=-1*plon_bounds(i,2)
338      ENDIF
339     ENDIF
340!
341     IF ( tabij(i).LE.nbp_lon) THEN
342      plat_bounds(i,1)=rlat_glo(tabij(i))
343     ELSE
344      plat_bounds(i,1)=rlat_glo(tabij(i)-nbp_lon)
345     ENDIF
346     plat_bounds(i,2)=rlat_glo(tabij(i)+nbp_lon)
347!
348!    print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon_glo(tabij(i)),plon_bounds(i,2)
349!    print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat_glo(tabij(i)),plat_bounds(i,2)
350!
351    ENDDO
352    if (is_sequential) then
353
354     npstn=pim
355     IF(.NOT. ALLOCATED(nptabij)) THEN
356      ALLOCATE(nptabij(pim))
357     ENDIF
358     DO i=1,pim
359      nptabij(i)=tabij(i)
360     ENDDO
361
362       CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon_glo,zx_lon)
363       IF ((nbp_lon*nbp_lat).GT.1) THEN
364       DO i = 1, nbp_lon
365         zx_lon(i,1) = rlon_glo(i+1)
366         zx_lon(i,nbp_lat) = rlon_glo(i+1)
367       ENDDO
368       ENDIF
369       CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat_glo,zx_lat)
370
371    DO i=1,pim
372!    print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
373
374     plon_bounds(i,1)=zx_lon(ipt(i)-1,jpt(i))
375     plon_bounds(i,2)=zx_lon(ipt(i)+1,jpt(i))
376
377     IF (ipt(i).EQ.1) THEN
378      plon_bounds(i,1)=zx_lon(nbp_lon,jpt(i))
379      plon_bounds(i,2)=360.+zx_lon(ipt(i)+1,jpt(i))
380     ENDIF
381 
382     IF (ipt(i).EQ.nbp_lon) THEN
383      plon_bounds(i,2)=360.+zx_lon(1,jpt(i))
384     ENDIF
385
386     plat_bounds(i,1)=zx_lat(ipt(i),jpt(i)-1)
387     plat_bounds(i,2)=zx_lat(ipt(i),jpt(i)+1)
388
389     IF (jpt(i).EQ.1) THEN
390      plat_bounds(i,1)=zx_lat(ipt(i),1)+0.001
391      plat_bounds(i,2)=zx_lat(ipt(i),1)-0.001
392     ENDIF
393 
394     IF (jpt(i).EQ.nbp_lat) THEN
395      plat_bounds(i,1)=zx_lat(ipt(i),nbp_lat)+0.001
396      plat_bounds(i,2)=zx_lat(ipt(i),nbp_lat)-0.001
397     ENDIF
398!
399!    print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon(tabij(i)),plon_bounds(i,2)
400!    print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat(tabij(i)),plat_bounds(i,2)
401!
402    ENDDO
403
404#ifndef CPP_IOIPSL_NO_OUTPUT
405     call histbeg(nname,pim,plon,plon_bounds, &
406                           plat,plat_bounds, &
407                           itau0, zjulian, dtime, nnhori, nnid_day)
408#endif
409    ELSE
410     npproc=0
411     DO ip=1, pim
412      tabprocbeg=klon_mpi_begin
413      tabprocend=klon_mpi_end
414      IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
415       npproc=npproc+1
416       npstn=npproc
417      ENDIF
418     ENDDO
419!    print*,'CFMIP_iophy mpi_rank npstn',mpi_rank,npstn
420     IF(.NOT. ALLOCATED(nptabij)) THEN
421      ALLOCATE(nptabij(npstn))
422      ALLOCATE(npplon(npstn), npplat(npstn))
423      ALLOCATE(npplon_bounds(npstn,2), npplat_bounds(npstn,2))
424     ENDIF
425     npproc=0
426     DO ip=1, pim
427      IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
428       npproc=npproc+1
429       nptabij(npproc)=tabij(ip)
430!      print*,'mpi_rank npproc ip plon plat tabij=',mpi_rank,npproc,ip, &
431!      plon(ip),plat(ip),tabij(ip)
432       npplon(npproc)=plon(ip)
433       npplat(npproc)=plat(ip)
434       npplon_bounds(npproc,1)=plon_bounds(ip,1)
435       npplon_bounds(npproc,2)=plon_bounds(ip,2)
436       npplat_bounds(npproc,1)=plat_bounds(ip,1)
437       npplat_bounds(npproc,2)=plat_bounds(ip,2)
438!!!
439!!! print qui sert a reordonner les points stations selon l'ordre CFMIP
440!!! ne pas enlever
441        print*,'iophy_mpi rank ip lon lat',mpi_rank,ip,plon(ip),plat(ip)
442!!!
443      ENDIF
444     ENDDO
445#ifndef CPP_IOIPSL_NO_OUTPUT
446     call histbeg(nname,npstn,npplon,npplon_bounds, &
447                            npplat,npplat_bounds, &
448                            itau0,zjulian,dtime,nnhori,nnid_day,phys_domain_id)
449#endif
450    ENDIF
451!$OMP END MASTER
452
453  END SUBROUTINE histbeg_phy_points
454
455
456  SUBROUTINE histdef2d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
457
458    USE ioipsl, ONLY: histdef
459    USE mod_phys_lmdz_para, ONLY: jj_nb
460    USE phys_output_var_mod, ONLY: type_ecri, zoutm, zdtime_moy, lev_files, &
461                                   nid_files, nhorim, swaero_diag, dryaod_diag, nfiles, &
462                                   ok_4xCO2atm
463    USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
464    USE aero_mod, ONLY : naero_tot, name_aero_tau
465
466    IMPLICIT NONE
467
468    INCLUDE "clesphys.h"
469
470    INTEGER                          :: iff
471    INTEGER                          :: naero
472    LOGICAL                          :: lpoint
473    INTEGER, DIMENSION(nfiles)       :: flag_var
474    CHARACTER(LEN=20)                :: nomvar
475    CHARACTER(LEN=*)                 :: titrevar
476    CHARACTER(LEN=*)                 :: unitvar
477
478    REAL zstophym
479
480    IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN
481       zstophym=zoutm(iff)
482    ELSE
483       zstophym=zdtime_moy
484    ENDIF
485
486    ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
487    CALL conf_physoutputs(nomvar,flag_var)
488
489    IF(.NOT.lpoint) THEN 
490       IF ( flag_var(iff)<=lev_files(iff) ) THEN
491          CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, &
492               nbp_lon,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
493               type_ecri(iff), zstophym,zoutm(iff))               
494       ENDIF
495    ELSE
496       IF ( flag_var(iff)<=lev_files(iff) ) THEN
497          CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, &
498               npstn,1,nhorim(iff), 1,1,1, -99, 32, &
499               type_ecri(iff), zstophym,zoutm(iff))               
500       ENDIF
501    ENDIF
502
503    ! Set swaero_diag=true if at least one of the concerned variables are defined
504    IF (nomvar=='topswad' .OR. nomvar=='topswad0' .OR. nomvar=='solswad' .OR. nomvar=='solswad0' .OR. &
505        nomvar=='toplwad' .OR. nomvar=='toplwad0' .OR. nomvar=='sollwad' .OR. nomvar=='sollwad0' .OR. &
506        nomvar=='topswai' .OR. nomvar=='solswai' ) THEN
507       IF  ( flag_var(iff)<=lev_files(iff) ) swaero_diag=.TRUE.
508    ENDIF
509
510    ! Set dryaod_diag=true if at least one of the concerned variables are defined
511    IF (nomvar=='dryod550aer') THEN
512      IF  ( flag_var(iff)<=lev_files(iff) ) dryaod_diag=.TRUE.
513    ENDIF
514    DO naero = 1, naero_tot-1
515      IF (nomvar=='dryod550_'//name_aero_tau(naero)) THEN
516        IF  ( flag_var(iff)<=lev_files(iff) ) dryaod_diag=.TRUE.
517      ENDIF
518    ENDDO
519
520    ! Set ok_4xCO2atm=true if at least one of the concerned variables are
521    ! defined
522    IF (nomvar=='rsut4co2'.OR.nomvar=='rlut4co2'.OR.nomvar=='rsutcs4co2' &
523        .OR. nomvar=='rlutcs4co2'.OR.nomvar=='rsu4co2'.OR.nomvar=='rsucs4co2' &
524        .OR.nomvar=='rsu4co2'.OR.nomvar=='rsucs4co2'.OR.nomvar=='rsd4co2'.OR. &
525        nomvar=='rsdcs4co2'.OR.nomvar=='rlu4co2'.OR.nomvar=='rlucs4co2'.OR.&
526        nomvar=='rld4co2'.OR.nomvar=='rldcs4co2') THEN
527        IF ( flag_var(iff)<=lev_files(iff) ) ok_4xCO2atm=.TRUE.
528    ENDIF
529  END SUBROUTINE histdef2d_old
530
531  SUBROUTINE histdef3d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
532
533    USE ioipsl, ONLY: histdef
534    USE dimphy, ONLY: klev
535    USE mod_phys_lmdz_para, ONLY: jj_nb
536    USE phys_output_var_mod, ONLY: type_ecri, zoutm, lev_files, nid_files, &
537                                   nhorim, zdtime_moy, levmin, levmax, &
538                                   nvertm, nfiles
539    USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
540    IMPLICIT NONE
541
542    INCLUDE "clesphys.h"
543
544    INTEGER                          :: iff
545    LOGICAL                          :: lpoint
546    INTEGER, DIMENSION(nfiles)       :: flag_var
547    CHARACTER(LEN=20)                 :: nomvar
548    CHARACTER(LEN=*)                 :: titrevar
549    CHARACTER(LEN=*)                 :: unitvar
550
551    REAL zstophym
552
553    ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
554    CALL conf_physoutputs(nomvar,flag_var)
555
556    IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN
557       zstophym=zoutm(iff)
558    ELSE
559       zstophym=zdtime_moy
560    ENDIF
561
562    IF(.NOT.lpoint) THEN
563       IF ( flag_var(iff)<=lev_files(iff) ) THEN
564          CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, &
565               nbp_lon, jj_nb, nhorim(iff), klev, levmin(iff), &
566               levmax(iff)-levmin(iff)+1, nvertm(iff), 32, type_ecri(iff), &
567               zstophym, zoutm(iff))
568       ENDIF
569    ELSE
570       IF ( flag_var(iff)<=lev_files(iff) ) THEN
571          CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, &
572               npstn,1,nhorim(iff), klev, levmin(iff), &
573               levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
574               type_ecri(iff), zstophym,zoutm(iff))
575       ENDIF
576    ENDIF
577  END SUBROUTINE histdef3d_old
578
579  SUBROUTINE histdef2d (iff,var)
580
581    USE ioipsl, ONLY: histdef
582    USE mod_phys_lmdz_para, ONLY: jj_nb
583    USE phys_output_var_mod, ONLY: ctrl_out, type_ecri_files, zoutm, zdtime_moy, &
584                                   clef_stations, phys_out_filenames, lev_files, &
585                                   nid_files, nhorim, swaero_diag, dryaod_diag,&
586                                   ok_4xCO2atm
587    USE print_control_mod, ONLY: prt_level,lunout
588    USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
589    USE aero_mod, ONLY : naero_tot, name_aero_tau
590#ifdef CPP_XIOS
591    USE wxios, ONLY: wxios_add_field_to_file
592#endif
593    IMPLICIT NONE
594
595    INCLUDE "clesphys.h"
596
597    INTEGER                          :: iff
598    INTEGER                          :: naero
599    TYPE(ctrl_out)                   :: var
600
601    REAL zstophym
602    CHARACTER(LEN=20) :: typeecrit
603
604    ! ug On récupère le type écrit de la structure:
605    !       Assez moche, à refaire si meilleure méthode...
606    IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN
607       typeecrit = 'once'
608    ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN
609       typeecrit = 't_min(X)'
610    ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN
611       typeecrit = 't_max(X)'
612    ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN
613       typeecrit = 'inst(X)'
614    ELSE
615       typeecrit = type_ecri_files(iff)
616    ENDIF
617
618    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
619       zstophym=zoutm(iff)
620    ELSE
621       zstophym=zdtime_moy
622    ENDIF
623
624    ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
625    CALL conf_physoutputs(var%name, var%flag)
626
627    IF(.NOT.clef_stations(iff)) THEN 
628
629#ifdef CPP_XIOS
630      IF (.not. ok_all_xml) THEN
631        IF ( var%flag(iff)<=lev_files(iff) ) THEN
632          CALL wxios_add_field_to_file(var%name, 2, iff, phys_out_filenames(iff), &
633          var%description, var%unit, var%flag(iff), typeecrit)
634          IF (prt_level >= 10) THEN
635            WRITE(lunout,*) 'histdef2d: call wxios_add_field_to_file var%name iff: ', &
636                            trim(var%name),iff
637          ENDIF
638        ENDIF
639      ENDIF
640#endif
641#ifndef CPP_IOIPSL_NO_OUTPUT
642
643       IF ( var%flag(iff)<=lev_files(iff) ) THEN
644          CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
645               nbp_lon,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
646               typeecrit, zstophym,zoutm(iff))               
647       ENDIF
648    ELSE
649       IF ( var%flag(iff)<=lev_files(iff)) THEN
650          CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
651               npstn,1,nhorim(iff), 1,1,1, -99, 32, &
652               typeecrit, zstophym,zoutm(iff))               
653       ENDIF
654#endif
655    ENDIF
656
657    ! Set swaero_diag=true if at least one of the concerned variables are defined
658    !--OB 30/05/2016 use wider set of variables
659    IF ( var%name=='topswad' .OR. var%name=='topswad0' .OR. var%name=='solswad' .OR. var%name=='solswad0' .OR. &
660         var%name=='topswai' .OR. var%name=='solswai'  .OR. ( iflag_rrtm==1 .AND. (                            &
661         var%name=='toplwad' .OR. var%name=='toplwad0' .OR. var%name=='sollwad' .OR. var%name=='sollwad0' .OR. &
662         var%name=='toplwai' .OR. var%name=='sollwai'  ) ) ) THEN
663       IF  ( var%flag(iff)<=lev_files(iff) ) swaero_diag=.TRUE.
664    ENDIF
665
666    ! set dryaod_dry=true if at least one of the concerned variables are defined
667    IF (var%name=='dryod550aer') THEN
668      IF  ( var%flag(iff)<=lev_files(iff) ) dryaod_diag=.TRUE.
669    ENDIF
670    !
671    DO naero = 1, naero_tot-1
672      IF (var%name=='dryod550_'//name_aero_tau(naero)) THEN
673        IF  ( var%flag(iff)<=lev_files(iff) ) dryaod_diag=.TRUE.
674      ENDIF
675    ENDDO
676    ! Set ok_4xCO2atm=true if at least one of the concerned variables are
677    ! defined
678    IF (var%name=='rsut4co2'.OR.var%name=='rlut4co2'.OR.var%name=='rsutcs4co2' &
679        .OR. var%name=='rlutcs4co2'.OR.var%name=='rsu4co2'.OR.var%name=='rsucs4co2' &
680        .OR.var%name=='rsu4co2'.OR.var%name=='rsucs4co2'.OR.var%name=='rsd4co2'.OR. &
681        var%name=='rsdcs4co2'.OR.var%name=='rlu4co2'.OR.var%name=='rlucs4co2'.OR.&
682        var%name=='rld4co2'.OR.var%name=='rldcs4co2') THEN
683        IF ( var%flag(iff)<=lev_files(iff) ) ok_4xCO2atm=.TRUE.
684    ENDIF
685  END SUBROUTINE histdef2d
686
687  SUBROUTINE histdef3d (iff,var)
688
689    USE ioipsl, ONLY: histdef
690    USE dimphy, ONLY: klev
691    USE mod_phys_lmdz_para, ONLY: jj_nb
692    USE phys_output_var_mod, ONLY: ctrl_out, type_ecri_files, zoutm, zdtime_moy, &
693                                   clef_stations, phys_out_filenames, lev_files, &
694                                   nid_files, nhorim, swaero_diag, dryaod_diag, levmin, &
695                                   levmax, nvertm
696    USE print_control_mod, ONLY: prt_level,lunout
697    USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
698#ifdef CPP_XIOS
699    USE wxios, ONLY: wxios_add_field_to_file
700#endif
701    IMPLICIT NONE
702
703    INCLUDE "clesphys.h"
704
705    INTEGER                          :: iff
706    TYPE(ctrl_out)                   :: var
707
708    REAL zstophym
709    CHARACTER(LEN=20) :: typeecrit
710
711    ! ug On récupère le type écrit de la structure:
712    !       Assez moche, à refaire si meilleure méthode...
713    IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN
714       typeecrit = 'once'
715    ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN
716       typeecrit = 't_min(X)'
717    ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN
718       typeecrit = 't_max(X)'
719    ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN
720       typeecrit = 'inst(X)'
721    ELSE
722       typeecrit = type_ecri_files(iff)
723    ENDIF
724
725
726    ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
727    CALL conf_physoutputs(var%name,var%flag)
728
729    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
730       zstophym=zoutm(iff)
731    ELSE
732       zstophym=zdtime_moy
733    ENDIF
734
735    IF(.NOT.clef_stations(iff)) THEN
736
737#ifdef CPP_XIOS
738       IF (.not. ok_all_xml) THEN
739         IF ( var%flag(iff)<=lev_files(iff) ) THEN
740         CALL wxios_add_field_to_file(var%name, 3, iff, phys_out_filenames(iff), &
741         var%description, var%unit, var%flag(iff), typeecrit)
742           IF (prt_level >= 10) THEN
743             WRITE(lunout,*) 'histdef3d: call wxios_add_field_to_file var%name iff: ', &
744                             trim(var%name),iff
745           ENDIF
746         ENDIF
747       ENDIF
748#endif
749#ifndef CPP_IOIPSL_NO_OUTPUT
750
751       IF ( var%flag(iff)<=lev_files(iff) ) THEN
752          CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
753               nbp_lon, jj_nb, nhorim(iff), klev, levmin(iff), &
754               levmax(iff)-levmin(iff)+1, nvertm(iff), 32, typeecrit, &
755               zstophym, zoutm(iff))
756       ENDIF
757    ELSE
758       IF ( var%flag(iff)<=lev_files(iff)) THEN
759          CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
760               npstn,1,nhorim(iff), klev, levmin(iff), &
761               levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
762               typeecrit, zstophym,zoutm(iff))
763       ENDIF
764#endif
765    ENDIF
766  END SUBROUTINE histdef3d
767
768  SUBROUTINE conf_physoutputs(nam_var,flag_var)
769!!! Lecture des noms et niveau de sortie des variables dans output.def
770    !   en utilisant les routines getin de IOIPSL 
771    USE ioipsl, ONLY: getin
772    USE phys_output_var_mod, ONLY: nfiles
773    USE print_control_mod, ONLY: prt_level,lunout
774    IMPLICIT NONE
775
776    CHARACTER(LEN=20)                :: nam_var
777    INTEGER, DIMENSION(nfiles)      :: flag_var
778
779    IF(prt_level>10) WRITE(lunout,*)'Avant getin: nam_var flag_var ',nam_var,flag_var(:)
780    CALL getin('flag_'//nam_var,flag_var)
781    CALL getin('name_'//nam_var,nam_var)
782    IF(prt_level>10) WRITE(lunout,*)'Apres getin: nam_var flag_var ',nam_var,flag_var(:)
783
784  END SUBROUTINE conf_physoutputs
785
786 
787  SUBROUTINE histwrite2d_phy_old(nid,lpoint,name,itau,field)
788  USE dimphy, ONLY: klon
789  USE mod_phys_lmdz_para, ONLY: Gather_omp, grid1Dto2D_mpi, &
790                                is_sequential, klon_mpi_begin, klon_mpi_end, &
791                                jj_nb, klon_mpi
792  USE ioipsl, ONLY: histwrite
793  USE print_control_mod, ONLY: prt_level,lunout
794  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
795  IMPLICIT NONE
796   
797    INTEGER,INTENT(IN) :: nid
798    LOGICAL,INTENT(IN) :: lpoint
799    CHARACTER*(*), INTENT(IN) :: name
800    INTEGER, INTENT(IN) :: itau
801    REAL,DIMENSION(:),INTENT(IN) :: field
802    REAL,DIMENSION(klon_mpi) :: buffer_omp
803    INTEGER, allocatable, DIMENSION(:) :: index2d
804    REAL :: Field2d(nbp_lon,jj_nb)
805
806    INTEGER :: ip
807    REAL,ALLOCATABLE,DIMENSION(:) :: fieldok
808
809    IF (size(field)/=klon) CALL abort_physic('iophy::histwrite2d','Field first DIMENSION not equal to klon',1)
810   
811    CALL Gather_omp(field,buffer_omp)   
812!$OMP MASTER
813    CALL grid1Dto2D_mpi(buffer_omp,Field2d)
814    if(.NOT.lpoint) THEN
815     ALLOCATE(index2d(nbp_lon*jj_nb))
816     ALLOCATE(fieldok(nbp_lon*jj_nb))
817     IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
818     CALL histwrite(nid,name,itau,Field2d,nbp_lon*jj_nb,index2d)
819     IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
820    ELSE
821     ALLOCATE(fieldok(npstn))
822     ALLOCATE(index2d(npstn))
823
824     IF (is_sequential) THEN
825!     klon_mpi_begin=1
826!     klon_mpi_end=klon
827      DO ip=1, npstn
828       fieldok(ip)=buffer_omp(nptabij(ip))
829      ENDDO
830     ELSE
831      DO ip=1, npstn
832!     print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
833       IF(nptabij(ip).GE.klon_mpi_begin.AND. &
834          nptabij(ip).LE.klon_mpi_end) THEN
835         fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
836       ENDIF
837      ENDDO
838     ENDIF
839     IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
840     CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
841     IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
842!
843    ENDIF
844    DEALLOCATE(index2d)
845    DEALLOCATE(fieldok)
846!$OMP END MASTER   
847
848 
849  END SUBROUTINE histwrite2d_phy_old
850
851  SUBROUTINE histwrite3d_phy_old(nid,lpoint,name,itau,field)
852  USE dimphy, ONLY: klon
853  USE mod_phys_lmdz_para, ONLY: Gather_omp, grid1Dto2D_mpi, &
854                                is_sequential, klon_mpi_begin, klon_mpi_end, &
855                                jj_nb, klon_mpi
856  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
857  USE ioipsl, ONLY: histwrite
858  USE print_control_mod, ONLY: prt_level,lunout
859  IMPLICIT NONE
860   
861    INTEGER,INTENT(IN) :: nid
862    LOGICAL,INTENT(IN) :: lpoint
863    CHARACTER*(*), INTENT(IN) :: name
864    INTEGER, INTENT(IN) :: itau
865    REAL,DIMENSION(:,:),INTENT(IN) :: field  ! --> field(klon,:)
866    REAL,DIMENSION(klon_mpi,size(field,2)) :: buffer_omp
867    REAL :: Field3d(nbp_lon,jj_nb,size(field,2))
868    INTEGER :: ip, n, nlev
869    INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
870    REAL,allocatable, DIMENSION(:,:) :: fieldok
871
872
873    IF (size(field,1)/=klon) CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)
874    nlev=size(field,2)
875
876    CALL Gather_omp(field,buffer_omp)
877!$OMP MASTER
878    CALL grid1Dto2D_mpi(buffer_omp,field3d)
879    IF (.NOT.lpoint) THEN
880     ALLOCATE(index3d(nbp_lon*jj_nb*nlev))
881     ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
882     IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
883     CALL histwrite(nid,name,itau,Field3d,nbp_lon*jj_nb*nlev,index3d)
884     IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
885   ELSE
886      nlev=size(field,2)
887      ALLOCATE(index3d(npstn*nlev))
888      ALLOCATE(fieldok(npstn,nlev))
889
890      IF (is_sequential) THEN
891!      klon_mpi_begin=1
892!      klon_mpi_end=klon
893       DO n=1, nlev
894       DO ip=1, npstn
895        fieldok(ip,n)=buffer_omp(nptabij(ip),n)
896       ENDDO
897       ENDDO
898      ELSE
899       DO n=1, nlev
900       DO ip=1, npstn
901        IF(nptabij(ip).GE.klon_mpi_begin.AND. &
902         nptabij(ip).LE.klon_mpi_end) THEN
903         fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
904        ENDIF
905       ENDDO
906       ENDDO
907      ENDIF
908      IF (prt_level >= 10) write(lunout,*)'Sending ',name,' to IOIPSL'
909      CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
910      IF (prt_level >= 10) write(lunout,*)'Finished sending ',name,' to IOIPSL'
911    ENDIF
912  DEALLOCATE(index3d)
913  DEALLOCATE(fieldok)
914!$OMP END MASTER   
915
916  END SUBROUTINE histwrite3d_phy_old
917
918
919
920
921! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
922  SUBROUTINE histwrite2d_phy(var,field, STD_iff)
923  USE dimphy, ONLY: klon, klev
924  USE mod_phys_lmdz_para, ONLY: gather_omp, grid1dto2d_mpi, &
925                                jj_nb, klon_mpi, klon_mpi_begin, &
926                                klon_mpi_end, is_sequential
927  USE ioipsl, ONLY: histwrite
928  USE phys_output_var_mod, ONLY: ctrl_out, clef_files, lev_files, &
929                                 nfiles, vars_defined, clef_stations, &
930                                 nid_files
931  USE print_control_mod, ONLY: prt_level,lunout
932  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
933#ifdef CPP_XIOS
934  USE xios, ONLY: xios_send_field
935#endif
936
937
938  IMPLICIT NONE
939  include 'clesphys.h'
940
941    TYPE(ctrl_out), INTENT(IN) :: var
942    REAL, DIMENSION(:), INTENT(IN) :: field
943    INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
944     
945    INTEGER :: iff, iff_beg, iff_end
946    LOGICAL, SAVE  :: firstx
947!$OMP THREADPRIVATE(firstx)
948
949    REAL,DIMENSION(klon_mpi) :: buffer_omp
950    INTEGER, allocatable, DIMENSION(:) :: index2d
951    REAL :: Field2d(nbp_lon,jj_nb)
952
953    INTEGER :: ip
954    REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
955
956    IF (prt_level >= 10) THEN
957      WRITE(lunout,*)'Begin histwrite2d_phy for ',trim(var%name)
958    ENDIF
959! ug RUSTINE POUR LES STD LEVS.....
960      IF (PRESENT(STD_iff)) THEN
961            iff_beg = STD_iff
962            iff_end = STD_iff
963      ELSE
964            iff_beg = 1
965            iff_end = nfiles
966      ENDIF
967
968  ! On regarde si on est dans la phase de définition ou d'écriture:
969  IF (.NOT.vars_defined) THEN
970!$OMP MASTER
971      !Si phase de définition.... on définit
972      IF (.not. ok_all_xml) THEN
973      IF (prt_level >= 10) THEN
974      WRITE (lunout,*)"histwrite2d_phy: .not.vars_defined ; time to define ", trim(var%name)
975      ENDIF
976      DO iff=iff_beg, iff_end
977         IF (clef_files(iff)) THEN
978            CALL histdef2d(iff, var)
979         ENDIF
980      ENDDO
981      ENDIF
982!$OMP END MASTER
983  ELSE
984
985    !Et sinon on.... écrit
986    IF (SIZE(field)/=klon .AND. SIZE(field)/=klev) CALL abort_physic('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon/klev',1)   
987    IF (prt_level >= 10) THEn
988      WRITE (lunout,*)"histwrite2d_phy: .not.vars_defined ; time to gather and write ", trim(var%name)
989    ENDIF
990   
991   
992    IF (SIZE(field) == klon) then
993        CALL Gather_omp(field,buffer_omp)
994    ELSE
995        buffer_omp(:)=0.
996    ENDIF
997!$OMP MASTER
998    CALL grid1Dto2D_mpi(buffer_omp,Field2d)
999
1000! La boucle sur les fichiers:
1001      firstx=.true.
1002
1003      IF (ok_all_xml) THEN
1004#ifdef CPP_XIOS
1005          IF (prt_level >= 10) THEN
1006             write(lunout,*)'Dans iophy histwrite2D,var%name ', trim(var%name)                       
1007          ENDIF
1008          IF (SIZE(field) == klon) then
1009              CALL xios_send_field(var%name, Field2d)
1010          ELSE
1011             CALL xios_send_field(var%name, field)
1012          ENDIF
1013          IF (prt_level >= 10) THEN
1014             WRITE (lunout,*)'Dans iophy histwrite2D,var%name apres xios_send ', trim(var%name)                       
1015          ENDIF
1016#else
1017        CALL abort_physic ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1)
1018#endif
1019      ELSE 
1020        DO iff=iff_beg, iff_end
1021            IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
1022
1023#ifdef CPP_XIOS
1024               IF (firstx) THEN
1025                  IF (prt_level >= 10) THEN
1026                     WRITE (lunout,*)'Dans iophy histwrite2D,iff,var%name ', iff,trim(var%name)                       
1027                     WRITE (lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field"
1028                  ENDIF
1029                  IF (SIZE(field) == klon) then
1030                     CALL xios_send_field(var%name, Field2d)
1031                  ELSE
1032                     CALL xios_send_field(var%name, field)
1033                  ENDIF
1034                  firstx=.false.
1035               ENDIF
1036#endif
1037
1038                  IF (.NOT.clef_stations(iff)) THEN
1039                        ALLOCATE(index2d(nbp_lon*jj_nb))
1040                        ALLOCATE(fieldok(nbp_lon*jj_nb))
1041#ifndef CPP_IOIPSL_NO_OUTPUT
1042                        CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,nbp_lon*jj_nb,index2d)
1043#endif
1044!#ifdef CPP_XIOS
1045!                        IF (iff == iff_beg) THEN
1046!                          if (prt_level >= 10) then
1047!                            write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call xios_send_field"
1048!                          endif
1049!                          CALL xios_send_field(var%name, Field2d)
1050!                        ENDIF
1051!#endif
1052                  ELSE
1053                        ALLOCATE(fieldok(npstn))
1054                        ALLOCATE(index2d(npstn))
1055
1056                        IF (is_sequential) THEN
1057                          DO ip=1, npstn
1058                            fieldok(ip)=buffer_omp(nptabij(ip))
1059                          ENDDO
1060                        ELSE
1061                              DO ip=1, npstn
1062                                write(lunout,*)'histwrite2d_phy is_sequential npstn ip namenptabij',npstn,ip,var%name,nptabij(ip)
1063                                     IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1064                                        nptabij(ip).LE.klon_mpi_end) THEN
1065                                       fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
1066                                     ENDIF
1067                              ENDDO
1068                       ENDIF ! of IF (is_sequential)
1069#ifndef CPP_IOIPSL_NO_OUTPUT
1070                       IF (prt_level >= 10) THEn
1071                         write(lunout,*)"histwrite2d_phy: clef_stations(iff) and iff==iff_beg, call wxios_write_2D"
1072                       ENDIF
1073                       CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn,index2d)
1074#endif
1075                  ENDIF ! of IF(.NOT.clef_stations(iff))
1076                 
1077                DEALLOCATE(index2d)
1078                DEALLOCATE(fieldok)
1079            ENDIF !levfiles
1080        ENDDO ! of DO iff=iff_beg, iff_end
1081      ENDIF
1082!$OMP END MASTER   
1083  ENDIF ! vars_defined
1084  IF (prt_level >= 10) WRITE(lunout,*)'End histwrite2d_phy ',trim(var%name)
1085  END SUBROUTINE histwrite2d_phy
1086
1087
1088! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
1089  SUBROUTINE histwrite3d_phy(var, field, STD_iff)
1090  USE dimphy, ONLY: klon, klev
1091  USE mod_phys_lmdz_para, ONLY: gather_omp, grid1dto2d_mpi, &
1092                                jj_nb, klon_mpi, klon_mpi_begin, &
1093                                klon_mpi_end, is_sequential
1094  USE ioipsl, ONLY: histwrite
1095  USE phys_output_var_mod, ONLY: ctrl_out, clef_files, lev_files, &
1096                                 nfiles, vars_defined, clef_stations, &
1097                                 nid_files
1098  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
1099#ifdef CPP_XIOS
1100  USE xios, ONLY: xios_send_field
1101#endif
1102  USE print_control_mod, ONLY: prt_level,lunout
1103
1104  IMPLICIT NONE
1105  include 'clesphys.h'
1106
1107    TYPE(ctrl_out), INTENT(IN) :: var
1108    REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
1109    INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
1110     
1111    INTEGER :: iff, iff_beg, iff_end
1112    LOGICAL, SAVE  :: firstx
1113!$OMP THREADPRIVATE(firstx)
1114    REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
1115    REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2))
1116    INTEGER :: ip, n, nlev, nlevx
1117    INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
1118    REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
1119
1120  IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d ',var%name
1121
1122! ug RUSTINE POUR LES STD LEVS.....
1123      IF (PRESENT(STD_iff)) THEN
1124            iff_beg = STD_iff
1125            iff_end = STD_iff
1126      ELSE
1127            iff_beg = 1
1128            iff_end = nfiles
1129      ENDIF
1130
1131  ! On regarde si on est dans la phase de définition ou d'écriture:
1132  IF(.NOT.vars_defined) THEN
1133      !Si phase de définition.... on définit
1134!$OMP MASTER
1135      DO iff=iff_beg, iff_end
1136        IF (clef_files(iff)) THEN
1137          CALL histdef3d(iff, var)
1138        ENDIF
1139      ENDDO
1140!$OMP END MASTER
1141  ELSE
1142    !Et sinon on.... écrit
1143
1144    IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev) CALL abort_physic('iophy::histwrite3d_xios','Field first DIMENSION not equal to klon/klev',1)
1145
1146    nlev=SIZE(field,2)
1147    IF (nlev.EQ.klev+1) THEN
1148        nlevx=klev
1149    ELSE
1150        nlevx=nlev
1151    ENDIF
1152
1153    IF (SIZE(field,1) == klon) then
1154        CALL Gather_omp(field,buffer_omp)
1155    ELSE
1156        buffer_omp(:,:)=0.
1157    ENDIF
1158!$OMP MASTER
1159    CALL grid1Dto2D_mpi(buffer_omp,field3d)
1160
1161
1162! BOUCLE SUR LES FICHIERS
1163     firstx=.true.
1164
1165      IF (ok_all_xml) THEN
1166#ifdef CPP_XIOS
1167          IF (prt_level >= 10) THEN
1168             write(lunout,*)'Dans iophy histwrite3D,var%name ',&
1169                             trim(var%name)                       
1170          ENDIF
1171          IF (SIZE(field,1) == klon) then
1172             CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
1173          ELSE
1174             CALL xios_send_field(var%name, field)
1175          ENDIF
1176#else
1177        CALL abort_physic ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1)
1178#endif
1179      ELSE 
1180
1181
1182     DO iff=iff_beg, iff_end
1183            IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
1184#ifdef CPP_XIOS
1185              IF (firstx) THEN
1186                IF (prt_level >= 10) THEn
1187                  WRITE (lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', &
1188                                  iff,nlev,klev, firstx                       
1189                  WRITE (lunout,*)'histwrite3d_phy: call xios_send_field for ', &
1190                                  trim(var%name), ' with iim jjm nlevx = ', &
1191                                  nbp_lon,jj_nb,nlevx
1192                ENDIF
1193                IF (SIZE(field,1) == klon) then
1194                    CALL xios_send_field(var%name, Field3d(:,:,1:nlevx))
1195                ELSE
1196                     CALL xios_send_field(var%name, field)
1197                ENDIF
1198                firstx=.false.
1199              ENDIF
1200#endif
1201                IF (.NOT.clef_stations(iff)) THEN
1202                        ALLOCATE(index3d(nbp_lon*jj_nb*nlev))
1203                        ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
1204
1205#ifndef CPP_IOIPSL_NO_OUTPUT
1206                        CALL histwrite(nid_files(iff),var%name,itau_iophy,Field3d,nbp_lon*jj_nb*nlev,index3d)
1207#endif
1208
1209!#ifdef CPP_XIOS
1210!                        IF (iff == 1) THEN
1211!                              CALL xios_send_field(var%name, Field3d(:,:,1:klev))
1212!                        ENDIF
1213!#endif
1214!                       
1215                ELSE
1216                        nlev=size(field,2)
1217                        ALLOCATE(index3d(npstn*nlev))
1218                        ALLOCATE(fieldok(npstn,nlev))
1219
1220                        IF (is_sequential) THEN
1221                              DO n=1, nlev
1222                                    DO ip=1, npstn
1223                                          fieldok(ip,n)=buffer_omp(nptabij(ip),n)
1224                                    ENDDO
1225                              ENDDO
1226                        ELSE
1227                              DO n=1, nlev
1228                                    DO ip=1, npstn
1229                                                IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1230                                                      nptabij(ip).LE.klon_mpi_end) THEN
1231                                                fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
1232                                          ENDIF
1233                                    ENDDO
1234                              ENDDO
1235                        ENDIF
1236#ifndef CPP_IOIPSL_NO_OUTPUT
1237                        CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn*nlev,index3d)
1238#endif
1239                  ENDIF
1240                  DEALLOCATE(index3d)
1241                  DEALLOCATE(fieldok)
1242            ENDIF
1243      ENDDO
1244      ENDIF
1245!$OMP END MASTER   
1246  ENDIF ! vars_defined
1247  IF (prt_level >= 10) write(lunout,*)'End histrwrite3d ',var%name
1248  END SUBROUTINE histwrite3d_phy
1249 
1250
1251! VERSION DES HISTWRITE DEDIEES AU TOUT-XIOS-XML DEJA UTILISEE DANS PHYDEV
1252#ifdef CPP_XIOS
1253  SUBROUTINE histwrite2d_xios(field_name,field)
1254  USE dimphy, ONLY: klon, klev
1255  USE mod_phys_lmdz_para, ONLY: gather_omp, grid1Dto2D_mpi, &
1256                                is_sequential, klon_mpi_begin, klon_mpi_end, &
1257                                jj_nb, klon_mpi
1258  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
1259  USE xios, ONLY: xios_send_field
1260  USE print_control_mod, ONLY: prt_level,lunout
1261
1262  IMPLICIT NONE
1263
1264    CHARACTER(LEN=*), INTENT(IN) :: field_name
1265    REAL, DIMENSION(:), INTENT(IN) :: field
1266     
1267    REAL,DIMENSION(klon_mpi) :: buffer_omp
1268    INTEGER, allocatable, DIMENSION(:) :: index2d
1269    REAL :: Field2d(nbp_lon,jj_nb)
1270
1271    INTEGER :: ip
1272    REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
1273
1274    IF (prt_level >= 10) WRITE(lunout,*)'Begin histrwrite2d_xios ',field_name
1275
1276    !Et sinon on.... écrit
1277    IF (SIZE(field)/=klon .AND. SIZE(field)/=klev) CALL abort_physic('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon/klev',1)
1278   
1279    IF (SIZE(field) == klev) then
1280!$OMP MASTER
1281        CALL xios_send_field(field_name,field)
1282!$OMP END MASTER   
1283    ELSE
1284        CALL Gather_omp(field,buffer_omp)   
1285!$OMP MASTER
1286        CALL grid1Dto2D_mpi(buffer_omp,Field2d)
1287   
1288!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1289!ATTENTION, STATIONS PAS GEREES !
1290!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1291    !IF(.NOT.clef_stations(iff)) THEN
1292        IF (.TRUE.) THEN
1293            ALLOCATE(index2d(nbp_lon*jj_nb))
1294            ALLOCATE(fieldok(nbp_lon*jj_nb))
1295   
1296   
1297            CALL xios_send_field(field_name, Field2d)
1298   
1299        ELSE
1300            ALLOCATE(fieldok(npstn))
1301            ALLOCATE(index2d(npstn))
1302   
1303            IF (is_sequential) THEN
1304                DO ip=1, npstn
1305                    fieldok(ip)=buffer_omp(nptabij(ip))
1306                ENDDO
1307            ELSE
1308                DO ip=1, npstn
1309                    PRINT*,'histwrite2d_xios is_sequential npstn ip namenptabij',npstn,ip,field_name,nptabij(ip)
1310                    IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1311                    nptabij(ip).LE.klon_mpi_end) THEN
1312                        fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
1313                    ENDIF
1314                ENDDO
1315            ENDIF
1316   
1317        ENDIF
1318                 
1319        DEALLOCATE(index2d)
1320        DEALLOCATE(fieldok)
1321!$OMP END MASTER   
1322    ENDIF
1323
1324  IF (prt_level >= 10) WRITE(lunout,*)'End histrwrite2d_xios ',field_name
1325  END SUBROUTINE histwrite2d_xios
1326
1327
1328! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
1329  SUBROUTINE histwrite3d_xios(field_name, field)
1330  USE dimphy, ONLY: klon, klev
1331  USE mod_phys_lmdz_para, ONLY: gather_omp, grid1Dto2D_mpi, &
1332                                is_sequential, klon_mpi_begin, klon_mpi_end, &
1333                                jj_nb, klon_mpi
1334  USE xios, ONLY: xios_send_field
1335  USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
1336  USE print_control_mod, ONLY: prt_level,lunout
1337
1338  IMPLICIT NONE
1339
1340    CHARACTER(LEN=*), INTENT(IN) :: field_name
1341    REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
1342
1343    REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
1344    REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2))
1345    INTEGER :: ip, n, nlev
1346    INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
1347    REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
1348
1349  IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d_xios ',field_name
1350
1351    !Et on.... écrit
1352    IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev) CALL abort_physic('iophy::histwrite3d_xios','Field first DIMENSION not equal to klon/klev',1)
1353   
1354    IF (SIZE(field,1) == klev) then
1355!$OMP MASTER
1356        CALL xios_send_field(field_name,field)
1357!$OMP END MASTER   
1358    ELSE
1359        nlev=SIZE(field,2)
1360
1361
1362        CALL Gather_omp(field,buffer_omp)
1363!$OMP MASTER
1364        CALL grid1Dto2D_mpi(buffer_omp,field3d)
1365
1366!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1367!ATTENTION, STATIONS PAS GEREES !
1368!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1369    !IF (.NOT.clef_stations(iff)) THEN
1370        IF(.TRUE.)THEN
1371            ALLOCATE(index3d(nbp_lon*jj_nb*nlev))
1372            ALLOCATE(fieldok(nbp_lon*jj_nb,nlev))
1373            CALL xios_send_field(field_name, Field3d(:,:,1:nlev))
1374                           
1375        ELSE
1376            nlev=size(field,2)
1377            ALLOCATE(index3d(npstn*nlev))
1378            ALLOCATE(fieldok(npstn,nlev))
1379   
1380            IF (is_sequential) THEN
1381                DO n=1, nlev
1382                    DO ip=1, npstn
1383                        fieldok(ip,n)=buffer_omp(nptabij(ip),n)
1384                    ENDDO
1385                ENDDO
1386            ELSE
1387                DO n=1, nlev
1388                    DO ip=1, npstn
1389                        IF(nptabij(ip).GE.klon_mpi_begin.AND. &
1390                        nptabij(ip).LE.klon_mpi_end) THEN
1391                            fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
1392                        ENDIF
1393                    ENDDO
1394                ENDDO
1395            ENDIF
1396        ENDIF
1397        DEALLOCATE(index3d)
1398        DEALLOCATE(fieldok)
1399!$OMP END MASTER   
1400    ENDIF
1401
1402  IF (prt_level >= 10) write(lunout,*)'End histrwrite3d_xios ',field_name
1403  END SUBROUTINE histwrite3d_xios
1404
1405#ifdef CPP_XIOS
1406  SUBROUTINE histwrite0d_xios(field_name, field)
1407  USE xios, ONLY: xios_send_field
1408  IMPLICIT NONE
1409
1410    CHARACTER(LEN=*), INTENT(IN) :: field_name
1411    REAL, INTENT(IN) :: field ! --> scalar
1412
1413!$OMP MASTER
1414   CALL xios_send_field(field_name, field)
1415!$OMP END MASTER
1416
1417  END SUBROUTINE histwrite0d_xios
1418#endif
1419
1420#endif
1421end module iophy
Note: See TracBrowser for help on using the repository browser.