source: LMDZ5/trunk/libf/phylmd/iophy.F90 @ 2311

Last change on this file since 2311 was 2311, checked in by Ehouarn Millour, 9 years ago

Further modifications to enforce physics/dynamics separation:

  • moved iniprint.h and misc_mod back to dyn3d_common, as these should only be used by dynamics.
  • created print_control_mod in the physics to store flags prt_level, lunout, debug to be local to physics (should be used rather than iniprint.h)
  • created abort_physic.F90 , which does the same job as abort_gcm() did, but should be used instead when in physics.
  • reactivated inifis (turned it into a module, inifis_mod.F90) to initialize physical constants and print_control_mod flags.

EM

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