fasgra.F90

Go to the documentation of this file.

SUBROUTINE fasgra_fort                                             &
&                     (fa,  krep, cdnomc, klongd)

USE fa_mod, ONLY : fa_com, facadr, lgrib2_lam_bf
USE parkind1, ONLY : jprb, jpim
USE lfi_precision
USE yomhook , ONLY : lhook, dr_hook

IMPLICIT NONE
!****
!      Sous-programme de calcul de la taille maximale de l'entete GRIB pour
!     un champ horizontal.
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                CDNOMC (Entree) ==> Nom du cadre
!                KLONGD (Sortie) ==> Taille max. de l'entete
!
!

TYPE(fa_com)   :: FA
INTEGER (KIND=JPLIKB) KREP, KLONGD
!
CHARACTER CDNOMC*(*)
!
INTEGER (KIND=JPLIKB) :: J
type(facadr), POINTER :: ylcadr
INTEGER (KIND=JPLIKB) :: IRANGC, IRANGC2, INUMER2, IRANG2
INTEGER (KIND=JPLIKB) :: ITYPTR, ISTROI
!
CHARACTER (LEN=*), PARAMETER :: CLNOM2 = '.dummy'
!
INTEGER (KIND=JPLIKB), PARAMETER :: IFLEVG = 1, itronc = 2, ilatit = 4, ixlopa = 5, inpahe=(1+ilatit)/2
INTEGER (KIND=JPLIKB), ALLOCATABLE :: IOZPAR (:), INLOPA (:)
REAL (KIND=JPDBLR),    ALLOCATABLE :: ZSINLA (:)

CHARACTER (LEN=16) :: CLNOMA, CLPREF, CLSUFF
INTEGER (KIND=JPLIKB) :: ILGRSP, ILGRGP, ILCHSP, ILCHGP
INTEGER (KIND=JPLIKB) :: ILNOMA, INBARI, INBARP, INIVAU
INTEGER (KIND=JPLIKB) :: INGRIB, INBPDG, INBCSP, ISTRON, IPUILA, IDMOPL, ILNOMC

REAL (KIND=JPDBLR) :: ZCHAMP (1000)
INTEGER (KIND=JPLIKB) :: IVALCO (1000)
REAL (KIND=JPDBLR) :: ZFOHYB (2,iflevg+1)
REAL (KIND=JPDBLR) :: ZUNDF
LOGICAL :: LLMLAM, LLLTLN, LLUNDF, LLMODC, LLREDF

REAL (KIND=JPRB) :: ZHOOK_HANDLE

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

#ifndef BUG_FAGRIB2
!#define FAGRIB2
#endif
#ifndef FAGRIB2

klongd = 2
GOTO 1001

#else

CALL fanuca_fort (fa, cdnomc,irangc, .false.)

ylcadr => fa%CADRE(irangc)

IF (ylcadr%IADDPK > 0) THEN
  klongd = ylcadr%IADDPK
  GOTO 1001
ENDIF

istroi = fa%NSTROI
fa%NSTROI = 1


llmlam = ylcadr%LIMLAM
llltln = ylcadr%SINLAT(2) < 0 .AND. llmlam

! Taille d'un champ

IF (llmlam) THEN
  ilchsp = ylcadr%NSFLAM
ELSE
  ilchsp = (1+ylcadr%MTRONC)*(2+ylcadr%MTRONC)
ENDIF

ilchgp = ylcadr%NVAPDG

! Geometrie minimale

ALLOCATE (iozpar(fa%JPXIND), inlopa(fa%JPXPAH), zsinla(fa%JPXGEO))

zfohyb(1,:) = 1._jpdblr
zfohyb(2,:) = 0._jpdblr

iozpar = 1

IF (llmlam) THEN
  ityptr = - itronc
  zsinla(1:18) = ylcadr%SINLAT (1:18)
  inlopa(1:8)  = (/ 1_jplikb, 1_jplikb, &
                 &   1_jplikb, ilatit-2, &
                 &   1_jplikb, ixlopa-2, &
                 &   0_jplikb, 0_jplikb /)
ELSE
  zsinla(1:inpahe) = (/ (1._jpdblr/REAL (J, JPDBLR), J = 1, inpahe) /)
  ityptr = ylcadr%NTYPTR
  inlopa = ixlopa
ENDIF


! Definition d'un cadre sur la geometrie minimale

llmodc = .false.
llredf = .false.
ilnomc = int(len(clnom2), jplikb)

CALL facadi_fort                                                                        &
&           (fa, krep, clnom2, ityptr, ylcadr%SSLAPO, ylcadr%SCLOPO, ylcadr%SSLOPO,     &
&            ylcadr%SCODIL, itronc,  ilatit, ixlopa, inlopa, iozpar, zsinla, iflevg,    &
&            ylcadr%SPREFE, zfohyb(1,:), zfohyb(2,:), llmodc, llredf, 0_jplikb,       &
&            irangc2, ilnomc, 1_jplikb)


! Ouverture d'un fichier

inumer2 = 0
inbarp=0
inbari=0

CALL fanouv_fort (fa, krep, inumer2, .false., clnom2, 'UNKNOWN', .true., &
                & .true., 0_jplikb, inbarp, inbari, clnom2)

CALL fanumu_fort (fa, inumer2, irang2)

! Read grib_api templates

CALL faigra_fort (fa)


! Compactage et extrapolation de la taille d'un champ compacte

CALL fagote_fort (fa, krep, inumer2, 121_jplikb, 64_jplikb, 64_jplikb, 1_jplikb, 0_jplikb, 0_jplikb)

zundf  = 0._jpdblr
llundf = .false.
zchamp = 0._jpdblr
ivalco = 0_jplikb
IF (llltln) THEN
  clpref = 'H'
  inivau = 2
  clsuff = 'TEMPERATURE'
  ilgrgp = SIZE (ivalco)
  CALL facgra_fort (fa, krep, irang2, clpref, inivau, clsuff, zchamp, &
                  & .false., ivalco, ilgrgp, llundf, zundf)
  klongd = max(ilgrgp, 2)
ELSE
  clpref = 'S'
  inivau = 1
  clsuff = 'TEMPERATURE'
  ilgrgp = SIZE (ivalco)
  CALL facgra_fort (fa, krep, irang2, clpref, inivau, clsuff, zchamp, &
                  & .false., ivalco, ilgrgp, llundf, zundf)
  IF ((.NOT. llmlam) .OR. lgrib2_lam_bf) THEN
    ilgrsp = SIZE (ivalco)
    CALL facgra_fort (fa, krep, irang2, clpref, inivau, clsuff, zchamp, &
                    & .true.,  ivalco, ilgrsp, llundf, zundf)
  ELSE
    ilgrsp = 0
  ENDIF
  klongd=max(                                                        &
        &         2, ilgrgp + 2*(ylcadr%NNIVER+1) + ylcadr%NLATIT,    &
        &         2, ilgrsp + 2*(ylcadr%NNIVER+1)                     &
        &    )
ENDIF

klongd = klongd + 100

CALL fairno_fort (fa, krep, inumer2, 'KEEP')

ylcadr%IADDPK = klongd

fa%NSTROI = istroi

#endif

1001 CONTINUE

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

END SUBROUTINE fasgra_fort

SUBROUTINE fasgra64                                        &
&           (krep, cdnomc, klongd)
USE fa_mod, ONLY : fa => fa_com_default, &
&                  fa_com_default_init,  &
&                  new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKB)  KREP                                   !   OUT
CHARACTER (LEN=*)      CDNOMC                                 ! IN   
INTEGER (KIND=JPLIKB)  KLONGD                                 !   OUT

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fasgra_fort                                               &
&           (fa, krep, cdnomc, klongd)

END SUBROUTINE

SUBROUTINE fasgra                                          &
&           (krep, cdnomc, klongd)
USE fa_mod, ONLY : fa => fa_com_default, &
&                  fa_com_default_init,  &
&                  new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
CHARACTER (LEN=*)      CDNOMC                                 ! IN   
INTEGER (KIND=JPLIKM)  KLONGD                                 !   OUT

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fasgra_mt                                                 &
&           (fa, krep, cdnomc, klongd)

END SUBROUTINE

SUBROUTINE fasgra_mt                                           &
&           (fa, krep, cdnomc, klongd)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
! Arguments
type(fa_com)          fa                                     ! INOUT
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
CHARACTER (LEN=*)      CDNOMC                                 ! IN   
INTEGER (KIND=JPLIKM)  KLONGD                                 !   OUT
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  ILONGD                                 !   OUT
! Convert arguments


CALL fasgra_fort                                               &
&           (fa, irep, cdnomc, ilongd)

krep       = int(      irep, jplikm)
klongd     = int(    ilongd, jplikm)

END SUBROUTINE