source: LMDZ6/trunk/libf/phylmd/cosp2/cosp_output_write_mod.F90 @ 3397

Last change on this file since 3397 was 3397, checked in by idelkadi, 6 years ago

Correction de diagnostique (reflectance parasol calcule en fonction de la fraction nuageuse totale Cltcalipso)

File size: 31.6 KB
Line 
1!!!! Abderrahmane Idelkadi aout 2013 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2! Module pour definir (au 1er appel) et ecrire les variables dans les fichiers de sortie cosp
3!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4   MODULE cosp_output_write_mod
5 
6   USE cosp_output_mod
7   USE MOD_COSP_INTERFACE_v1p4, ONLY: cosp_config, cosp_gridbox, cosp_sglidar, &
8                                      cosp_sgradar, cosp_isccp, cosp_lidarstats, &
9                                      cosp_radarstats, cosp_modis, cosp_misr, cosp_vgrid
10   USE mod_cosp_config, only : R_UNDEF, DBZE_BINS, SR_BINS, CFAD_ZE_MIN, PARASOL_NREFL, &
11                              CFAD_ZE_WIDTH,vgrid_zl,vgrid_zu,vgrid_z,PARASOL_SZA, &
12                              isccp_histPresCenters,tau_binCenters, LIDAR_NTEMP, &
13                              LIDAR_PHASE_TEMP,misr_histHgtCenters,numMISRHgtBins, &
14                              numMODISReffIceBins,reffICE_binCenters, &
15                              numMODISReffLiqBins, reffLIQ_binCenters
16
17 
18   IMPLICIT NONE
19
20   INTEGER, SAVE  :: itau_iocosp
21!$OMP THREADPRIVATE(itau_iocosp)
22   INTEGER, save        :: Nlevout, Ncolout
23!$OMP THREADPRIVATE(Nlevout, Ncolout)
24
25!  INTERFACE histwrite_cosp
26!    MODULE PROCEDURE histwrite2d_cosp,histwrite3d_cosp
27!  END INTERFACE
28
29   CONTAINS
30
31  SUBROUTINE cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_cosp, &
32                               cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, &
33                               isccp, misr, modis)
34
35    USE ioipsl
36    USE time_phylmdz_mod, ONLY: itau_phy, start_time, day_step_phy
37    USE print_control_mod, ONLY: lunout,prt_level
38
39#ifdef CPP_XIOS
40    USE wxios, only: wxios_closedef
41    USE xios, only: xios_update_calendar, xios_field_is_active
42#endif
43  IMPLICIT NONE 
44!!! Variables d'entree
45  integer               :: itap, Nlevlmdz, Ncolumns, Npoints
46  real                  :: freq_COSP, dtime, missing_val, missing_cosp
47  type(cosp_config)     :: cfg     ! Control outputs
48  type(cosp_gridbox)    :: gbx     ! Gridbox information. Input for COSP
49  type(cosp_sglidar)    :: sglidar ! Output from lidar simulator
50  type(cosp_sgradar)    :: sgradar ! Output from radar simulator
51  type(cosp_isccp)      :: isccp   ! Output from ISCCP simulator
52  type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator
53  type(cosp_radarstats) :: stradar
54  type(cosp_misr)       :: misr    ! Output from MISR
55  type(cosp_modis)      :: modis   ! Outputs from Modis
56  type(cosp_vgrid)      :: vgrid   ! Information on vertical grid of stats
57
58!!! Variables locales
59  integer               :: icl,k,ip
60  logical               :: ok_sync
61  integer               :: itau_wcosp, iff
62  real, dimension(Npoints,PARASOL_NREFL) :: parasolcrefl, Ncref
63
64! Variables locals intermidiaires pour inverser les axes des champs 4D
65! Compatibilite avec sorties CMIP
66  real, dimension(Npoints,Nlevout,SR_BINS) :: tmp_fi4da_cfadL
67  real, dimension(Npoints,Nlevout,DBZE_BINS) :: tmp_fi4da_cfadR
68  real, dimension(Npoints,numMISRHgtBins,7) :: tmp_fi4da_misr
69
70#ifdef CPP_XIOS
71  missing_val=missing_cosp
72#else
73  missing_val=0.
74#endif
75
76  Nlevout = vgrid%Nlvgrid
77  Ncolout = Ncolumns
78
79! A refaire
80       itau_wcosp = itau_phy + itap + start_time * day_step_phy
81        if (prt_level >= 10) then
82             WRITE(lunout,*)'itau_wcosp, itap, start_time, day_step_phy =', &
83                             itau_wcosp, itap, start_time, day_step_phy
84        endif
85
86! On le donne a  cosp_output_write_mod pour que les histwrite y aient acces:
87       CALL set_itau_iocosp(itau_wcosp)
88        if (prt_level >= 10) then
89              WRITE(lunout,*)'itau_iocosp =',itau_iocosp
90        endif
91
92    ok_sync = .TRUE.
93   
94!DO iinit=1, iinitend
95! AI sept 2014 cette boucle supprimee
96! On n'ecrit pas quand itap=1 (cosp)
97
98!   if (prt_level >= 10) then
99!         WRITE(lunout,*)'DO iinit=1, iinitend ',iinitend
100!   endif
101
102!!#ifdef CPP_XIOS
103! !$OMP MASTER
104!IF (cosp_varsdefined) THEN
105!   if (prt_level >= 10) then
106!         WRITE(lunout,*)'Apell xios_update_calendar cosp_varsdefined iinitend ', &
107!                         cosp_varsdefined,iinitend
108!   endif
109!    CALL xios_update_calendar(itau_wcosp)
110!ENDIF
111!  !$OMP END MASTER
112!  !$OMP BARRIER
113!!#endif
114
115!!!! Sorties Calipso
116 if (cfg%Llidar_sim) then
117!!! AI 02 2018
118! Traitement missing_val
119   where(stlidar%lidarcld == R_UNDEF) stlidar%lidarcld = missing_val
120!   where(stlidar%proftemp == R_UNDEF) stlidar%proftemp = missing_val   !TIBO 
121!   where(stlidar%profSR == R_UNDEF) stlidar%profSR = missing_val       !TIBO2
122   where(sglidar%beta_mol == R_UNDEF) sglidar%beta_mol = missing_val 
123   where(sglidar%beta_tot == R_UNDEF) sglidar%beta_tot = missing_val
124   where(stlidar%cldlayer == R_UNDEF) stlidar%cldlayer = missing_val
125!   where(stlidar%cldtype == R_UNDEF) stlidar%cldtype = missing_val     !OPAQ
126   where(stlidar%cfad_sr == R_UNDEF) stlidar%cfad_sr = missing_val
127! AI 11 / 2015
128   where(stlidar%parasolrefl == R_UNDEF) stlidar%parasolrefl = missing_val
129   where(stlidar%lidarcldtmp == R_UNDEF) stlidar%lidarcldtmp = missing_val
130   where(stlidar%cldlayerphase == R_UNDEF) stlidar%cldlayerphase = missing_val
131   where(stlidar%lidarcldphase == R_UNDEF) stlidar%lidarcldphase = missing_val
132!   where(stlidar%lidarcldtype == R_UNDEF) stlidar%lidarcldtype = missing_val   !OPAQ
133   where(stlidar%lidarcldtmp == R_UNDEF) stlidar%lidarcldtmp = missing_val
134 
135!   print*,'Appel histwrite2d_cosp'
136   if (cfg%Lcllcalipso) CALL histwrite2d_cosp(o_cllcalipso,stlidar%cldlayer(:,1))
137   if (cfg%Lclhcalipso) CALL histwrite2d_cosp(o_clhcalipso,stlidar%cldlayer(:,3))
138   if (cfg%Lclmcalipso) CALL histwrite2d_cosp(o_clmcalipso,stlidar%cldlayer(:,2))
139   if (cfg%Lcltcalipso) CALL histwrite2d_cosp(o_cltcalipso,stlidar%cldlayer(:,4))
140   if (cfg%Lclcalipso) CALL histwrite3d_cosp(o_clcalipso,stlidar%lidarcld,nvert)
141   if (cfg%Lclcalipsotmp) CALL histwrite3d_cosp(o_clcalipsotmp,stlidar%lidarcldtmp(:,:,1),nverttemp)
142
143   if (cfg%Lcllcalipsoice) CALL histwrite2d_cosp(o_cllcalipsoice,stlidar%cldlayerphase(:,1,1))
144   if (cfg%Lclhcalipsoice) CALL histwrite2d_cosp(o_clhcalipsoice,stlidar%cldlayerphase(:,3,1))
145   if (cfg%Lclmcalipsoice) CALL histwrite2d_cosp(o_clmcalipsoice,stlidar%cldlayerphase(:,2,1))
146   if (cfg%Lcltcalipsoice) CALL histwrite2d_cosp(o_cltcalipsoice,stlidar%cldlayerphase(:,4,1))
147   if (cfg%Lclcalipsoice) CALL histwrite3d_cosp(o_clcalipsoice,stlidar%lidarcldphase(:,:,1),nvert)
148   if (cfg%Lclcalipsotmpice) CALL histwrite3d_cosp(o_clcalipsotmpice,stlidar%lidarcldtmp(:,:,2),nverttemp)
149
150   if (cfg%Lcllcalipsoliq) CALL histwrite2d_cosp(o_cllcalipsoliq,stlidar%cldlayerphase(:,1,2))
151   if (cfg%Lclhcalipsoliq) CALL histwrite2d_cosp(o_clhcalipsoliq,stlidar%cldlayerphase(:,3,2))
152   if (cfg%Lclmcalipsoliq) CALL histwrite2d_cosp(o_clmcalipsoliq,stlidar%cldlayerphase(:,2,2))
153   if (cfg%Lcltcalipsoliq) CALL histwrite2d_cosp(o_cltcalipsoliq,stlidar%cldlayerphase(:,4,2))
154   if (cfg%Lclcalipsoliq) CALL histwrite3d_cosp(o_clcalipsoliq,stlidar%lidarcldphase(:,:,2),nvert)
155   if (cfg%Lclcalipsotmpliq) CALL histwrite3d_cosp(o_clcalipsotmpliq,stlidar%lidarcldtmp(:,:,3),nverttemp)
156
157   if (cfg%Lcllcalipsoun) CALL histwrite2d_cosp(o_cllcalipsoun,stlidar%cldlayerphase(:,1,3))
158   if (cfg%Lclhcalipsoun) CALL histwrite2d_cosp(o_clhcalipsoun,stlidar%cldlayerphase(:,3,3))
159   if (cfg%Lclmcalipsoun) CALL histwrite2d_cosp(o_clmcalipsoun,stlidar%cldlayerphase(:,2,3))
160   if (cfg%Lcltcalipsoun) CALL histwrite2d_cosp(o_cltcalipsoun,stlidar%cldlayerphase(:,4,3))
161   if (cfg%Lclcalipsoun) CALL histwrite3d_cosp(o_clcalipsoun,stlidar%lidarcldphase(:,:,3),nvert)
162   if (cfg%Lclcalipsotmpun) CALL histwrite3d_cosp(o_clcalipsotmpun,stlidar%lidarcldtmp(:,:,4),nverttemp)
163
164!   if (cfg%Lclopaquecalipso) CALL histwrite2d_cosp(o_clopaquecalipso,stlidar%cldtype(:,1))               !OPAQ
165!   if (cfg%Lclthincalipso) CALL histwrite2d_cosp(o_clthincalipso,stlidar%cldtype(:,2))                 !OPAQ
166!   if (cfg%Lclzopaquecalipso) CALL histwrite2d_cosp(o_clzopaquecalipso,stlidar%cldtype(:,3))              !OPAQ
167
168!   if (cfg%Lclcalipsoopaque) CALL histwrite3d_cosp(o_clcalipsoopaque,stlidar%lidarcldtype(:,:,1),nvert)  !OPAQ
169!   if (cfg%Lclcalipsothin) CALL histwrite3d_cosp(o_clcalipsothin,stlidar%lidarcldtype(:,:,2),nvert)    !OPAQ
170!   if (cfg%Lclcalipsozopaque) CALL histwrite3d_cosp(o_clcalipsozopaque,stlidar%lidarcldtype(:,:,3),nvert) !OPAQ
171!   if (cfg%Lclcalipsoopacity) CALL histwrite3d_cosp(o_clcalipsoopacity,stlidar%lidarcldtype(:,:,4),nvert) !OPAQ
172
173!   if (cfg%Lproftemp) CALL histwrite3d_cosp(o_proftemp,stlidar%proftemp,nvert)                    !TIBO
174
175#ifdef CPP_XIOS
176   do icl=1,SR_BINS
177      tmp_fi4da_cfadL(:,:,icl)=stlidar%cfad_sr(:,icl,:)
178   enddo
179!   if (cfg%LcfadLidarsr532) CALL histwrite4d_cosp(o_cfad_lidarsr532,stlidar%cfad_sr)
180   if (cfg%LcfadLidarsr532) CALL histwrite4d_cosp(o_cfad_lidarsr532,tmp_fi4da_cfadL)
181!   if (cfg%LprofSR) CALL histwrite4d_cosp(o_profSR,stlidar%profSR)                              !TIBO
182#else
183   if (cfg%LcfadLidarsr532) then
184     do icl=1,SR_BINS
185        CALL histwrite3d_cosp(o_cfad_lidarsr532,stlidar%cfad_sr(:,icl,:),nvert,icl)
186     enddo
187   endif
188!   if (cfg%LprofSR) then
189!     do icl=1,Ncolumns                                                              !TIBO
190!        CALL histwrite3d_cosp(o_profSR,stlidar%profSR(:,icl,:),nvert,icl)           !TIBO
191!     enddo                                                                          !TIBO
192!   endif
193#endif
194   if (cfg%LparasolRefl) CALL histwrite3d_cosp(o_parasol_refl,stlidar%parasolrefl,nvertp)
195
196  if (cfg%LparasolRefl) then
197    do k=1,PARASOL_NREFL
198     do ip=1, Npoints
199      if (stlidar%cldlayer(ip,4).gt.1.and.stlidar%parasolrefl(ip,k).ne.missing_val) then
200        parasolcrefl(ip,k)=(stlidar%parasolrefl(ip,k)-0.03*(1.-stlidar%cldlayer(ip,4)/100.))/ &
201                             stlidar%cldlayer(ip,4)/100.
202         Ncref(ip,k) = 1.
203      else
204         parasolcrefl(ip,k)=missing_val
205         Ncref(ip,k) = 0.
206      endif
207     enddo
208    enddo
209    CALL histwrite3d_cosp(o_Ncrefl,Ncref,nvertp)
210    CALL histwrite3d_cosp(o_parasol_crefl,parasolcrefl,nvertp)
211  endif
212
213#ifdef CPP_XIOS
214   if (cfg%Latb532) CALL histwrite4d_cosp(o_atb532,sglidar%beta_tot)
215#else
216   if (cfg%Latb532) then 
217     do icl=1,Ncolumns
218        CALL histwrite3d_cosp(o_atb532,sglidar%beta_tot(:,icl,:),nvertmcosp,icl)
219     enddo
220   endif
221#endif
222
223   if (cfg%LlidarBetaMol532) CALL histwrite3d_cosp(o_beta_mol532,sglidar%beta_mol,nvertmcosp)
224
225 endif !Lidar
226
227!!! Sorties Cloudsat
228 if (cfg%Lradar_sim) then
229
230   where(stradar%cfad_ze == R_UNDEF) stradar%cfad_ze = missing_val
231#ifdef CPP_XIOS
232   do icl=1,DBZE_BINS
233     tmp_fi4da_cfadR(:,:,icl)=stradar%cfad_ze(:,icl,:)
234   enddo
235   if (cfg%Ldbze94) CALL histwrite4d_cosp(o_dbze94,sgradar%Ze_tot)
236!   if (cfg%LcfadDbze94) CALL histwrite4d_cosp(o_cfadDbze94,stradar%cfad_ze)
237   if (cfg%LcfadDbze94) CALL histwrite4d_cosp(o_cfadDbze94,tmp_fi4da_cfadR)
238#else
239   if (cfg%Ldbze94) then
240    do icl=1,Ncolumns
241       CALL histwrite3d_cosp(o_dbze94,sgradar%Ze_tot(:,icl,:),nvert,icl)
242    enddo
243   endif
244   if (cfg%LcfadDbze94) then
245    do icl=1,DBZE_BINS
246    CALL histwrite3d_cosp(o_cfadDbze94,stradar%cfad_ze(:,icl,:),nvert,icl)
247    enddo
248   endif
249#endif
250 endif
251! endif pour radar
252
253!!! Sorties combinees Cloudsat et Calipso
254 if (cfg%Llidar_sim .and. cfg%Lradar_sim) then
255   where(stradar%lidar_only_freq_cloud == R_UNDEF) &
256                           stradar%lidar_only_freq_cloud = missing_val
257   if (cfg%Lclcalipso) CALL histwrite3d_cosp(o_clcalipso2,stradar%lidar_only_freq_cloud,nvert)
258   where(stradar%radar_lidar_tcc == R_UNDEF) &
259                           stradar%radar_lidar_tcc = missing_val
260   if (cfg%Lcltlidarradar) CALL histwrite2d_cosp(o_cltlidarradar,stradar%radar_lidar_tcc)
261 endif
262
263!!! Sorties Isccp
264 if (cfg%Lisccp_sim) then
265  where(isccp%totalcldarea == R_UNDEF) isccp%totalcldarea = missing_val
266  where(isccp%meanptop == R_UNDEF) isccp%meanptop = missing_val
267  where(isccp%meantaucld == R_UNDEF) isccp%meantaucld = missing_val
268  where(isccp%meanalbedocld == R_UNDEF) isccp%meanalbedocld = missing_val
269  where(isccp%meantb == R_UNDEF) isccp%meantb = missing_val
270  where(isccp%meantbclr == R_UNDEF) isccp%meantbclr = missing_val
271  where(isccp%fq_isccp == R_UNDEF) isccp%fq_isccp = missing_val
272  where(isccp%boxtau == R_UNDEF) isccp%boxtau = missing_val
273  where(isccp%boxptop == R_UNDEF) isccp%boxptop = missing_val
274
275   CALL histwrite2d_cosp(o_sunlit,gbx%sunlit)
276#ifdef CPP_XIOS
277  if (cfg%Lclisccp) CALL histwrite4d_cosp(o_clisccp2,isccp%fq_isccp)
278#else
279   if (cfg%Lclisccp) then
280     do icl=1,7
281       CALL histwrite3d_cosp(o_clisccp2,isccp%fq_isccp(:,icl,:),nvertisccp,icl)
282     enddo
283   endif
284#endif
285
286   if (cfg%Lboxtauisccp) CALL histwrite3d_cosp(o_boxtauisccp,isccp%boxtau,nvertcol)
287   if (cfg%Lboxptopisccp) CALL histwrite3d_cosp(o_boxptopisccp,isccp%boxptop,nvertcol)
288   if (cfg%Lcltisccp) CALL histwrite2d_cosp(o_tclisccp,isccp%totalcldarea)
289   if (cfg%Lpctisccp) CALL histwrite2d_cosp(o_ctpisccp,isccp%meanptop)
290   if (cfg%Ltauisccp) CALL histwrite2d_cosp(o_tauisccp,isccp%meantaucld)
291   if (cfg%Lalbisccp) CALL histwrite2d_cosp(o_albisccp,isccp%meanalbedocld)
292   if (cfg%Lmeantbisccp) CALL histwrite2d_cosp(o_meantbisccp,isccp%meantb)
293   if (cfg%Lmeantbclrisccp) CALL histwrite2d_cosp(o_meantbclrisccp,isccp%meantbclr)
294 endif ! Isccp
295
296!!! MISR simulator
297 if (cfg%Lmisr_sim) then
298   where(misr%fq_MISR == R_UNDEF) misr%fq_MISR = missing_val
299
300#ifdef CPP_XIOS
301   do icl=1,numMISRHgtBins
302      tmp_fi4da_misr(:,icl,:)=misr%fq_MISR(:,:,icl)
303   enddo
304!   if (cfg%LclMISR) CALL histwrite4d_cosp(o_clMISR,misr%fq_MISR)
305   if (cfg%LclMISR) CALL histwrite4d_cosp(o_clMISR,tmp_fi4da_misr)
306#else
307   if (cfg%LclMISR) then
308    do icl=1,7
309      CALL histwrite3d_cosp(o_clMISR,misr%fq_MISR(:,icl,:),nvertmisr,icl)
310    enddo
311   endif
312#endif
313 endif
314! endif pour Misr
315
316!!! Modis simulator
317 if (cfg%Lmodis_sim) then
318  where(modis%Cloud_Fraction_Low_Mean == R_UNDEF) &
319        modis%Cloud_Fraction_Low_Mean = missing_val
320  where(modis%Cloud_Fraction_High_Mean == R_UNDEF) &
321        modis%Cloud_Fraction_High_Mean = missing_val
322  where(modis%Cloud_Fraction_Mid_Mean == R_UNDEF) &
323        modis%Cloud_Fraction_Mid_Mean = missing_val
324  where(modis%Cloud_Fraction_Total_Mean == R_UNDEF) &
325        modis%Cloud_Fraction_Total_Mean = missing_val
326  where(modis%Cloud_Fraction_Water_Mean == R_UNDEF) &
327        modis%Cloud_Fraction_Water_Mean = missing_val
328  where(modis%Cloud_Fraction_Ice_Mean == R_UNDEF) &
329        modis%Cloud_Fraction_Ice_Mean = missing_val
330  where(modis%Optical_Thickness_Total_Mean == R_UNDEF) &
331        modis%Optical_Thickness_Total_Mean = missing_val
332  where(modis%Optical_Thickness_Water_Mean == R_UNDEF) &
333        modis%Optical_Thickness_Water_Mean = missing_val
334  where(modis%Optical_Thickness_Ice_Mean == R_UNDEF) &
335        modis%Optical_Thickness_Ice_Mean = missing_val
336  where(modis%Cloud_Particle_Size_Water_Mean == R_UNDEF) &
337        modis%Cloud_Particle_Size_Water_Mean = missing_val
338  where(modis%Cloud_Particle_Size_Ice_Mean == R_UNDEF) &
339        modis%Cloud_Particle_Size_Ice_Mean = missing_val
340  where(modis%Cloud_Top_Pressure_Total_Mean == R_UNDEF) &
341        modis%Cloud_Top_Pressure_Total_Mean = missing_val
342  where(modis%Liquid_Water_Path_Mean == R_UNDEF) &
343        modis%Liquid_Water_Path_Mean = missing_val
344  where(modis%Ice_Water_Path_Mean == R_UNDEF) &
345        modis%Ice_Water_Path_Mean = missing_val
346
347  where(modis%Optical_Thickness_Total_LogMean == R_UNDEF) &
348          modis%Optical_Thickness_Total_LogMean = missing_val
349           
350  where(modis%Optical_Thickness_Water_LogMean == R_UNDEF) &
351          modis%Optical_Thickness_Water_LogMean = missing_val
352
353  where(modis%Optical_Thickness_Ice_LogMean == R_UNDEF) &
354          modis%Optical_Thickness_Ice_LogMean = missing_val
355   
356  if (cfg%Lcllmodis) CALL histwrite2d_cosp(o_cllmodis,modis%Cloud_Fraction_Low_Mean)
357  if (cfg%Lclhmodis) CALL histwrite2d_cosp(o_clhmodis,modis%Cloud_Fraction_High_Mean)
358  if (cfg%Lclmmodis) CALL histwrite2d_cosp(o_clmmodis,modis%Cloud_Fraction_Mid_Mean)
359  if (cfg%Lcltmodis) CALL histwrite2d_cosp(o_cltmodis,modis%Cloud_Fraction_Total_Mean)
360  if (cfg%Lclwmodis) CALL histwrite2d_cosp(o_clwmodis,modis%Cloud_Fraction_Water_Mean)
361  if (cfg%Lclimodis) CALL histwrite2d_cosp(o_climodis,modis%Cloud_Fraction_Ice_Mean)
362  if (cfg%Ltautmodis)  CALL histwrite2d_cosp(o_tautmodis,modis%Optical_Thickness_Total_Mean)
363  if (cfg%Ltauwmodis) CALL histwrite2d_cosp(o_tauwmodis,modis%Optical_Thickness_Water_Mean)
364  if (cfg%Ltauimodis) CALL histwrite2d_cosp(o_tauimodis,modis%Optical_Thickness_Ice_Mean)
365  if (cfg%Ltautlogmodis) CALL histwrite2d_cosp(o_tautlogmodis,modis%Optical_Thickness_Total_LogMean) 
366  if (cfg%Ltauwlogmodis) CALL histwrite2d_cosp(o_tauwlogmodis,modis%Optical_Thickness_Water_LogMean)
367  if (cfg%Ltauilogmodis) CALL histwrite2d_cosp(o_tauilogmodis,modis%Optical_Thickness_Ice_LogMean)
368  if (cfg%Lreffclwmodis) CALL histwrite2d_cosp(o_reffclwmodis,modis%Cloud_Particle_Size_Water_Mean)
369  if (cfg%Lreffclimodis) CALL histwrite2d_cosp(o_reffclimodis,modis%Cloud_Particle_Size_Ice_Mean)
370  if (cfg%Lpctmodis) CALL histwrite2d_cosp(o_pctmodis,modis%Cloud_Top_Pressure_Total_Mean)
371  if (cfg%Llwpmodis) CALL histwrite2d_cosp(o_lwpmodis,modis%Liquid_Water_Path_Mean)
372  if (cfg%Liwpmodis) CALL histwrite2d_cosp(o_iwpmodis,modis%Ice_Water_Path_Mean)
373
374    where(modis%Optical_Thickness_vs_Cloud_Top_Pressure == R_UNDEF) &
375          modis%Optical_Thickness_vs_Cloud_Top_Pressure = missing_val
376
377#ifdef CPP_XIOS
378   if (cfg%Lclmodis) CALL histwrite4d_cosp(o_clmodis,modis%Optical_Thickness_vs_Cloud_Top_Pressure)
379#else
380  if (cfg%Lclmodis) then
381   do icl=1,7
382   CALL histwrite3d_cosp(o_clmodis, &
383     modis%Optical_Thickness_vs_Cloud_Top_Pressure(:,icl,:),nvertisccp,icl)           
384   enddo
385  endif
386#endif
387
388    where(modis%Optical_Thickness_vs_ReffIce == R_UNDEF) &
389          modis%Optical_Thickness_vs_ReffIce = missing_val
390
391    where(modis%Optical_Thickness_vs_ReffLiq == R_UNDEF) &
392          modis%Optical_Thickness_vs_ReffLiq = missing_val
393
394#ifdef CPP_XIOS
395  if (cfg%Lclmodis) CALL histwrite4d_cosp(o_crimodis,modis%Optical_Thickness_vs_ReffIce)
396  if (cfg%Lclmodis) CALL histwrite4d_cosp(o_crlmodis,modis%Optical_Thickness_vs_ReffLiq)
397#else
398  if (cfg%Lclmodis) then
399    do icl=1,7
400     CALL histwrite3d_cosp(o_crimodis, &
401          modis%Optical_Thickness_vs_ReffIce(:,icl,:),nvertReffIce,icl)
402    enddo
403  endif
404  if (cfg%Lclmodis) then
405    do icl=1,7
406     CALL histwrite3d_cosp(o_crlmodis, &
407          modis%Optical_Thickness_vs_ReffLiq(:,icl,:),nvertReffLiq,icl)
408    enddo
409  endif
410#endif
411 endif !modis
412
413 IF(.NOT.cosp_varsdefined) THEN
414!$OMP MASTER
415#ifndef CPP_IOIPSL_NO_OUTPUT
416            DO iff=1,3
417                IF (cosp_outfilekeys(iff)) THEN
418                  CALL histend(cosp_nidfiles(iff))
419                ENDIF ! cosp_outfilekeys
420            ENDDO !  iff
421#endif
422! Fermeture dans phys_output_write
423!#ifdef CPP_XIOS
424            !On finalise l'initialisation:
425            !CALL wxios_closedef()
426!#endif
427
428!$OMP END MASTER
429!$OMP BARRIER
430            cosp_varsdefined = .TRUE.
431 END IF
432
433    IF(cosp_varsdefined) THEN
434! On synchronise les fichiers pour IOIPSL
435#ifndef CPP_IOIPSL_NO_OUTPUT
436!$OMP MASTER
437     DO iff=1,3
438         IF (ok_sync .AND. cosp_outfilekeys(iff)) THEN
439             CALL histsync(cosp_nidfiles(iff))
440         ENDIF
441     END DO
442!$OMP END MASTER
443#endif
444    ENDIF  !cosp_varsdefined
445
446    END SUBROUTINE cosp_output_write
447
448! ug Routine pour definir itau_iocosp depuis cosp_output_write_mod:
449  SUBROUTINE set_itau_iocosp(ito)
450      IMPLICIT NONE
451      INTEGER, INTENT(IN) :: ito
452      itau_iocosp = ito
453  END SUBROUTINE
454
455  SUBROUTINE histdef2d_cosp (iff,var)
456
457    USE ioipsl
458    USE dimphy
459    use iophy
460    USE mod_phys_lmdz_para
461    USE mod_grid_phy_lmdz, ONLY: nbp_lon
462    USE print_control_mod, ONLY: lunout,prt_level
463#ifdef CPP_XIOS
464  USE wxios
465#endif
466
467    IMPLICIT NONE
468
469    INCLUDE "clesphys.h"
470
471    INTEGER                          :: iff
472    TYPE(ctrl_outcosp)               :: var
473
474    REAL zstophym
475    CHARACTER(LEN=20) :: typeecrit
476
477    ! ug On récupère le type écrit de la structure:
478    !       Assez moche, Ã|  refaire si meilleure méthode...
479    IF (INDEX(var%cosp_typeecrit(iff), "once") > 0) THEN
480       typeecrit = 'once'
481    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_min") > 0) THEN
482       typeecrit = 't_min(X)'
483    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_max") > 0) THEN
484       typeecrit = 't_max(X)'
485    ELSE IF(INDEX(var%cosp_typeecrit(iff), "inst") > 0) THEN
486       typeecrit = 'inst(X)'
487    ELSE
488       typeecrit = cosp_outfiletypes(iff)
489    ENDIF
490
491    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
492       zstophym=zoutm_cosp(iff)
493    ELSE
494       zstophym=zdtimemoy_cosp
495    ENDIF
496
497#ifdef CPP_XIOS
498     IF (.not. ok_all_xml) then
499       IF ( var%cles(iff) ) THEN
500         if (prt_level >= 10) then
501              WRITE(lunout,*)'Appel wxios_add_field_to_file var%name =',var%name
502         endif
503        CALL wxios_add_field_to_file(var%name, 2, cosp_nidfiles(iff), cosp_outfilenames(iff), &
504                                     var%description, var%unit, 1, typeecrit)
505       ENDIF
506     ENDIF
507#endif
508
509#ifndef CPP_IOIPSL_NO_OUTPUT
510       IF ( var%cles(iff) ) THEN
511          CALL histdef (cosp_nidfiles(iff), var%name, var%description, var%unit, &
512               nbp_lon,jj_nb,nhoricosp(iff), 1,1,1, -99, 32, &
513               typeecrit, zstophym,zoutm_cosp(iff))
514       ENDIF
515#endif
516
517  END SUBROUTINE histdef2d_cosp
518
519 SUBROUTINE histdef3d_cosp (iff,var,nvertsave,ncols)
520    USE ioipsl
521    USE dimphy
522    use iophy
523    USE mod_phys_lmdz_para
524    USE mod_grid_phy_lmdz, ONLY: nbp_lon
525    USE print_control_mod, ONLY: lunout,prt_level
526
527#ifdef CPP_XIOS
528  USE wxios
529#endif
530
531
532    IMPLICIT NONE
533
534    INCLUDE "clesphys.h"
535
536    INTEGER                        :: iff, klevs
537    INTEGER, INTENT(IN), OPTIONAL  :: ncols ! ug RUSTINE POUR LES variables 4D
538    INTEGER, INTENT(IN)           :: nvertsave
539    TYPE(ctrl_outcosp)             :: var
540
541    REAL zstophym
542    CHARACTER(LEN=20) :: typeecrit, nomi
543    CHARACTER(LEN=20) :: nom
544    character(len=2) :: str2
545    CHARACTER(len=20) :: nam_axvert
546
547! Axe vertical
548      IF (nvertsave.eq.nvertp(iff)) THEN
549          klevs=PARASOL_NREFL
550          nam_axvert="sza"
551      ELSE IF (nvertsave.eq.nvertisccp(iff)) THEN
552          klevs=7
553          nam_axvert="pressure2"
554      ELSE IF (nvertsave.eq.nvertcol(iff)) THEN
555          klevs=Ncolout
556          nam_axvert="column"
557      ELSE IF (nvertsave.eq.nverttemp(iff)) THEN
558          klevs=LIDAR_NTEMP
559          nam_axvert="temp"
560      ELSE IF (nvertsave.eq.nvertmisr(iff)) THEN
561          klevs=numMISRHgtBins
562          nam_axvert="cth16"
563      ELSE IF (nvertsave.eq.nvertReffIce(iff)) THEN
564          klevs= numMODISReffIceBins
565          nam_axvert="ReffIce"
566      ELSE IF (nvertsave.eq.nvertReffLiq(iff)) THEN
567          klevs= numMODISReffLiqBins
568          nam_axvert="ReffLiq"
569      ELSE
570           klevs=Nlevout
571           nam_axvert="presnivs"
572      ENDIF
573
574! ug RUSTINE POUR LES Champs 4D
575      IF (PRESENT(ncols)) THEN
576               write(str2,'(i2.2)')ncols
577               nomi=var%name
578               nom="c"//str2//"_"//nomi
579      ELSE
580               nom=var%name
581      END IF
582
583    ! ug On récupère le type écrit de la structure:
584    !       Assez moche, Ã|  refaire si meilleure méthode...
585    IF (INDEX(var%cosp_typeecrit(iff), "once") > 0) THEN
586       typeecrit = 'once'
587    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_min") > 0) THEN
588       typeecrit = 't_min(X)'
589    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_max") > 0) THEN
590       typeecrit = 't_max(X)'
591    ELSE IF(INDEX(var%cosp_typeecrit(iff), "inst") > 0) THEN
592       typeecrit = 'inst(X)'
593    ELSE
594       typeecrit = cosp_outfiletypes(iff)
595    ENDIF
596
597    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
598       zstophym=zoutm_cosp(iff)
599    ELSE
600       zstophym=zdtimemoy_cosp
601    ENDIF
602
603#ifdef CPP_XIOS
604      IF (.not. ok_all_xml) then
605        IF ( var%cles(iff) ) THEN
606          if (prt_level >= 10) then
607              WRITE(lunout,*)'Appel wxios_add_field_to_file 3d nom variable nam_axvert = ',nom, nam_axvert
608          endif
609          CALL wxios_add_field_to_file(nom, 3, cosp_nidfiles(iff), cosp_outfilenames(iff), &
610                                       var%description, var%unit, 1, typeecrit, nam_axvert)
611        ENDIF
612      ENDIF
613#endif
614
615#ifndef CPP_IOIPSL_NO_OUTPUT
616       IF ( var%cles(iff) ) THEN
617          CALL histdef (cosp_nidfiles(iff), nom, var%description, var%unit, &
618               nbp_lon, jj_nb, nhoricosp(iff), klevs, 1, &
619               klevs, nvertsave, 32, typeecrit, &
620               zstophym, zoutm_cosp(iff))
621       ENDIF
622#endif
623
624  END SUBROUTINE histdef3d_cosp
625
626 SUBROUTINE histwrite2d_cosp(var,field)
627  USE dimphy
628  USE mod_phys_lmdz_para
629  USE ioipsl
630  use iophy
631  USE mod_grid_phy_lmdz, ONLY: nbp_lon
632  USE print_control_mod, ONLY: lunout,prt_level
633
634#ifdef CPP_XIOS
635  USE xios, only: xios_send_field
636#endif
637
638  IMPLICIT NONE
639  INCLUDE 'clesphys.h'
640
641    TYPE(ctrl_outcosp), INTENT(IN) :: var
642    REAL, DIMENSION(:), INTENT(IN) :: field
643
644    INTEGER :: iff
645
646    REAL,DIMENSION(klon_mpi) :: buffer_omp
647    INTEGER, allocatable, DIMENSION(:) :: index2d
648    REAL :: Field2d(nbp_lon,jj_nb)
649    CHARACTER(LEN=20) ::  nomi, nom
650    character(len=2) :: str2
651    LOGICAL, SAVE  :: firstx
652!$OMP THREADPRIVATE(firstx)
653
654    IF (prt_level >= 9) WRITE(lunout,*)'Begin histrwrite2d ',var%name
655
656  ! On regarde si on est dans la phase de définition ou d'écriture:
657  IF(.NOT.cosp_varsdefined) THEN
658!$OMP MASTER
659      !Si phase de définition.... on définit
660      CALL conf_cospoutputs(var%name,var%cles)
661      DO iff=1, 3
662         IF (cosp_outfilekeys(iff)) THEN
663            CALL histdef2d_cosp(iff, var)
664         ENDIF
665      ENDDO
666!$OMP END MASTER
667  ELSE
668    !Et sinon on.... écrit
669    IF (SIZE(field)/=klon) &
670  CALL abort_physic('iophy::histwrite2d_cosp','Field first DIMENSION not equal to klon',1)
671
672    CALL Gather_omp(field,buffer_omp)
673!$OMP MASTER
674    CALL grid1Dto2D_mpi(buffer_omp,Field2d)
675
676! La boucle sur les fichiers:
677      firstx=.true.
678      DO iff=1, 3
679           IF (var%cles(iff) .AND. cosp_outfilekeys(iff)) THEN
680                ALLOCATE(index2d(nbp_lon*jj_nb))
681#ifndef CPP_IOIPSL_NO_OUTPUT
682        CALL histwrite(cosp_nidfiles(iff),var%name,itau_iocosp,Field2d,nbp_lon*jj_nb,index2d)
683#endif
684                deallocate(index2d)
685#ifdef CPP_XIOS
686              IF (.not. ok_all_xml) then
687                 if (firstx) then
688                  if (prt_level >= 10) then
689                    WRITE(lunout,*)'xios_send_field variable ',var%name
690                  endif
691                  CALL xios_send_field(var%name, Field2d)
692                   firstx=.false.
693                 endif
694              ENDIF
695#endif
696           ENDIF
697      ENDDO
698
699#ifdef CPP_XIOS
700      IF (ok_all_xml) THEN
701        if (prt_level >= 1) then
702              WRITE(lunout,*)'xios_send_field variable ',var%name
703        endif
704       CALL xios_send_field(var%name, Field2d)
705      ENDIF
706#endif
707
708!$OMP END MASTER   
709  ENDIF ! vars_defined
710  IF (prt_level >= 9) WRITE(lunout,*)'End histrwrite2d_cosp ',var%name
711  END SUBROUTINE histwrite2d_cosp
712
713! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
714! AI sept 2013
715  SUBROUTINE histwrite3d_cosp(var, field, nverts, ncols)
716  USE dimphy
717  USE mod_phys_lmdz_para
718  USE ioipsl
719  use iophy
720  USE mod_grid_phy_lmdz, ONLY: nbp_lon
721  USE print_control_mod, ONLY: lunout,prt_level
722
723#ifdef CPP_XIOS
724  USE xios, only: xios_send_field
725#endif
726
727
728  IMPLICIT NONE
729  INCLUDE 'clesphys.h'
730
731    TYPE(ctrl_outcosp), INTENT(IN)    :: var
732    REAL, DIMENSION(:,:), INTENT(IN)  :: field ! --> field(klon,:)
733    INTEGER, INTENT(IN), OPTIONAL     :: ncols ! ug RUSTINE POUR LES Champs 4D.....
734    INTEGER, DIMENSION(3), INTENT(IN) :: nverts
735
736    INTEGER :: iff, k
737
738    REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
739    REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2))
740    INTEGER :: ip, n, nlev
741    INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
742    CHARACTER(LEN=20) ::  nomi, nom
743    character(len=2) :: str2
744    LOGICAL, SAVE  :: firstx
745!$OMP THREADPRIVATE(firstx)
746
747  IF (prt_level >= 9) write(lunout,*)'Begin histrwrite3d ',var%name
748
749! ug RUSTINE POUR LES STD LEVS.....
750      IF (PRESENT(ncols)) THEN
751              write(str2,'(i2.2)')ncols
752              nomi=var%name
753              nom="c"//str2//"_"//nomi
754      ELSE
755               nom=var%name
756      END IF
757  ! On regarde si on est dans la phase de définition ou d'écriture:
758  IF(.NOT.cosp_varsdefined) THEN
759      !Si phase de définition.... on définit
760!$OMP MASTER
761      CALL conf_cospoutputs(var%name,var%cles)
762      DO iff=1, 3
763        IF (cosp_outfilekeys(iff)) THEN
764          CALL histdef3d_cosp(iff, var, nverts(iff), ncols)
765        ENDIF
766      ENDDO
767!$OMP END MASTER
768  ELSE
769    !Et sinon on.... écrit
770    IF (SIZE(field,1)/=klon) &
771   CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)                                 
772    nlev=SIZE(field,2)
773
774
775    CALL Gather_omp(field,buffer_omp)
776!$OMP MASTER
777    CALL grid1Dto2D_mpi(buffer_omp,field3d)
778
779! BOUCLE SUR LES FICHIERS
780     firstx=.true.
781     DO iff=1, 3
782        IF (var%cles(iff) .AND. cosp_outfilekeys(iff)) THEN
783           ALLOCATE(index3d(nbp_lon*jj_nb*nlev))
784#ifndef CPP_IOIPSL_NO_OUTPUT
785    CALL histwrite(cosp_nidfiles(iff),nom,itau_iocosp,Field3d,nbp_lon*jj_nb*nlev,index3d)
786#endif
787
788#ifdef CPP_XIOS
789          IF (.not. ok_all_xml) then
790           IF (firstx) THEN
791               CALL xios_send_field(nom, Field3d(:,:,1:nlev))
792               IF (prt_level >= 9) WRITE(lunout,*)'xios_send_field ',var%name
793               firstx=.FALSE.
794           ENDIF
795          ENDIF
796#endif
797         deallocate(index3d)
798        ENDIF
799      ENDDO
800#ifdef CPP_XIOS
801    IF (ok_all_xml) THEN
802     CALL xios_send_field(nom, Field3d(:,:,1:nlev))
803     IF (prt_level >= 1) WRITE(lunout,*)'xios_send_field ',var%name
804    ENDIF
805#endif
806
807!$OMP END MASTER   
808  ENDIF ! vars_defined
809  IF (prt_level >= 9) write(lunout,*)'End histrwrite3d_cosp ',nom
810  END SUBROUTINE histwrite3d_cosp
811
812! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
813! AI sept 2013
814  SUBROUTINE histwrite4d_cosp(var, field)
815  USE dimphy
816  USE mod_phys_lmdz_para
817  USE ioipsl
818  use iophy
819  USE mod_grid_phy_lmdz, ONLY: nbp_lon
820  USE print_control_mod, ONLY: lunout,prt_level
821
822#ifdef CPP_XIOS
823  USE xios, only: xios_send_field
824#endif
825
826
827  IMPLICIT NONE
828  INCLUDE 'clesphys.h'
829
830    TYPE(ctrl_outcosp), INTENT(IN)    :: var
831    REAL, DIMENSION(:,:,:), INTENT(IN)  :: field ! --> field(klon,:)
832
833    INTEGER :: iff, k
834
835    REAL,DIMENSION(klon_mpi,SIZE(field,2),SIZE(field,3)) :: buffer_omp
836    REAL :: field4d(nbp_lon,jj_nb,SIZE(field,2),SIZE(field,3))
837    INTEGER :: ip, n, nlev, nlev2
838    INTEGER, ALLOCATABLE, DIMENSION(:) :: index4d
839    CHARACTER(LEN=20) ::  nomi, nom
840
841  IF (prt_level >= 9) write(lunout,*)'Begin histrwrite4d ',var%name
842
843  IF(cosp_varsdefined) THEN
844    !Et sinon on.... écrit
845    IF (SIZE(field,1)/=klon) &
846   CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)           
847
848    nlev=SIZE(field,2)
849    nlev2=SIZE(field,3)
850    CALL Gather_omp(field,buffer_omp)
851!$OMP MASTER
852    CALL grid1Dto2D_mpi(buffer_omp,field4d)
853
854#ifdef CPP_XIOS
855!    IF (ok_all_xml) THEN
856     CALL xios_send_field(var%name, Field4d(:,:,1:nlev,1:nlev2))
857     IF (prt_level >= 1) WRITE(lunout,*)'xios_send_field ',var%name
858!    ENDIF
859#endif
860
861!$OMP END MASTER   
862  ENDIF ! vars_defined
863  IF (prt_level >= 9) write(lunout,*)'End histrwrite4d_cosp ',nom
864  END SUBROUTINE histwrite4d_cosp
865
866  SUBROUTINE conf_cospoutputs(nam_var,cles_var)
867!!! Lecture des noms et cles de sortie des variables dans config.def
868    !   en utilisant les routines getin de IOIPSL 
869    use ioipsl
870    USE print_control_mod, ONLY: lunout,prt_level
871
872    IMPLICIT NONE
873
874   CHARACTER(LEN=20)               :: nam_var, nnam_var
875   LOGICAL, DIMENSION(3)           :: cles_var
876
877! Lecture dans config.def ou output.def de cles_var et name_var
878    CALL getin('cles_'//nam_var,cles_var)
879    CALL getin('name_'//nam_var,nam_var)
880    IF(prt_level>10) WRITE(lunout,*)'nam_var cles_var ',nam_var,cles_var(:)
881
882  END SUBROUTINE conf_cospoutputs
883
884 END MODULE cosp_output_write_mod
Note: See TracBrowser for help on using the repository browser.