write_file_isbamap.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_file_isbamap (UG, &
                                     kunit,pvar,ki)
!     ##########################
!
!!
!!    PURPOSE
!!    -------
!        
!     
!!**  METHOD
!!    ------
!
!!    EXTERNAL
!!    --------
!!
!!    none
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!      
!!    REFERENCE
!!    ---------
!!     
!!    AUTHOR
!!    ------
!!
!!      K. Chancibault  * Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      Original   25/01/2005
!!                 03/2014 (E. Artinian) manages the option CGRID='IGN'
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
!
!
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
!
USE modd_topodyn
USE modd_surf_par,        ONLY : xundef
!
USE mode_gridtype_conf_proj
USE mode_gridtype_lonlat_reg
USE mode_gridtype_ign
!
USE modi_abor1_sfx
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
TYPE(surf_atm_grid_t), INTENT(INOUT) :: ug
!
INTEGER, INTENT(IN)             :: kunit  ! file unit
REAL, DIMENSION(:), INTENT(IN)  :: pvar   ! variable to write in the file
INTEGER, INTENT(IN)             :: ki    ! Grid dimensions
!
!
!*      0.2    declarations of local variables
INTEGER                    :: jj,ji,il
INTEGER                    :: ini,ilambert
INTEGER                    :: jindex ! reference number of the pixel
REAL                       :: zout
REAL                       :: zmax,zmin
REAL, DIMENSION(KI)        :: zxi, zyi     ! natural coordinates of ISBA grid (conformal projection)
REAL, DIMENSION(KI)        :: zxn, zyn     ! isba nodes coordinates in the Lambert II coordinates - Eram rajout
REAL, DIMENSION(KI)        :: zdxi, zdyi   ! Isba grid resolution in the conformal projection
REAL, DIMENSION(KI)        :: zdx, zdy
INTEGER                    :: iimax,ijmax
REAL :: zlonmin,zlonmax,zlatmin,zlatmax
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('WRITE_FILE_ISBAMAP',0,zhook_handle)
!
!*       0.     Initialization:
!               ---------------
!
IF(ug%CGRID.EQ.'CONF PROJ') THEN
 CALL get_gridtype_conf_proj(ug%XGRID_PAR,px=zxi,py=zyi,kimax=iimax,kjmax=ijmax,pdx=zdxi)
ELSE IF(ug%CGRID.EQ.'LONLAT REG') THEN
    CALL get_gridtype_lonlat_reg(ug%XGRID_PAR,plonmin=zlonmin,plonmax=zlonmax,             &
                                 platmin=zlatmin,platmax=zlatmax,klon=iimax,klat=ijmax, &
                                 kl=il,plon=zxi,plat=zyi)
    !
    zdxi(:)=(zlonmax-zlonmin)/(iimax-1)
    zdyi(:)=(zlatmax-zlatmin)/(ijmax-1)
ELSE IF (ug%CGRID=='IGN') THEN 
  CALL get_gridtype_ign(ug%XGRID_PAR,klambert=ilambert,kl=ini,px=zxn,py=zyn,pdx=zdx,pdy=zdy)
  ini=ki
  zdxi(:)=zdx(:)
  zdyi(:)=zdy(:)
ELSE
    CALL abor1_sfx("WRITE_FILE_ISBAMAP: TYPE DE GRILLE NON GERE PAR LE CODE")
ENDIF
!
zmax = maxval(pvar)
zmin = minval(pvar)
zout = xundef
!
DO jj=1,5
  WRITE(kunit,*)
ENDDO
!
IF(ug%CGRID.EQ.'IGN') THEN

    WRITE(kunit,*) zxn(1)
    WRITE(kunit,*) zyn(1)
    WRITE(kunit,*) ini
    WRITE(kunit,*) zout
    WRITE(kunit,*) zdxi(1)
    WRITE(kunit,*) zmin
    WRITE(kunit,*) zmax
    !
    DO jj = 1,ini
      WRITE(kunit,*) pvar(jj)
    ENDDO
ELSE
    WRITE(kunit,*) zxi(1)
    WRITE(kunit,*) zyi(1)
    WRITE(kunit,*) iimax
    WRITE(kunit,*) ijmax
    WRITE(kunit,*) zout
    WRITE(kunit,*) zdxi(1)
    WRITE(kunit,*) zmin
    WRITE(kunit,*) zmax
!
    DO jj = 1,ijmax
      DO ji = 1,iimax
        jindex = (jj-1) * iimax + ji
        WRITE(kunit,*) pvar(jindex)
      ENDDO
    ENDDO
ENDIF
!
IF (lhook) CALL dr_hook('WRITE_FILE_ISBAMAP',1,zhook_handle)
!
END SUBROUTINE write_file_isbamap