pgd.F90

Go to the documentation of this file.

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
!SFX_LIC for details. version 1.
!     ###########
      PROGRAM pgd
!     ###########
!!
!!    PURPOSE
!!    -------
!!   This program prepares the physiographic data fields.
!!
!!    METHOD
!!    ------
!!   
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    F. Mereyde                  Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original     21/07/95
!!    Modification 26/07/95       Treatment of orography and subgrid-scale
!!                                orography roughness length (V. Masson)
!!    Modification 22/05/96       Variable CSTORAGE_TYPE (V. Masson)
!!    Modification 25/05/96       Modification of splines, correction on z0rel
!!                                and set limits for some surface varaibles
!!    Modification 12/06/96       Treatment of a rare case for ZPGDZ0EFF (Masson)
!!    Modification 22/11/96       removes the filtering. It will have to be 
!!                                performed in ADVANCED_PREP_PGD (Masson)
!!    Modification 15/03/99       **** MAJOR MODIFICATION **** (Masson)
!!                                PGD fields are now defined from the cover
!!                                type fractions in the grid meshes
!!                                User can still include its own data, and
!!                                even additional (dummy) fields
!!    Modificatio 06/00           patch approach, for vegetation related variable (Solmon/Masson)
!                                  averaging is performed on subclass(=patch) of nature
!!                08/03/01        add chemical emission treatment (D.Gazen)
!!    Modification 15/10/01       allow namelists in different orders (I.Mallet)
!!    Modification    07/11       new routine write_pgd_surf_atmn.F90 for writing PGD field (B.Decharme)
!!                                flag_update now in write_pgd_surf_atmn.F90 (B.Decharme)
!!
!!
!!                   ################################
!!    13/10/03       EXTERNALIZED VERSION (V. Masson)
!!                   ################################
!!
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
USE modd_surfex_omp, ONLY : nwork, nwork2, xwork, xwork2, xwork3, &
                            nwork_full, nwork2_full, xwork_full, xwork2_full
!
USE modd_io_surf_asc
USE modd_io_surf_fa
USE modd_io_surf_lfi
USE modd_io_surf_nc
USE modd_surf_conf
USE modi_open_namelist
USE modi_close_namelist
!      
USE modi_get_lonlat_n
!
USE modi_io_buff_clean
USE modi_pgd_orog_filter
USE modi_pgd_surf_atm
USE modi_pgd_grid_surf_atm
USE modi_split_grid
USE modi_write_header_fa
USE modi_write_header_mnh
USE modi_write_pgd_surf_atm_n
USE modi_init_output_nc_n
!
USE mode_pos_surf
!
USE modn_io_offline
USE modn_write_surf_atm
!
USE modd_io_surf_fa, ONLY : lfanocompact
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_get_luout
!
USE modd_off_surfex_n
!
IMPLICIT NONE
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
INTEGER            :: iluout
INTEGER            :: ilunam
LOGICAL            :: gfound
!
 CHARACTER(LEN=28)  :: yluout    ='LISTING_PGD'   ! name of the listing
!
INTEGER            :: inw, jnw
INTEGER            :: iret      
REAL(KIND=JPRB) :: zhook_handle
!
!------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('PGD',0,zhook_handle)
!
 CALL surfex_alloc_list(1)
 csoftware='PGD    '
 CALL goto_model(1)
!
!*    1.      Set default names and parallelized I/O
!             --------------------------------------
!
 CALL get_luout('ASCII ',iluout)
 cluout_lfi =  adjustl(adjustr(yluout)//'.txt')
OPEN(unit=iluout,file=adjustl(adjustr(yluout)//'.txt'),form='FORMATTED',action='WRITE')
!
!     1.3     output file name read in namelist
!             ---------------------------------
 CALL open_namelist('ASCII ',ilunam,cnamelist)
 CALL posnam(ilunam,'NAM_IO_OFFLINE',gfound)
IF (gfound) READ (unit=ilunam,nml=nam_io_offline)
 CALL posnam(ilunam,'NAM_WRITE_SURF_ATM',gfound)
IF (gfound) READ (unit=ilunam,nml=nam_write_surf_atm)
 CALL close_namelist('ASCII ',ilunam)
!
 cfileout     = adjustl(adjustr(cpgdfile)//'.txt')      ! output of PGD program
 cfileout_fa  = adjustl(adjustr(cpgdfile)//'.fa')
 cfileout_lfi = cpgdfile
 cfileout_nc  = adjustl(adjustr(cpgdfile)//'.nc')
!
!*    2.      Preparation of surface physiographic fields
!             -------------------------------------------
!
 CALL pgd_grid_surf_atm(ysurf_cur%UG, ysurf_cur%U,&
                csurf_filetype,'                            ','      ',.false.)
!
 CALL split_grid(ysurf_cur%UG, ysurf_cur%U,&
                 'OFFLIN')
!
 CALL pgd_surf_atm(ysurf_cur,&
                   csurf_filetype,'                            ','      ',.false.)
!
 CALL pgd_orog_filter(ysurf_cur%U,&
                      csurf_filetype)
!
!*    3.      writing of surface physiographic fields
!             ---------------------------------------
!
!* building of the header for the opening of the file in case of Arpege file
IF (csurf_filetype=='FA    ') THEN
  lfanocompact = .true.
  CALL write_header_fa(ysurf_cur%UG, &
                       csurf_filetype,'PGD') 
END IF
!
ldef = .true.
!
IF (csurf_filetype=="NC    ") THEN
  CALL init_output_nc_n(ysurf_cur%TM%BDD, ysurf_cur%CHE, ysurf_cur%CHN, ysurf_cur%CHU, &
                         ysurf_cur%SM%DTS, ysurf_cur%TM%DTT, ysurf_cur%DTZ, ysurf_cur%IM%I, &
                         ysurf_cur%UG, ysurf_cur%U, ysurf_cur%DGU)
ENDIF
!
inw = 1
IF (csurf_filetype=="NC    ") inw = 2
!
DO jnw = 1,inw
  !
  IF (lwrite_coord) CALL get_lonlat_n(ysurf_cur, &
                                      csurf_filetype)
  !
  !* writing of the fields
 CALL io_buff_clean
  
  ! FLAG_UPDATE now in WRITE_PGD_SURF_ATM_n
  CALL write_pgd_surf_atm_n(ysurf_cur, &
                            csurf_filetype)
  !
  ldef = .false.
  CALL io_buff_clean  
  !
ENDDO
!
!* closes the file
IF (csurf_filetype=='FA    ') THEN
#ifdef SFX_FA
  CALL fairme(iret,nunit_fa,'UNKNOWN')
#endif
END IF
!
!* add informations in the file
IF (csurf_filetype=='LFI   ' .AND. lmnh_compatible) CALL write_header_mnh
!
!*    3.     Close parallelized I/O
!            ----------------------
!
WRITE(iluout,*) ' '
WRITE(iluout,*) '    ----------------------'
WRITE(iluout,*) '    | PGD ENDS CORRECTLY |'
WRITE(iluout,*) '    ----------------------'
!
WRITE(*,*) ' '
WRITE(*,*) '    ----------------------'
WRITE(*,*) '    | PGD ENDS CORRECTLY |'
WRITE(*,*) '    ----------------------'
      !
 CLOSE(iluout)
 CALL surfex_deallo_list
!
IF (ASSOCIATED(nwork)) DEALLOCATE(nwork)
IF (ASSOCIATED(xwork)) DEALLOCATE(xwork)
IF (ASSOCIATED(nwork2)) DEALLOCATE(nwork2)
IF (ASSOCIATED(xwork2)) DEALLOCATE(xwork2)
IF (ASSOCIATED(xwork3)) DEALLOCATE(xwork3)
IF (ASSOCIATED(nwork_full)) DEALLOCATE(nwork_full)
IF (ASSOCIATED(xwork_full)) DEALLOCATE(xwork_full)
IF (ASSOCIATED(nwork2_full)) DEALLOCATE(nwork2_full)
IF (ASSOCIATED(xwork2_full)) DEALLOCATE(xwork2_full)
!
IF (lhook) CALL dr_hook('PGD',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END PROGRAM pgd