faccpl.F90

Go to the documentation of this file.

SUBROUTINE faccpl_fort                                              &
&                     (fa,  krep,   krang,  cdpref, knivau, cdsuff, &
&                      pchamp, ldcosp, kvalco, klongd)
USE fa_mod, ONLY : fa_com, jpniil, fafich, facadr
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
USE grib_api_interface
USE grib_api
IMPLICIT NONE
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KREP, KRANG, KNIVAU, KLONGD, ILONGD
!
INTEGER (KIND=JPLIKB) KVALCO(*)
REAL (KIND=JPDBLR) PCHAMP(*)
!
LOGICAL LDCOSP
!
CHARACTER CDPREF*(*), CDSUFF*(*)
!
#include "fagribex.h"
!
REAL (KIND=JPDBLR), ALLOCATABLE :: ZCHAMP (:)
INTEGER (KIND=JPLIKB) IRANGC
INTEGER (KIND=JPLIKB) INLATI, INXLON, IDLUXG, IDGUXG, IDZONL, IDZONG
INTEGER (KIND=JPLIKB) ILCHAM
INTEGER (KIND=JPLIKB) ICPLSIZE
INTEGER (KIND=JPLIKB) ILAT, ILON
INTEGER (KIND=JPLIKB) INIMES, INUMER
INTEGER (KIND=JPLIKB) ILATMIN, ILATMAX, ILONMIN, ILONMAX
!
CHARACTER(LEN=FA%JPLMES) CLMESS
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL :: LLFATA
!

type(facadr), POINTER :: ylcadr
type(fafich), POINTER :: ylfich
CHARACTER, ALLOCATABLE :: CLGRIB (:)
INTEGER (KIND=JPKSIZE_T) :: ILGRIB
INTEGER (KIND=JPLIKM) :: IRET, IGRIBH
INTEGER (KIND=JPLIKB) :: IFGRIB, INBITS, IBFPDG
REAL (KIND=JPDBLR)    :: ZUNDF, ZMAX, ZMIN
LOGICAL               :: LLUNDF
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook('FACCPL_MT',0,zhook_handle)

ylfich => fa%FICHIER(krang)
irangc = ylfich%NUCADR
ylcadr => fa%CADRE(irangc)

! Save encoding options

ibfpdg = ylfich%NBFPDG 
ifgrib = ylfich%NFGRIB

! Hollow field encoding options

ylfich%NFGRIB = 140
ylfich%NBFPDG = ylfich%NCPLBITS

IF (ldcosp) THEN
  krep=-200
  GOTO 1001
ENDIF

krep=0

inlati=ylcadr%NLATIT
inxlon=ylcadr%NXLOPA

ilcham = inlati * inxlon
idluxg  = ylcadr%NLOPAR (4)  ! lon
idguxg  = ylcadr%NLOPAR (6)  ! lat
idzonl  = ylcadr%NLOPAR (7)  
idzong  = ylcadr%NLOPAR (8)

icplsize = ylfich%NCPLSIZE

ALLOCATE (zchamp(ilcham))

ilonmin=idzonl+icplsize
ilonmax=idluxg-icplsize-idzonl+1
ilatmin=idzong+icplsize
ilatmax=idguxg-icplsize-idzong+1

zmin = minval(pchamp(1:ilcham))
zmax = maxval(pchamp(1:ilcham))

IF (zmax > 0) THEN
  zundf = 2.0_jpdblr * zmax
ELSEIF (zmax < 0) THEN
  zundf = 0.5_jpdblr * zmax
ELSEIF (zmin < 0) THEN
  zundf = 2.0_jpdblr * zmin
ELSEIF (zmin > 0) THEN
  zundf = 0.5_jpdblr * zmin
ELSE ! ZMAX=ZMIN=0.
  zundf = 1.0_jpdblr
ENDIF

DO ilat = 1, inlati
  DO ilon = 1, inxlon
    IF ((ilon <= ilonmin) .OR. (ilon >= ilonmax) .OR. &
      & (ilat <= ilatmin) .OR. (ilat >= ilatmax)) THEN
      zchamp((ilat-1)*inxlon+ilon) = pchamp((ilat-1)*inxlon+ilon)
    ELSE
      zchamp((ilat-1)*inxlon+ilon) = zundf
    ENDIF
  ENDDO
ENDDO

llundf = .true.
CALL facgrm_fort (fa, krep, krang, cdpref, knivau, cdsuff, zchamp, &
                & ldcosp, igribh, llundf, zundf, 2_jplikb)

IF (krep /= 0) GOTO 1001

CALL igrib_set_value (igribh, 'ICPLSIZE', icplsize)

CALL igrib_get_value (igribh, 'INBITS', inbits)

CALL igrib_get_message_size (igribh, ilgrib)

ALLOCATE (clgrib(ilgrib))
CALL grib_copy_message (igribh, clgrib, status=iret)

IF (iret == grib_success) THEN
  ilongd = 4+(ilgrib+7)/8
  kvalco(1) = ifgrib
  kvalco(2) = 0
  kvalco(3) = icplsize
  kvalco(4) = inbits
  IF ((klongd < ilongd) .AND. (klongd > 0)) THEN
    krep=-130
    GOTO 1001
  ELSE
    klongd = ilongd
  ENDIF
  kvalco(5:ilongd) = transfer(clgrib, kvalco(5:ilongd))
ELSE
  krep = iret-1000
  GOTO 1001
ENDIF

CALL igrib_release (igribh)

1001 CONTINUE

IF (ALLOCATED (clgrib)) DEALLOCATE (clgrib)
IF (ALLOCATED (zchamp)) DEALLOCATE (zchamp)

! Restore encoding options

ylfich%NBFPDG = ibfpdg 
ylfich%NFGRIB = ifgrib 

!

llfata=llmoer(krep,krang)

IF (fa%LFAMOP.OR.llfata) THEN
  inimes=2
  clnspr='FACCPL'
  inumer=jpniil

  WRITE (unit=clmess,fmt="('KREP=',I4,', KRANG=',I4,         &
&   ', CDPREF=''',A,''', KNIVAU=',I4,', CDSUFF=''',A,'''')") &
&             krep, krang, cdpref, knivau, cdsuff
  CALL faipar_fort                                       &
&                 (fa,inumer,inimes,krep,.false.,clmess, &
&                  clnspr, '',.false.)
ENDIF

IF (lhook) CALL dr_hook('FACCPL_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"

END SUBROUTINE