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_mpi, ONLY : ncomm, nproc, nrank, npio, wlog_mpi, prep_log_mpi,   &
                            end_log_mpi, nindex, nnum, nsize_task
USE modd_surfex_omp, ONLY : nblocktot
!
USE modn_io_offline
!
USE modd_write_surf_atm, ONLY : lfirst_write,  ncpt_write
!
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_init_index_mpi
USE modi_io_buff_clean
USE modi_pgd_orog_filter
USE modi_pgd_surf_atm
USE modi_pgd_grid_surf_atm
USE modi_write_header_fa
USE modi_write_header_mnh
USE modi_write_pgd_surf_atm_n
USE modi_init_output_nc_n
USE modi_get_size_full_n
!
USE mode_pos_surf
!
USE modn_write_surf_atm
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_get_luout
!
USE modd_off_surfex_n
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include 'mpif.h'
#endif
!
#ifndef AIX64
!$ INCLUDE 'omp_lib.h'
#endif
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
INTEGER            :: ILUOUT
INTEGER            :: ILUNAM
LOGICAL            :: GFOUND
!
 CHARACTER(LEN=28)  :: YLUOUT    ='LISTING_PGD'   ! name of the listing
 CHARACTER(LEN=100) :: YNAME 
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ISTATUS
#endif
INTEGER :: ILEVEL, INFOMPI
INTEGER            :: INW, JNW
INTEGER            :: IRET, ISIZE_FULL
DOUBLE PRECISION :: XTIME0
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!------------------------------------------------------------------------------
!
#ifdef SFX_MPI
 CALL mpi_init_thread(mpi_thread_multiple,ilevel,infompi)
#endif
!
IF (lhook) CALL dr_hook('PGD',0,zhook_handle)
!
 CALL surfex_alloc_list(1)
CSOFTWARE='PGD    '
!
#ifdef SFX_MPI
ncomm = mpi_comm_world
 CALL mpi_comm_size(ncomm,nproc,infompi)
 CALL mpi_comm_rank(ncomm,nrank,infompi)
#endif
!
!
!*    1.      Set default names and parallelized I/O
!             --------------------------------------
!
 IF (nrank>=10) THEN
  WRITE(yname,fmt='(A15,I2)') trim(yluout),nrank
ELSE
  WRITE(yname,fmt='(A15,I1)') trim(yluout),nrank
ENDIF
 cluout_lfi =  adjustl(adjustr(yluout)//'.txt')
 cluout_nc  =  adjustl(adjustr(yname)//'.txt')
 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')
!
 CALL goto_model(1)
!
!$OMP PARALLEL
!$ NBLOCKTOT = OMP_GET_NUM_THREADS()
!$OMP END PARALLEL
!
 CALL prep_log_mpi
!
 CALL wlog_mpi(' ')
!
 CALL wlog_mpi('NBLOCKTOT ',klog=nblocktot)
!
#ifdef SFX_MPI
xtime0 = mpi_wtime()
#endif
!
!*    2.      Preparation of surface physiographic fields
!             -------------------------------------------
!
 CALL init_index_mpi(ysc%DTCO,ysc%U,ysc%UG,ysc%GCP,csurf_filetype,'PGD',yalg_mpi,xio_frac)
 !
 CALL pgd_grid_surf_atm(ysc%UG, ysc%U, ysc%GCP, csurf_filetype,&
                        '                            ','      ',.false.,hdir='H')
 !
 CALL get_size_full_n(csurf_filetype, ysc%U%NDIM_FULL, ysc%U%NSIZE_FULL, isize_full)
ysc%U%NSIZE_FULL = isize_full
!
 CALL pgd_surf_atm(ysc,csurf_filetype,'                            ','      ',.false.)
!
 CALL pgd_orog_filter(ysc%U,ysc%UG,csurf_filetype)
!
!*    3.      writing of surface physiographic fields
!             ---------------------------------------
!
!* building of the header for the opening of the file in case of Arpege file
IF (nrank==npio) THEN
  IF (csurf_filetype=='FA    ') THEN
    lfanocompact = .true.
    CALL write_header_fa(ysc%GCP, ysc%UG%G%CGRID, ysc%UG%XGRID_FULL_PAR, csurf_filetype,'PGD') 
  END IF
END IF
!
ALLOCATE(ysc%DUO%CSELECT(0))
!
ldef = .true.
!
IF (csurf_filetype=="NC    ") THEN
  CALL init_output_nc_n (ysc%TM%BDD, ysc%CHE, ysc%CHN, ysc%CHU,   &
                         ysc%SM%DTS, ysc%TM%DTT, ysc%DTZ, ysc%IM, &
                         ysc%UG, ysc%U, ysc%DUO%CSELECT)
ENDIF
!
inw = 1
IF (csurf_filetype=="NC    ") inw = 2
!
lfirst_write = .true.
ncpt_write = 0
!
DO jnw = 1,inw
  !
  IF (lwrite_coord) CALL get_lonlat_n(ysc%DTCO, ysc%U, ysc%UG, ysc%DUO%CSELECT, 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(ysc, csurf_filetype)
  !
  ldef = .false.
  lfirst_write = .false.
  ncpt_write = 0
  CALL io_buff_clean
  !
ENDDO
!
!* closes the file
IF (nrank==npio) THEN
  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)
  !
ENDIF
!
 CALL surfex_deallo_list
!
IF (ALLOCATED(nindex)) DEALLOCATE(nindex)
IF (ALLOCATED(nnum)) DEALLOCATE(nnum)
IF (ALLOCATED(nsize_task)) DEALLOCATE(nsize_task)
!
 CALL end_log_mpi
!
IF (lhook) CALL dr_hook('PGD',1,zhook_handle)
!
#ifdef SFX_MPI
 CALL mpi_finalize(infompi)
#endif
!
!-------------------------------------------------------------------------------
!
END PROGRAM pgd