source: LMDZ5/branches/LMDZ6_rc0/libf/phylmd/iophy.F90 @ 3069

Last change on this file since 3069 was 2160, checked in by Laurent Fairhead, 10 years ago

Merged trunk changes -r2070:2158 into testing branch. Compilation problems introduced by revision r2155 have been corrected by hand

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