cosp_output_write_mod.F90

Go to the documentation of this file.

!!!! Abderrahmane Idelkadi aout 2013 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Module pour definir (au 1er appel) et ecrire les variables dans les fichiers de sortie cosp
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   MODULE cosp_output_write_mod
  
   USE cosp_output_mod
  
   INTEGER, SAVE  :: itau_iocosp
!$OMP THREADPRIVATE(itau_iocosp)
   INTEGER, save        :: nlevout, ncolout
!$OMP THREADPRIVATE(Nlevout, Ncolout)

!  INTERFACE histwrite_cosp
!    MODULE PROCEDURE histwrite2d_cosp,histwrite3d_cosp
!  END INTERFACE

   CONTAINS

  SUBROUTINE cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, &
                               cfg, gbx, vgrid, sglidar, stlidar, isccp)

    USE ioipsl
    USE time_phylmdz_mod, ONLY: itau_phy, start_time, day_step_phy
    USE print_control_mod, ONLY: lunout,prt_level

#ifdef CPP_XIOS
    USE wxios, only: wxios_closedef
    USE xios, only: xios_update_calendar
#endif

!!! Variables d'entree
  integer               :: itap, Nlevlmdz, Ncolumns, Npoints
  real                  :: freq_COSP, dtime
  type(cosp_config)     :: cfg     ! Control outputs
  type(cosp_gridbox)    :: gbx     ! Gridbox information. Input for COSP
  type(cosp_sglidar)    :: sglidar ! Output from lidar simulator
  type(cosp_isccp)      :: isccp   ! Output from ISCCP simulator
  type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator
  type(cosp_vgrid)      :: vgrid   ! Information on vertical grid of stats

!!! Variables locales
  integer               :: icl
  logical               :: ok_sync
  integer               :: itau_wcosp
  real, dimension(Npoints,PARASOL_NREFL) :: parasolcrefl, Ncref

  nlevout = vgrid%Nlvgrid
  ncolout = ncolumns

! A refaire
       itau_wcosp = itau_phy + itap + start_time * day_step_phy
        if (prt_level >= 10) then
             WRITE(lunout,*)'itau_wcosp, itap, start_time, day_step_phy =', & 
                             itau_wcosp, itap, start_time, day_step_phy
        endif

! On le donne a  cosp_output_write_mod pour que les histwrite y aient acces:
       CALL set_itau_iocosp(itau_wcosp)
        if (prt_level >= 10) then
              WRITE(lunout,*)'itau_iocosp =',itau_iocosp
        endif

    ok_sync = .true.
    
!DO iinit=1, iinitend
! AI sept 2014 cette boucle supprimee
! On n'ecrit pas quand itap=1 (cosp)

   if (prt_level >= 10) then
         WRITE(lunout,*)'DO iinit=1, iinitend ',iinitend
   endif

!#ifdef CPP_XIOS
! !$OMP MASTER
!IF (cosp_varsdefined) THEN
!   if (prt_level >= 10) then
!         WRITE(lunout,*)'Apell xios_update_calendar cosp_varsdefined iinitend ', &
!                         cosp_varsdefined,iinitend
!   endif 
!    CALL xios_update_calendar(itau_wcosp)
!ENDIF
!  !$OMP END MASTER
!  !$OMP BARRIER
!#endif

 if (cfg%Llidar_sim) then
! Pb des valeurs indefinies, on les met a 0
! A refaire proprement
  do k = 1,nlevout
     do ip = 1,npoints
     if(stlidar%lidarcld(ip,k).eq.r_undef)then
      stlidar%lidarcld(ip,k)=cosp_fill_value
     endif
     enddo

     do ii= 1,sr_bins
      do ip = 1,npoints
       if(stlidar%cfad_sr(ip,ii,k).eq.r_undef)then
        stlidar%cfad_sr(ip,ii,k)=cosp_fill_value
       endif
      enddo
     enddo
   enddo

  do ip = 1,npoints
   do k = 1,nlevlmdz
     if(sglidar%beta_mol(ip,k).eq.r_undef)then
      sglidar%beta_mol(ip,k)=cosp_fill_value
     endif

     do ii= 1,ncolumns
       if(sglidar%beta_tot(ip,ii,k).eq.r_undef)then
        sglidar%beta_tot(ip,ii,k)=cosp_fill_value
       endif
     enddo

    enddo    !k = 1,Nlevlmdz
   enddo     !ip = 1,Npoints

   do k = 1,lidar_ncat
    do ip = 1,npoints
     if(stlidar%cldlayer(ip,k).eq.r_undef)then
      stlidar%cldlayer(ip,k)=cosp_fill_value
     endif
    enddo
   enddo

   print*,'Appel histwrite2d_cosp'
   CALL histwrite2d_cosp(o_cllcalipso,stlidar%cldlayer(:,1))
   CALL histwrite2d_cosp(o_clhcalipso,stlidar%cldlayer(:,3))
   CALL histwrite2d_cosp(o_clmcalipso,stlidar%cldlayer(:,2)) 
   CALL histwrite2d_cosp(o_cltcalipso,stlidar%cldlayer(:,4))
   CALL histwrite3d_cosp(o_clcalipso,stlidar%lidarcld,nvert)

   do icl=1,sr_bins
      CALL histwrite3d_cosp(o_cfad_lidarsr532,stlidar%cfad_sr(:,icl,:),nvert,icl)
   enddo

   CALL histwrite3d_cosp(o_parasol_refl,stlidar%parasolrefl,nvertp)

   do k=1,parasol_nrefl
    do ip=1, npoints
     if (stlidar%cldlayer(ip,4).gt.0.01) then
       parasolcrefl(ip,k)=(stlidar%parasolrefl(ip,k)-0.03*(1.-stlidar%cldlayer(ip,4)))/ &
                            stlidar%cldlayer(ip,4)
        ncref(ip,k) = 1.
     else
        parasolcrefl(ip,k)=0.
        ncref(ip,k) = 0.
     endif
    enddo
   enddo
   CALL histwrite3d_cosp(o_ncrefl,ncref,nvertp)
   CALL histwrite3d_cosp(o_parasol_crefl,parasolcrefl,nvertp)

   do icl=1,ncolumns 
      CALL histwrite3d_cosp(o_atb532,sglidar%beta_tot(:,icl,:),nvertmcosp,icl)
   enddo
   CALL histwrite3d_cosp(o_beta_mol532,sglidar%beta_mol,nvertmcosp) 
 endif !Lidar

 if (cfg%Lisccp_sim) then

! Traitement des valeurs indefinies
   do ip = 1,npoints
    if(isccp%totalcldarea(ip).eq.-1.e+30)then
      isccp%totalcldarea(ip)=cosp_fill_value
    endif
    if(isccp%meanptop(ip).eq.-1.e+30)then
      isccp%meanptop(ip)=cosp_fill_value
    endif
    if(isccp%meantaucld(ip).eq.-1.e+30)then
      isccp%meantaucld(ip)=cosp_fill_value
    endif
    if(isccp%meanalbedocld(ip).eq.-1.e+30)then
      isccp%meanalbedocld(ip)=cosp_fill_value
    endif
    if(isccp%meantb(ip).eq.-1.e+30)then
      isccp%meantb(ip)=cosp_fill_value
    endif
    if(isccp%meantbclr(ip).eq.-1.e+30)then
      isccp%meantbclr(ip)=cosp_fill_value
    endif

    do k=1,7
     do ii=1,7
     if(isccp%fq_isccp(ip,ii,k).eq.-1.e+30)then
      isccp%fq_isccp(ip,ii,k)=cosp_fill_value
     endif
     enddo
    enddo

    do ii=1,ncolumns
     if(isccp%boxtau(ip,ii).eq.-1.e+30)then
       isccp%boxtau(ip,ii)=cosp_fill_value
     endif
    enddo

    do ii=1,ncolumns
     if(isccp%boxptop(ip,ii).eq.-1.e+30)then
       isccp%boxptop(ip,ii)=cosp_fill_value
     endif
    enddo
   enddo

   CALL histwrite2d_cosp(o_sunlit,gbx%sunlit)
   do icl=1,7
   CALL histwrite3d_cosp(o_clisccp2,isccp%fq_isccp(:,icl,:),nvertisccp,icl) 
   enddo
   CALL histwrite3d_cosp(o_boxtauisccp,isccp%boxtau,nvertcol)
   CALL histwrite3d_cosp(o_boxptopisccp,isccp%boxptop,nvertcol) 
   CALL histwrite2d_cosp(o_tclisccp,isccp%totalcldarea) 
   CALL histwrite2d_cosp(o_ctpisccp,isccp%meanptop) 
   CALL histwrite2d_cosp(o_tauisccp,isccp%meantaucld) 
   CALL histwrite2d_cosp(o_albisccp,isccp%meanalbedocld) 
   CALL histwrite2d_cosp(o_meantbisccp,isccp%meantb) 
   CALL histwrite2d_cosp(o_meantbclrisccp,isccp%meantbclr)
 endif ! Isccp

 IF(.NOT.cosp_varsdefined) THEN
!$OMP MASTER
#ifndef CPP_IOIPSL_NO_OUTPUT
            DO iff=1,3
                IF (cosp_outfilekeys(iff)) THEN
                  CALL histend(cosp_nidfiles(iff))
                ENDIF ! cosp_outfilekeys
            ENDDO !  iff
#endif
! Fermeture dans phys_output_write
!#ifdef CPP_XIOS
            !On finalise l'initialisation:
            !CALL wxios_closedef()
!#endif

!$OMP END MASTER
!$OMP BARRIER
            cosp_varsdefined = .true.
 END IF

    IF(cosp_varsdefined) THEN
! On synchronise les fichiers pour IOIPSL
#ifndef CPP_IOIPSL_NO_OUTPUT 
!$OMP MASTER
     DO iff=1,3
         IF (ok_sync .AND. cosp_outfilekeys(iff)) THEN
             CALL histsync(cosp_nidfiles(iff))
         ENDIF
     END DO
!$OMP END MASTER
#endif
    ENDIF  !cosp_varsdefined

    END SUBROUTINE cosp_output_write

! ug Routine pour definir itau_iocosp depuis cosp_output_write_mod:
  SUBROUTINE set_itau_iocosp(ito)
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: ito
      itau_iocosp = ito
  END SUBROUTINE

  SUBROUTINE histdef2d_cosp (iff,var)

    USE ioipsl
    USE dimphy
    use iophy
    USE mod_phys_lmdz_para
    USE mod_grid_phy_lmdz, ONLY: nbp_lon
    USE print_control_mod, ONLY: lunout,prt_level
#ifdef CPP_XIOS
  USE wxios
#endif

    IMPLICIT NONE

    include "clesphys.h"

    INTEGER                          :: iff
    TYPE(ctrl_outcosp)               :: var

    REAL zstophym
    CHARACTER(LEN=20) :: typeecrit

    ! ug On récupère le type écrit de la structure:
    !       Assez moche, Ã|  refaire si meilleure méthode...
    IF (index(var%cosp_typeecrit(iff), "once") > 0) THEN
       typeecrit = 'once'
    ELSE IF(index(var%cosp_typeecrit(iff), "t_min") > 0) THEN
       typeecrit = 't_min(X)'
    ELSE IF(index(var%cosp_typeecrit(iff), "t_max") > 0) THEN
       typeecrit = 't_max(X)'
    ELSE IF(index(var%cosp_typeecrit(iff), "inst") > 0) THEN
       typeecrit = 'inst(X)'
    ELSE
       typeecrit = cosp_outfiletypes(iff)
    ENDIF

    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
       zstophym=zoutm_cosp(iff)
    ELSE
       zstophym=zdtimemoy_cosp
    ENDIF

#ifdef CPP_XIOS
     IF (.not. ok_all_xml) then
       IF ( var%cles(iff) ) THEN
         if (prt_level >= 10) then
              WRITE(lunout,*)'Appel wxios_add_field_to_file var%name =',var%name 
         endif
        CALL wxios_add_field_to_file(var%name, 2, cosp_nidfiles(iff), cosp_outfilenames(iff), &
                                     var%description, var%unit, 1, typeecrit)
       ENDIF
     ENDIF
#endif

#ifndef CPP_IOIPSL_NO_OUTPUT 
       IF ( var%cles(iff) ) THEN
          CALL histdef (cosp_nidfiles(iff), var%name, var%description, var%unit, &
               nbp_lon,jj_nb,nhoricosp(iff), 1,1,1, -99, 32, &
               typeecrit, zstophym,zoutm_cosp(iff))
       ENDIF
#endif

  END SUBROUTINE histdef2d_cosp

 SUBROUTINE histdef3d_cosp (iff,var,nvertsave,ncols)
    USE ioipsl
    USE dimphy
    use iophy
    USE mod_phys_lmdz_para
    USE mod_grid_phy_lmdz, ONLY: nbp_lon
    USE print_control_mod, ONLY: lunout,prt_level

#ifdef CPP_XIOS
  USE wxios
#endif


    IMPLICIT NONE

    include "clesphys.h"

    INTEGER                        :: iff, klevs
    INTEGER, INTENT(IN), OPTIONAL  :: ncols ! ug RUSTINE POUR LES variables 4D
    INTEGER, INTENT(IN)           :: nvertsave
    TYPE(ctrl_outcosp)             :: var

    REAL zstophym
    CHARACTER(LEN=20) :: typeecrit, nomi
    CHARACTER(LEN=20) :: nom
    character(len=2) :: str2
    CHARACTER(len=20) :: nam_axvert

! Axe vertical
      IF (nvertsave.eq.nvertp(iff)) THEN
          klevs=parasol_nrefl
          nam_axvert="sza"
      ELSE IF (nvertsave.eq.nvertisccp(iff)) THEN
          klevs=7
          nam_axvert="pressure2"
      ELSE IF (nvertsave.eq.nvertcol(iff)) THEN
          klevs=ncolout
          nam_axvert="column"
      ELSE
           klevs=nlevout
           nam_axvert="presnivs"
      ENDIF

! ug RUSTINE POUR LES Champs 4D
      IF (PRESENT(ncols)) THEN
               write(str2,'(i2.2)')ncols
               nomi=var%name
               nom="c"//str2//"_"//nomi
      ELSE
               nom=var%name
      END IF

    ! ug On récupère le type écrit de la structure:
    !       Assez moche, Ã|  refaire si meilleure méthode...
    IF (index(var%cosp_typeecrit(iff), "once") > 0) THEN
       typeecrit = 'once'
    ELSE IF(index(var%cosp_typeecrit(iff), "t_min") > 0) THEN
       typeecrit = 't_min(X)'
    ELSE IF(index(var%cosp_typeecrit(iff), "t_max") > 0) THEN
       typeecrit = 't_max(X)'
    ELSE IF(index(var%cosp_typeecrit(iff), "inst") > 0) THEN
       typeecrit = 'inst(X)'
    ELSE
       typeecrit = cosp_outfiletypes(iff)
    ENDIF

    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
       zstophym=zoutm_cosp(iff)
    ELSE
       zstophym=zdtimemoy_cosp
    ENDIF

#ifdef CPP_XIOS
      IF (.not. ok_all_xml) then
        IF ( var%cles(iff) ) THEN
          if (prt_level >= 10) then
              WRITE(lunout,*)'Appel wxios_add_field_to_file 3d nom variable nam_axvert = ',nom, nam_axvert 
          endif
          CALL wxios_add_field_to_file(nom, 3, cosp_nidfiles(iff), cosp_outfilenames(iff), &
                                       var%description, var%unit, 1, typeecrit, nam_axvert)
        ENDIF
      ENDIF
#endif

#ifndef CPP_IOIPSL_NO_OUTPUT
       IF ( var%cles(iff) ) THEN
          CALL histdef (cosp_nidfiles(iff), nom, var%description, var%unit, &
               nbp_lon, jj_nb, nhoricosp(iff), klevs, 1, &
               klevs, nvertsave, 32, typeecrit, &
               zstophym, zoutm_cosp(iff))
       ENDIF
#endif

  END SUBROUTINE histdef3d_cosp

 SUBROUTINE histwrite2d_cosp(var,field)
  USE dimphy
  USE mod_phys_lmdz_para
  USE ioipsl
  use iophy
  USE mod_grid_phy_lmdz, ONLY: nbp_lon
  USE print_control_mod, ONLY: lunout,prt_level

#ifdef CPP_XIOS
  USE xios, only: xios_send_field
#endif

  IMPLICIT NONE
  include 'clesphys.h'

    TYPE(ctrl_outcosp), INTENT(IN) :: var
    REAL, DIMENSION(:), INTENT(IN) :: field

    INTEGER :: iff

    REAL,DIMENSION(klon_mpi) :: buffer_omp
    INTEGER, allocatable, DIMENSION(:) :: index2d
    REAL :: Field2d(nbp_lon,jj_nb)
    CHARACTER(LEN=20) ::  nomi, nom
    character(len=2) :: str2
    LOGICAL, SAVE  :: firstx
!$OMP THREADPRIVATE(firstx)

    IF (prt_level >= 9) WRITE(lunout,*)'Begin histrwrite2d ',var%name

  ! On regarde si on est dans la phase de définition ou d'écriture:
  IF(.NOT.cosp_varsdefined) THEN
!$OMP MASTER
      !Si phase de définition.... on définit
      CALL conf_cospoutputs(var%name,var%cles)
      DO iff=1, 3
         IF (cosp_outfilekeys(iff)) THEN
            CALL histdef2d_cosp(iff, var)
         ENDIF
      ENDDO
!$OMP END MASTER
  ELSE
    !Et sinon on.... écrit
    IF (SIZE(field)/=klon) &
  CALL abort_physic('iophy::histwrite2d_cosp','Field first DIMENSION not equal to klon',1) 

    CALL gather_omp(field,buffer_omp)
!$OMP MASTER
    CALL grid1dto2d_mpi(buffer_omp,field2d)

! La boucle sur les fichiers:
      firstx=.true.
      DO iff=1, 3
           IF (var%cles(iff) .AND. cosp_outfilekeys(iff)) THEN
                ALLOCATE(index2d(nbp_lon*jj_nb))
#ifndef CPP_IOIPSL_NO_OUTPUT
        CALL histwrite(cosp_nidfiles(iff),var%name,itau_iocosp,field2d,nbp_lon*jj_nb,index2d) 
#endif
                deallocate(index2d)
#ifdef CPP_XIOS
              IF (.not. ok_all_xml) then
                 if (firstx) then
                  if (prt_level >= 10) then
                    WRITE(lunout,*)'xios_send_field variable ',var%name
                  endif
                  CALL xios_send_field(var%name, field2d)
                   firstx=.false.
                 endif
              ENDIF
#endif
           ENDIF
      ENDDO 

#ifdef CPP_XIOS
      IF (ok_all_xml) THEN
        if (prt_level >= 10) then
              WRITE(lunout,*)'xios_send_field variable ',var%name
        endif
       CALL xios_send_field(var%name, field2d)
      ENDIF
#endif

!$OMP END MASTER   
  ENDIF ! vars_defined
  IF (prt_level >= 9) WRITE(lunout,*)'End histrwrite2d_cosp ',var%name
  END SUBROUTINE histwrite2d_cosp

! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
! AI sept 2013
  SUBROUTINE histwrite3d_cosp(var, field, nverts, ncols)
  USE dimphy
  USE mod_phys_lmdz_para
  USE ioipsl
  use iophy
  USE mod_grid_phy_lmdz, ONLY: nbp_lon
  USE print_control_mod, ONLY: lunout,prt_level

#ifdef CPP_XIOS
  USE xios, only: xios_send_field
#endif


  IMPLICIT NONE
  include 'clesphys.h'

    TYPE(ctrl_outcosp), INTENT(IN)    :: var
    REAL, DIMENSION(:,:), INTENT(IN)  :: field ! --> field(klon,:)
    INTEGER, INTENT(IN), OPTIONAL     :: ncols ! ug RUSTINE POUR LES Champs 4D.....
    INTEGER, DIMENSION(3), INTENT(IN) :: nverts

    INTEGER :: iff, k

    REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
    REAL :: Field3d(nbp_lon,jj_nb,size(field,2))
    INTEGER :: ip, n, nlev
    INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
    CHARACTER(LEN=20) ::  nomi, nom
    character(len=2) :: str2
    LOGICAL, SAVE  :: firstx
!$OMP THREADPRIVATE(firstx)

  IF (prt_level >= 9) write(lunout,*)'Begin histrwrite3d ',var%name

! ug RUSTINE POUR LES STD LEVS.....
      IF (PRESENT(ncols)) THEN
              write(str2,'(i2.2)')ncols
              nomi=var%name
              nom="c"//str2//"_"//nomi
      ELSE
               nom=var%name
      END IF
  ! On regarde si on est dans la phase de définition ou d'écriture:
  IF(.NOT.cosp_varsdefined) THEN
      !Si phase de définition.... on définit
!$OMP MASTER
      CALL conf_cospoutputs(var%name,var%cles)
      DO iff=1, 3
        IF (cosp_outfilekeys(iff)) THEN
          CALL histdef3d_cosp(iff, var, nverts(iff), ncols)
        ENDIF
      ENDDO
!$OMP END MASTER
  ELSE
    !Et sinon on.... écrit
    IF (SIZE(field,1)/=klon) &
   CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)                                  
    nlev=SIZE(field,2)


    CALL gather_omp(field,buffer_omp)
!$OMP MASTER
    CALL grid1dto2d_mpi(buffer_omp,field3d)

! BOUCLE SUR LES FICHIERS
     firstx=.true.
     DO iff=1, 3
        IF (var%cles(iff) .AND. cosp_outfilekeys(iff)) THEN
           ALLOCATE(index3d(nbp_lon*jj_nb*nlev))
#ifndef CPP_IOIPSL_NO_OUTPUT
    CALL histwrite(cosp_nidfiles(iff),nom,itau_iocosp,field3d,nbp_lon*jj_nb*nlev,index3d) 
#endif

#ifdef CPP_XIOS
          IF (.not. ok_all_xml) then
           IF (firstx) THEN
               CALL xios_send_field(nom, field3d(:,:,1:nlev))
               IF (prt_level >= 9) WRITE(lunout,*)'xios_send_field ',var%name
               firstx=.false.
           ENDIF
          ENDIF
#endif
         deallocate(index3d)
        ENDIF
      ENDDO
#ifdef CPP_XIOS
    IF (ok_all_xml) THEN
     CALL xios_send_field(nom, field3d(:,:,1:nlev))
     IF (prt_level >= 9) WRITE(lunout,*)'xios_send_field ',var%name
    ENDIF
#endif

!$OMP END MASTER   
  ENDIF ! vars_defined
  IF (prt_level >= 9) write(lunout,*)'End histrwrite3d_cosp ',nom
  END SUBROUTINE histwrite3d_cosp

  SUBROUTINE conf_cospoutputs(nam_var,cles_var)
!!! Lecture des noms et cles de sortie des variables dans config.def
    !   en utilisant les routines getin de IOIPSL  
    use ioipsl
    USE print_control_mod, ONLY: lunout,prt_level

    IMPLICIT NONE

   CHARACTER(LEN=20)               :: nam_var, nnam_var
   LOGICAL, DIMENSION(3)           :: cles_var

! Lecture dans config.def ou output.def de cles_var et name_var
    CALL getin('cles_'//nam_var,cles_var)
    CALL getin('name_'//nam_var,nam_var)
    IF(prt_level>10) WRITE(lunout,*)'nam_var cles_var ',nam_var,cles_var(:)

  END SUBROUTINE conf_cospoutputs

 END MODULE cosp_output_write_mod