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 (GCP, HGRID, PGRID_PAR, 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_grid_conf_proj_n,  ONLY : grid_conf_proj_t
!
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(grid_conf_proj_t),INTENT(INOUT) :: GCP
!
 CHARACTER(LEN=*), INTENT(IN) :: HGRID
REAL, DIMENSION(:), INTENT(IN) :: PGRID_PAR
!
 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 (hgrid=="CONF PROJ ") THEN
!
  CALL get_gridtype_conf_proj(pgrid_par,zlapo,zlopo,zprpk,zbeta, &
                                zlatmin,zlonmin,ilon,ilat          )  
!
  icount=ilon*ilat
  ALLOCATE(zdx(icount))
  ALLOCATE(zdy(icount))
!
  CALL get_gridtype_conf_proj(pgrid_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) = gcp%XLONC*zrad
  zsinla(6) = gcp%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 (hgrid=="CARTESIAN ") THEN
!
  CALL abor1_sfx('WRITE_HEADER_FA: CARTESIAN NOT YET IMPLEMENTED')
!
ELSEIF (hgrid=="LONLAT REG") THEN
!
  CALL get_gridtype_lonlat_reg(pgrid_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 (hgrid=="GAUSS     ") THEN
!
  CALL get_gridtype_gauss(pgrid_par,knlati=inlati,kl=il)
!
  ALLOCATE(inlopa(inlati))
  ALLOCATE(zsinla(inlati))
  ALLOCATE(inozpa(inlati))
!
  ALLOCATE(zlat_xy(il))
!
  CALL get_gridtype_gauss(pgrid_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 (hgrid=="IGN       ") THEN
!
  CALL abor1_sfx('WRITE_HEADER_FA: IGN NOT YET IMPLEMENTED')
!
ELSEIF (hgrid=="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