fadcpl.F90

Go to the documentation of this file.

SUBROUTINE fadcpl_fort                                          &
&                     (fa, krep, krang, cdnoma, kvalco, klonga, &
&                      pchamp, ldcosp, ldundf, pundf)
USE fa_mod, ONLY : fa_com, jpniil
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, KLONGA
!
INTEGER (KIND=JPLIKB) KVALCO(*)
REAL (KIND=JPDBLR)    PCHAMP(*)
REAL (KIND=JPDBLR)    PUNDF
!
LOGICAL LDCOSP, LDUNDF
!
CHARACTER CDNOMA*(*)
!
!
REAL (KIND=JPDBLR) :: Z1, Z2, Z3, Z4
INTEGER (KIND=JPLIKB) IRANGC
INTEGER (KIND=JPLIKB) INLATI, INXLON, IDLUXG, IDGUXG, IDZONL, IDZONG
INTEGER (KIND=JPLIKB) ILCHAM
INTEGER (KIND=JPLIKB) ICPLSIZE, INBITS
INTEGER (KIND=JPLIKB) ILAT, ILON, IPACK
INTEGER (KIND=JPLIKB) ILAT1, ILAT2, ILAT3, ILAT4
INTEGER (KIND=JPLIKB) ILON1, ILON2, ILON3, ILON4
INTEGER (KIND=JPLIKB) ILATMIN, ILATMAX, ILONMIN, ILONMAX
INTEGER (KIND=JPLIKB) INIMES, INUMER
!
CHARACTER(LEN=FA%JPLMES) CLMESS
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL :: LLFATA
!
REAL (KIND=JPDBLR) :: ZUNDF, ZMULTI
INTEGER (KIND=JPLIKM) :: ILGRIB, IGRIBH, IRET
INTEGER (KIND=JPLIKB) :: INOD, INOV
CHARACTER, ALLOCATABLE :: CLGRIB (:)
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

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

krep=0

irangc=fa%FICHIER(krang)%NUCADR
inlati=fa%CADRE(irangc)%NLATIT
inxlon=fa%CADRE(irangc)%NXLOPA

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

icplsize = kvalco(3)
inbits   = kvalco(4)

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


ilgrib = (klonga-3)*8

ALLOCATE (clgrib(ilgrib))
clgrib = transfer(kvalco(5:klonga), clgrib)
CALL grib_new_from_message_char (igribh, clgrib, status=iret)
DEALLOCATE (clgrib)
IF (iret /= grib_success) THEN
  krep=-1000-iret
  GOTO 1001
ENDIF

CALL igrib_get_value (igribh, 'FMULTI', zmulti)
CALL igrib_get_value (igribh, 'numberOfValues', inov) 
CALL igrib_get_value (igribh, 'numberOfDataPoints', inod) 
CALL igrib_get_value (igribh, 'values', pchamp(1:ilcham))
CALL igrib_get_value (igribh, 'missingValue',  zundf)
CALL igrib_release (igribh)


! Basic check on dimensions

IF ((inod < ilcham) .OR. &
  & (inov < (ilcham-(ilatmax-ilatmin-1)*(ilonmax-ilonmin-1)))) THEN
  krep=-93
  GOTO 1001
ELSEIF ((inod > ilcham) .OR. &
  & (inov > (ilcham-(ilatmax-ilatmin-1)*(ilonmax-ilonmin-1)))) THEN
  krep=-94
  GOTO 1001
ENDIF

! Apply scaling factor

IF (zmulti /= real(1._4, jpdblr)) THEN
  pchamp(1:ilcham) = pchamp(1:ilcham) / zmulti
  zundf             = zundf             / zmulti
ENDIF

DO ilat = ilatmin+1, ilatmax-1
  DO ilon = ilonmin+1, ilonmax-1

    IF (ldundf) THEN
      pchamp((ilat-1)*inxlon+ilon) = pundf
    ELSE
      ilat1=ilat
      ilon1=ilonmin

      ilat2=ilat
      ilon2=ilonmax

      ilat3=ilatmin
      ilon3=ilon

      ilat4=ilatmax
      ilon4=ilon

      z1 = 1.0_jprb / (ilon-ilon1)
      z2 = 1.0_jprb / (ilon2-ilon)
      z3 = 1.0_jprb / (ilat-ilat3)
      z4 = 1.0_jprb / (ilat4-ilat)

      pchamp((ilat-1)*inxlon+ilon) = &
                    & (z1*pchamp((ilat1-1)*inxlon+ilon1)   &
                    & +z2*pchamp((ilat2-1)*inxlon+ilon2)   &
                    & +z3*pchamp((ilat3-1)*inxlon+ilon3)   &
                    & +z4*pchamp((ilat4-1)*inxlon+ilon4))  &
                    & /(z1+z2+z3+z4) 
    ENDIF

  ENDDO
ENDDO

1001 CONTINUE

llfata=llmoer(krep,krang)

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

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

!
IF (lhook) CALL dr_hook('FADCPL_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"

END SUBROUTINE