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

Last change on this file since 1992 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

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