write_header_fa.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.
!
!#############################################
SUBROUTINE write_header_fa (UG, &
                            cfiletype,hwrite)
!#############################################
!
!!    PURPOSE
!!    -------
!!    Create and write a header for an ARPEGE FA file
!!
!!    METHOD
!!    ------
!!   
!!    EXTERNAL
!!    --------
!!                           
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!      A. Voldoire          Meteo-France
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    08/2007
!!         F. Taillefer 06/2008 : add Gauss and Conf Proj cases
!!         B. Decharme  01/2009 : FA can be used only if NDIM_FULL >=289 in LATLON
!!         A. Alias     10/2010 : FA header modified
!!         R. El Khatib 30-Mar-2012 fanmsg with 2 arguments
!!
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
!
!
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
!
USE modd_grid_conf_proj,  ONLY : xlatc, xlonc
!
USE modd_io_surf_fa
!
USE modd_csts,  ONLY : xpi 
!
USE mode_gridtype_conf_proj
USE mode_gridtype_lonlat_reg
USE mode_gridtype_gauss
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
USE modi_io_buff_clean
!
USE modi_get_luout
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
TYPE(surf_atm_grid_t), INTENT(INOUT) :: ug
!
 CHARACTER(LEN=3),    INTENT(IN)  :: hwrite       ! 'PGD' : only physiographic fields are written
 CHARACTER(LEN=6),    INTENT(IN)  :: cfiletype    ! 'FA' could also be 'LFI' in future developments
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
INTEGER :: il
INTEGER :: ilon
INTEGER :: ilat
!
REAL :: zlonmin
REAL :: zlonmax
REAL :: zlatmin
REAL :: zlatmax
!
REAL :: zslapo
REAL :: zclopo
REAL :: zslopo
REAL :: zcodil
REAL :: zprpk
REAL :: zbeta
!
REAL :: zlapo
REAL :: zlopo
!
REAL :: zrad
!
REAL, DIMENSION(:), ALLOCATABLE :: zsinla, zahybr, zbhybr
!
REAL, DIMENSION(:), ALLOCATABLE :: zlat_xy, zdx, zdy
!
REAL, DIMENSION(0:1), PARAMETER :: zniva = (/0.,0./)
!
REAL, DIMENSION(0:1), PARAMETER :: znivb = (/0.,1./)
!
REAL, PARAMETER :: zrefer = 101325.
!      
INTEGER, DIMENSION(11) :: idate
INTEGER, DIMENSION(:), ALLOCATABLE :: inlopa, inozpa
INTEGER :: ityptr
INTEGER :: inb ! number of articles in the file
INTEGER :: iret
INTEGER :: itronc
INTEGER :: inlati
INTEGER :: inxlon
INTEGER :: iwork
INTEGER :: icount
INTEGER :: jlat
!
INTEGER :: iluout
REAL(KIND=JPRB) :: zhook_handle
!
!----------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('WRITE_HEADER_FA',0,zhook_handle)
!
#ifdef SFX_FA
!
 CALL io_buff_clean
!
zrad=xpi/180.0
!
zslapo=0.0
zclopo=0.0
zslopo=0.0
zcodil=0.0
!
IF (ug%CGRID=="CONF PROJ ") THEN
!
  CALL get_gridtype_conf_proj(ug%XGRID_PAR,zlapo,zlopo,zprpk,zbeta, &
                                zlatmin,zlonmin,ilon,ilat          )  
!
  icount=ilon*ilat
  ALLOCATE(zdx(icount))
  ALLOCATE(zdy(icount))
!
  CALL get_gridtype_conf_proj(ug%XGRID_PAR,pdx=zdx,pdy=zdy)
!
  ALLOCATE(zsinla(18))
  ALLOCATE(inlopa(8))
  ALLOCATE(inozpa((1+ilat)/2))
!
  zsinla(:)=0.0
  inlopa(:)=0
  inozpa(:)=0
!
  zsinla(1) = -1.0
  zsinla(2) = zprpk
  zsinla(3) = zlopo*zrad
  zsinla(4) = zlapo*zrad
  zsinla(5) = xlonc*zrad
  zsinla(6) = xlatc*zrad  
  zsinla(7) = zdx(1)
  zsinla(8) = zdy(1)
  zsinla(13) = 0.0
  zsinla(14) = 0.0
!
  inlopa(1) = 10
  inlopa(2) = 1
  inlopa(3) = 1
  inlopa(4) = ilon
  inlopa(5) = 1
  inlopa(6) = ilat
  inlopa(7) = 8
  inlopa(8) = 8
!
  ityptr = -int(REAL(ilon-1)/2.)
  itronc = int(REAL(ilat-1)/2.)
!
  inlati = ilat
  inxlon = ilon
!
ELSEIF (ug%CGRID=="CARTESIAN ") THEN
!
  CALL abor1_sfx('WRITE_HEADER_FA: CARTESIAN NOT YET IMPLEMENTED')
!
ELSEIF (ug%CGRID=="LONLAT REG") THEN
!
  CALL get_gridtype_lonlat_reg(ug%XGRID_PAR,zlonmin,zlonmax, &
                                 zlatmin,zlatmax,ilon,ilat  )  
!
  CALL get_luout(cfiletype,iluout)
  il=ilon*ilat
  IF(il<289)THEN
    WRITE(iluout,*)' When Fa is used, NDIM_FULL must be >= 289, here NDIM_FULL = ',il
    CALL abor1_sfx(' WRITE_HEADER_FA: LONLAT REG, With Fa, NDIM_FULL must be >= 289')
  ENDIF
!
  ALLOCATE(zsinla(18))
  ALLOCATE(inlopa(8))
  ALLOCATE(inozpa((1+ilat)/2))
!
  itronc= min(int((REAL(ilat-2)/2.0)),21)
  ityptr=-min(int((REAL(ilon-2)/2.0)),21)
  inlati=ilat
  inxlon=ilon
!
  zsinla(:)=0.
  inlopa(:)=0
  inozpa(:)=0
!
  zsinla(1) =-1.
  zsinla(2) =-9.
  zsinla(5) =(zlonmin+(zlonmax-zlonmin)/2.)*zrad
  zsinla(6) =(zlatmin+(zlatmax-zlatmin)/2.)*zrad
  zsinla(7) =((zlonmax-zlonmin)/REAL(ilon))*zrad
  zsinla(8) =((zlatmax-zlatmin)/REAL(ilat))*zrad
  zsinla(9) =(zlonmax-zlonmin)*zrad
  zsinla(10)=(zlatmax-zlatmin)*zrad
  zsinla(13)=zlonmin*zrad
  zsinla(14)=zlatmin*zrad
  zsinla(15)=zlonmax*zrad
  zsinla(16)=zlatmax*zrad
!
  inlopa(1) = 10
  inlopa(2) = -1
  inlopa(3) = 1
  inlopa(4) = ilon
  inlopa(5) = 1
  inlopa(6) = ilat
  inlopa(7) = 8
  inlopa(8) = 8
!
ELSEIF (ug%CGRID=="GAUSS     ") THEN
!
  CALL get_gridtype_gauss(ug%XGRID_PAR,knlati=inlati,kl=il)
!
  ALLOCATE(inlopa(inlati))
  ALLOCATE(zsinla(inlati))
  ALLOCATE(inozpa(inlati))
!
  ALLOCATE(zlat_xy(il))
!
  CALL get_gridtype_gauss(ug%XGRID_PAR,plapo=zlapo,plopo=zlopo,          &
                            pcodil=zcodil,knlopa=inlopa,plat_xy=zlat_xy )  
!
! voir plus tard si ce parametre n'est pas deja dans un module !
  IF (zlapo>89.99 .AND. abs(zlopo)<0.00001) THEN
    ityptr=1
  ELSE
    ityptr=2
  ENDIF
!
  zslapo=sin(zlapo*zrad)
  zclopo=cos(zlopo*zrad)
  zslopo=sin(zlopo*zrad)
!
  iwork = int(REAL(inlati)/2.0)
  inxlon=inlopa(iwork)
!
  IF (ityptr==1) THEN
    itronc=int(REAL(inxlon-1)/2.)
  ELSE
    itronc=int(REAL(inxlon-3)/2.)
  ENDIF
!
  inozpa(:)=0
!
  icount=1
  DO jlat = 1,inlati
    zsinla(jlat)=sin(zlat_xy(icount)*zrad)
    icount=icount+inlopa(jlat)
  ENDDO
!
  DEALLOCATE(zlat_xy)
!
ELSEIF (ug%CGRID=="IGN       ") THEN
!
  CALL abor1_sfx('WRITE_HEADER_FA: IGN NOT YET IMPLEMENTED')
!
ELSEIF (ug%CGRID=="LONLATVAL ") THEN
!
  CALL abor1_sfx('WRITE_HEADER_FA: LONLATVAL NOT YET IMPLEMENTED')
!
END IF
!
ALLOCATE(zahybr(0:1))
ALLOCATE(zbhybr(0:1))
zahybr(0:1)=zniva(0:1)
zbhybr(0:1)=znivb(0:1)
!
! Reduce verbosity (in case it is not already done)
 CALL fanmsg(0,nluout)
 CALL facade(cdnomc,ityptr,zslapo,zclopo,zslopo,zcodil,itronc,inlati,inxlon, &
              inlopa,inozpa,zsinla,1,zrefer,zahybr,zbhybr,.true.)  
!
 CALL faitou(iret,nunit_fa,.true.,cfileout_fa,'UNKNOWN', &
              .true.,.false.,iverbfa,0,inb,cdnomc)  
!
idate(:)=0
idate(1)=1992
idate(2)=1
idate(3)=1
idate(6)=1
 CALL fandar(iret,nunit_fa,idate)
!
DEALLOCATE(zsinla)
DEALLOCATE(inlopa)
DEALLOCATE(inozpa)
!
DEALLOCATE(zahybr)
DEALLOCATE(zbhybr)
!
#endif
!
IF (lhook) CALL dr_hook('WRITE_HEADER_FA',1,zhook_handle)
!
END SUBROUTINE write_header_fa