fa_mod.F90

Go to the documentation of this file.

MODULE fa_mod
! Feb-2013 P. Marguinaud Define JNGEOM & JNEXPL
!                        Fix bug in cadre allocation
! Jan-2011 P. Marguinaud Interface to thread-safe FA
! Sep-2012 P. Marguinaud DrHook

USE parkind1, ONLY : jpim, jprb, jpia
USE yomhook, ONLY : lhook, dr_hook
USE lfimod, ONLY : lficom, jplspx

USE lfi_precision
IMPLICIT NONE

! Date index

INTEGER (KIND=JPLIKB), PARAMETER :: &
& JD_YEA =  1, JD_MON =  2, JD_DAY =  3, &  !  Base year, month, day
& JD_HOU =  4, JD_MIN =  5, JD_TUN =  6, &  !  Base hour, minute, term unit (1=hour, 2=day)
& JD_THO =  7, JD_GR8 =  8, JD_IAN =  9, &  !  Term hour or day, ?, forecast/initialised analysis flag
& JD_CU1 = 10, JD_CU2 = 11,              &  !  Time of event1 (hour or day), time of event2 (hour or day)
& JD_DEX = 12,              JD_SEM = 14, &  !  Extended date flag,                       base seconds
& JD_SET = 15, JD_CE1 = 16, JD_CE2 = 17, &  !  Term in seconds, seconds of event1, seconds of event2
& JD_TST = 18, JD_FMT = 19,              &  !  Time step, time format
& JD_SIZ = 22

INTEGER (KIND=JPLIKB), PARAMETER :: jpprcm = jpdbld / jpdblr

INTEGER (KIND=JPLIKB), PARAMETER :: jngeom =  18_jplikb
INTEGER (KIND=JPLIKB), PARAMETER :: jnexpl =   8_jplikb

INTEGER (KIND=JPLIKB), PARAMETER :: jpniil =-999_jplikb
INTEGER (KIND=JPLIKB), PARAMETER :: jpxnom =  16_jplikb
INTEGER (KIND=JPLIKB), PARAMETER :: jpxprf =   8_jplikb
INTEGER (KIND=JPLIKB), PARAMETER :: jpxsuf = jpxnom+jpxprf 

INTEGER (KIND=JPLIKB), PARAMETER :: nundef = jpniil
REAL (KIND=JPDBLR),    PARAMETER :: xundef = -99._jpdbld
LOGICAL,               PARAMETER :: lundef = .false.
CHARACTER,             PARAMETER :: cundef = char (0)
!****
!           !-----------------------------------------------!
!           ! Sous-programme du Logiciel de Fichiers ARPEGE !
!           !-----------------------------------------------!
!
!       - Version originale du logiciel: Mars 1990, auteur:
!           Jean CLOCHARD, Meteorologie Nationale, FRANCE.
!
!       - Juin 90: Ajout du "type de transformation horizontale"
!         aux elements definissant un cadre
!         (1=transformation de Frank-Schmidt "pure", 2=ARPEGE complete),
!         et ajout de la notion d'"Identificateur de Fichier".
!
!**
!---------------- VARIABLES "SIMPLES" GLOBALES -------------------------
!
!     NFIOUV = Nombre de fichiers ouverts simultanement
!     NCADEF =   "    "  cadres definis        "
!     LFAMUL = Option "utilisation du logiciel en mode multi-taches"
!     LFAMOP = Option "mode mise au point du logiciel"
!     VRGLAS = Verrou global du lociciel (en mode multi-taches)
!     NIMSGA = Niveau global de messagerie du logiciel
!     NRFAGA = Niveau de filtrage global des erreurs fatales detectees ?
!     NBIPDG = Nombre de bits IMPLICITE par valeur point-de-grille
!     NBICSP =    "   "   "   IMPLICITE par coefficient spectral
!     NSTROI = Sous-troncature non compactee IMPLICITE (coef. spectraux)
!     NPUILA = "Puissance de laplacien" IMPLICITE pour coeffi. spectraux
!     NMIDPL = Degre de modulation IMPLICITE de puissance de laplacien
!     NIGRIB = Niveau IMPLICITE de codage GRIB
!              (  0 ==> pas de codage, 1 ==> "standard", 2 => "Arpege" )
!              ( -1 ==> pas de codage (rangt coeff spec selon modele)  )
!              (  3 ==> "GRIBEX"      (rangt coeff spec selon modele)  )
!     NCPCAD = Nombre maximum de caracteres possibles par nom de cadre.
!     SPSMIN = Pression sol minimum   "     "    "     "      "    "
!     SPSMAX = Pression sol maximum   "     "    "     "      "    "
!     MPRESX = Pression maximum pour designer un niveau isobare
!     NBIMAC = Nombre de bits par mot machine
!     NBIMAX = Nombre maximum de bits par valeur elementaire compactee
!     NTYPTX = Type maximum reconnu de transformation horizontale
!     LIGARD = Option de conservation des cadres definis dynamiquement
!
!        Ci-dessous, limites en termes de dimensions reglables au niveau
!     usager, initialisees aux valeurs maximum du logiciel:
!
!     NXNIVV = Nombre maximum de niveaux verticaux au niveau usager
!     NXTRON = Troncature maximum                  "    "      "
!     NXLATI = Nombre maximum de latitudes de pole a pole "    "
!     NXLONG = Nombre maximum de longitudes par parallele "    "
!
!     CHAINC = Impression de substitut aux variables non reconnues
!**
!------------------------- TABLEAUX GLOBAUX ----------------------------
!
!     NULIND = Table d'indirection pour les autres tables "fichiers"
!     NCAIND =   "   "      "       "    "     "      "   "cadres"
!**
!--------- DESCRIPTIF DES ELEMENTS CONCERNANT UNE UNITE LOGIQUE --------
!
!     NULOGI = Numero de l'unite logique
!     NUCADR = Rang du cadre auquel le fichier est rattache
!     CIDENT = Identification (utilisateur) du fichier
!     LNOMME = Vrai si l'unite logique a un nom utilisateur (BOF...)
!     NIVOMS = Niveau de la messagerie defini par l'utilisateur
!     LERRFA = Vrai si toute erreur detectee doit etre fatale
!     LCREAF = Vrai si le fichier est en mode creation
!     NBFPDG = Nombre de bits EFFECTIF par valeur point-de-grille
!     NBFCSP =    "   "   "   EFFECTIF par coefficient spectral
!     NPUFLA = "Puissance de laplacien" EFFECTIVE pour coeffi. spectraux
!     NSTROF = Sous-troncature non compactee EFFECTIVE (coef. spectraux)
!     NMFDPL = Degre de modulation EFFECTIF de la puissance de laplacien
!     NFGRIB = Niveau EFFECTIF de codage GRIB
!     VRFICH = Verrou du fichier (en mode multi-taches)
!
!     MADATE = Contenu de l'article 'DATE'
!
!     CTNPRF = Prefixes de champ (re)connus.
!     NIVDSC = Descripteurs associes aux prefixes (re)connus.
!     NRASHO = Nombre de champs de coeff. spectraux ARPEGE ranges
!              horizontalement (donc a l'inverse du modele) detectes au
!              cours des lectures/ecritures
!     NRASVE = Nombre de champs de coeff. spectraux ARPEGE ranges
!              verticalement (donc comme le modele), detectes au cours
!              des lectures/ecritures
!
!**
!----------- DESCRIPTIF DES ELEMENTS CONSTITUANT UN CADRE --------------
!
!                     Elements DEFINISSANT un cadre:
!
!     CNOMCA = Nom du cadre (conventionnel; non ecrit sur le fichier)
!     NLCCAD = Longueur en caracteres du nom de cadre
!     NULCAD = Nombre d'unites logiques rattachees au cadre
!     MTRONC = Troncature associee aux donnees contenues dans le fichier
!     NNIVER = Nombre de niveaux verticaux
!     NLATIT =   "    "  latitudes de pole a pole
!     NXLOPA =   "    maximum de longitudes par cercle de latitude
!     NTYPTR = Type de transformation horizontale
!     SSLAPO = Sinus   de la latitude  du pole d'interet
!     SCLOPO = Cosinus  "   "     "     "    "      "
!     SSLOPO = Sinus    "   "     "     "    "      "
!     SCODIL = Coefficient de dilatation
!     SPREFE = Pression de reference (facteur multiplicatif de la premi-
!              ere fonction de la coordonnee hybride)
!     NLOPAR = Nombre de longitudes par parallele de l'hemisphere "nord"
!     NOZPAR =    "   d'onde zonal maximum "    "  "     "        "
!     SINLAT = Sinus des latitudes de la grille (*hemisphere nord seul*)
!     SFOHYB = Valeurs des fonctions "A" et "B" de la coordonnee hybride
!              (Definies aux LIMITES DE COUCHES)
!
!                Autres elements rattaches a un cadre:
!
!     NVAPDG = Nombre total de points de grille dans un champ horizontal
!     NGARDE = Option de conservation lors de la fermeture du dernier
!              fichier s'y rattachant. ( 0=Non, 1=selon LIGARD, 2=Oui )
!     LIMLAM = IMPLICIT SWITCH FOR SETTING OF GLOBAL/LAM CASE
!     NSFLAM = TOTAL NUMBER OF SPECTRAL COEFFICIENTS FOR LAM CASE
!

TYPE facadr
  INTEGER (KIND=JPLIKB)          :: mtronc         = nundef
  INTEGER (KIND=JPLIKB)          :: nniver         = nundef
  INTEGER (KIND=JPLIKB)          :: nlatit         = nundef
  INTEGER (KIND=JPLIKB)          :: nxlopa         = nundef
  INTEGER (KIND=JPLIKB)          :: nulcad         = nundef
  INTEGER (KIND=JPLIKB)          :: nlccad         = nundef
  INTEGER (KIND=JPLIKB)          :: ngarde         = nundef
  INTEGER (KIND=JPLIKB)          :: nvapdg         = nundef
  INTEGER (KIND=JPLIKB)          :: ntyptr         = nundef
  INTEGER (KIND=JPLIKB)          :: nsflam         = nundef
  REAL (KIND=JPDBLR)             :: sslapo         = xundef
  REAL (KIND=JPDBLR)             :: sclopo         = xundef
  REAL (KIND=JPDBLR)             :: sprefe         = xundef
  REAL (KIND=JPDBLR)             :: sslopo         = xundef
  LOGICAL                        :: limlam         = lundef
  CHARACTER*(JPXNOM)             :: cnomca         = cundef
  REAL (KIND=JPDBLR)             :: scodil         = xundef
  REAL (KIND=JPDBLR),    POINTER :: sinlat (:)     => null ()
  INTEGER (KIND=JPLIKB), POINTER :: nlopar (:)     => null ()
  INTEGER (KIND=JPLIKB), POINTER :: nozpar (:)     => null ()
  REAL (KIND=JPDBLR),    POINTER :: sfohyb (:,:)   => null ()

!      EN-TETE POUR GRIBEX (SECTIONS 1 ET 2) 

  INTEGER (KIND=JPLIKB), POINTER :: nsec2sp(:)     => null ()
  INTEGER (KIND=JPLIKB), POINTER :: nsec2ll(:)     => null ()
  INTEGER (KIND=JPLIKB), POINTER :: nsec2gg(:)     => null ()
  INTEGER (KIND=JPLIKB), POINTER :: nsec2la(:)     => null ()
  INTEGER (KIND=JPLIKB), POINTER :: nsec2al(:)     => null ()
  REAL (KIND=JPDBLR),    POINTER :: xsec2(:)       => null ()
  LOGICAL                        :: lisec2         = .true.

  INTEGER (KIND=JPLIKB), POINTER :: nompar(:)      => null ()

  INTEGER (KIND=JPLIKB)          :: nsefre         = nundef
  INTEGER (KIND=JPLIKB)          :: nsmax          = nundef
  INTEGER (KIND=JPLIKB)          :: nmsmax         = nundef
  INTEGER (KIND=JPLIKB), POINTER :: ncpl4m  (:)    => null ()
  INTEGER (KIND=JPLIKB), POINTER :: nismax  (:)    => null ()
  INTEGER (KIND=JPLIKB), POINTER :: nisnax  (:)    => null ()
  INTEGER (KIND=JPLIKB), POINTER :: ndim0gg (:)    => null ()
  INTEGER (KIND=JPLIKB)          :: iaddpk         = 0_jplikb

END TYPE facadr

TYPE fafich
  INTEGER (KIND=JPLIKB)          :: nulogi       = jpniil   ! From farine.F90
  INTEGER (KIND=JPIA)            :: nfilep       = 0_jpia   ! Auxiliary FILE pointer
  INTEGER (KIND=JPLIKB)          :: noffst       = 0_jplikb ! Auxiliary FILE offset
  INTEGER (KIND=JPLIKB)          :: nucadr       = nundef
  INTEGER (KIND=JPLIKB)          :: nivoms       = nundef
  INTEGER (KIND=JPLIKB)          :: nbfpdg       = nundef
  INTEGER (KIND=JPLIKB)          :: nbfcsp       = nundef
  INTEGER (KIND=JPLIKB)          :: npufla       = nundef
  INTEGER (KIND=JPLIKB)          :: nfgrib       = nundef
  INTEGER (KIND=JPLIKB)          :: nstrof       = nundef
  INTEGER (KIND=JPLIKB)          :: nmfdpl       = nundef
  INTEGER (KIND=JPLIKB)          :: nrasho       = 0_jplikb ! From farine.F90
  INTEGER (KIND=JPLIKB)          :: nrasve       = 0_jplikb ! From farine.F90
  INTEGER (KIND=JPLIKB), POINTER :: madate (:)   => null ()
  INTEGER (KIND=JPLIKB), POINTER :: madatx (:)   => null ()
  LOGICAL                        :: lerrfa       = lundef
  REAL (KIND=JPDBLR)             :: vrfich       = xundef
  LOGICAL                        :: lcreaf       = lundef
  CHARACTER*(JPXNOM)             :: cident       = cundef
  LOGICAL                        :: liflap       = .false.  ! From farine.F90
  LOGICAL                        :: lnomme       = lundef
  INTEGER (KIND=JPLIKB)          :: nsec1 (2:21) 
  INTEGER (KIND=JPLIKB), POINTER :: nsc2alf(:)   => null ()
  LOGICAL                        :: lisec1       = .true.   ! From farine.F90
  LOGICAL                        :: lisc2f       = .true.   ! From farine.F90
  INTEGER (KIND=JPLIKB)          :: ncogrif(12) 
  REAL (KIND=JPDBLR),    POINTER :: flap1d(:)    => null ()
  REAL (KIND=JPDBLR),    POINTER :: flap1da(:)   => null ()
  INTEGER (KIND=JPLIKB)          :: ncplsize     = nundef
  INTEGER (KIND=JPLIKB)          :: ncplbits     = nundef
  INTEGER (KIND=JPLIKB)          :: ioptgrsx2o   = nundef
  INTEGER (KIND=JPLIKB)          :: ioptgrsn2o   = nundef
  CHARACTER (LEN=64)             :: cmodel       = ''
  INTEGER (KIND=JPLIKB)          :: nidcen       = 85_jplikb
END TYPE fafich

TYPE fagr1tab

  CHARACTER(LEN=JPXPRF) :: cipref = cundef
  CHARACTER(LEN=JPXSUF) :: cisuff = cundef
  INTEGER (KIND=JPLIKB) :: ncodpa(8) = (/ nundef, nundef, nundef, nundef, nundef, nundef, nundef, nundef /)
  LOGICAL               :: lfniva = .false.  
  REAL (KIND=JPDBLR)    :: fmulti = xundef  ! Facteur multiplicatif avant encodage
  LOGICAL               :: lmulti = .false. ! Appliquer FMULTI ou non
  
END TYPE fagr1tab

TYPE fa_com

  TYPE(lficom), POINTER :: lfi => null ()

  INTEGER (KIND=JPLIKB), POINTER :: nulind (:) => null ()
  INTEGER (KIND=JPLIKB), POINTER :: ncaind (:) => null ()

  INTEGER (KIND=JPLIKB) nfiouv, ncadef, nimsga, nrfaga
  INTEGER (KIND=JPLIKB) nbipdg, nbicsp, npuila
  INTEGER (KIND=JPLIKB) nigrib, ncpcad, nstroi, nmidpl
  INTEGER (KIND=JPLIKB) nbimac, nbimax, mpresx
  INTEGER (KIND=JPLIKB) nxnivv, nxtron, nxlati, nxlong, ntyptx
!
  INTEGER (KIND=JPLIKB), POINTER :: nivdsc (:,:) => null ()
!
  REAL (KIND=JPDBLR) spsmin, spsmax, vrglas
!
!
  LOGICAL lfamul, lfamop, ligard
!
  CHARACTER*(JPXNOM) chainc
  CHARACTER(LEN=8), POINTER :: ctnprf (:) => null ()
!
!**
!----- DESCRIPTION DES "PARAMETER" DU LOGICIEL DE "FICHIER ARPEGE" -----
!
!     JPNXFA = Nombre maximum de fichiers ouverts "simultanement"
!     JPNXCA =    "      "    "  cadres definissables "simultanement"
!     JPXNIV =    "      "    "  niveaux verticaux (champs d'altitude)
!     JPXTRO = Troncature maximum gerable
!     JPXLAT = Nombre maximum de latitudes de pole a pole
!     JPXLON = Nombre maximum de longitudes par parallele
!     JPLDAT = Longueur de l'article 'DATE', en mots
!     JPLB1P = Longueur du tableau "Bloc 1" pour sous-programmes GRIB
!     JPLB2P = Longueur du tableau "Bloc 2" pour sous-programmes GRIB
!     JPNIIL = Code "valeur absente" du logiciel pour les entiers
!     JPXCSP = Dimension maxi d'un champ en coefficients spectraux
!     JPXPDG = Dimension maxi d'un champ en points de grille
!     JPXCHA = Dimension maxi d'un champ ( maximum de JPXCSP et JPXPDG )
!     JPXPAH = Nombre maximum de latitudes par hemisphere
!     JPXIND = DIMENSIONING OF NOZPAR()
!     JPXGEO = DIMENSIONING OF SINLAT()
!     JPNVER = Numero de version du logiciel (qui est le contenu de
!              l'article dont le nom est l'identificateur du fichier)
!     JPUILA = Puissance de laplacien maximum pour laquelle les tableaux
!              servant a calculer laplacien et inverse sont precalcules
!     JPXNOM = Nombre maximum de caracteres par NOM d'article LFI.
!     JPXPRF =   "       "    "      "      par PReFixe de champ.
!     JPXSUF = JPXPRF+JPXNOM.
!     JPTNIV = Nombre de types de niveaux verticaux (re)connus.
!     CPDATE = Nom de l'article DATE
!
!         Noms des articles contenant les differentes parties du CADRE:
!
!     CPCADI = "Dimensions" (MTRONC, NNIVER, NLATIT, NXLOPA)
!     CPCAFS = Parametres de la transformation ARPEGE
!              (SSLAPO, SCLOPO, SSLOPO, SCODIL)
!     CPCARP = Tableaux lies a la reduction des points pres des poles
!     CPCASL = Tableau des sinus des latitudes
!     CPCACH = Valeurs des fonctions "A" et "B" de la coordonnee hybride
!     JPCADI et JPCAFS sont les longueurs des 2 premiers de ces articles
!
  INTEGER (KIND=JPLIKB) jpnxfa, jpnxca, jpldat
  INTEGER (KIND=JPLIKB) jpxniv, jpxtro, jpxlat
  INTEGER (KIND=JPLIKB) jpuila, jpxau1, jpxlon
  INTEGER (KIND=JPLIKB) jpxau2, jpxpah, jpxind, jpxgeo
  INTEGER (KIND=JPLIKB) jpxcsp, jpxcha, jplb1p
  INTEGER (KIND=JPLIKB) jplb2p, jpcadi, jpcafs, jpnver
  INTEGER (KIND=JPLIKB) jpxpdg, jpxnom, jpxprf, jpxsuf, jptniv
!
  CHARACTER cpcadi*(16), cpcafs*(16), cpcarp*(16), cpcach*(16)
  CHARACTER cpcasl*(16), cpdate*(16), cpdatx*(16)
!


!*
!      FAMODU - MODULE POUR LE LOGICIEL FA

!        D. PARADIS       METEO FRANCE     21/7/00

!  ----------------------------------------------------------------------
!  1 - COEFFICIENTS MULTIPLICATIFS DES COEFF SPECTRAUX
!
!     XLAP1D  = Coefficients elementaires pour "laplacien" [n*(n+1)],
!              ainsi que leurs inverses.
!     XLAP2D  = Cf. XLAP1D, mais etale dans un champ complet, et calcules
!              pour les puissances 1 a JPUILA, ainsi que les inverses.
!     FLAP1D  = Tableau des "puissances de laplacien" pour l'ecriture
!                     (n*(n+1))**NPUFLA()
!              ( Ce dernier tableau n'est calcule que pour une
!                puissance de laplacien non nulle )
!     XLAP1DA = ALADIN version de XLAP1D
!     XLAP2DA = ALADIN version de XLAP2D
!     FLAP1DA = ALADIN version de FLAP1D
!     LIXLAP  = .T. s'il faut initialiser XLAPxDx
!     LIFLAP() = .T. s'il faut initialiser FLAP1Dx()
!
!  2 - EN-TETE POUR GRIBEX (SECTIONS 1 ET 2)
!
!     JPSEC1   = taille du tableau contenant les elements de la section 1
!     JPSEC2   = taille du tableau contenant les elements de la section 2
!     JPSEC4   = taille du tableau contenant les elements de la section 4
!     NSEC1    = tableau contenant les elts 2:21 de la section 1 de GRIBEX
!     LISEC1() = .T. s'il faut initialiser le tableau NSEC1 ci-dessus
!
!      Tableaux contenant des elements de la section 2 de GRIBEX:
!     NSEC2SP  = cas de la representation spectrale ARPEGE avec niveaux modele
!     NSEC2GG  = cas de la grille de Gauss
!     NSEC2LL  = cas de la grille latitude-longitude
!     NSEC2LA  = cas de la grille Lambert conforme (type general de Aladin)
!     NSEC2AL  = cas de la representation spectrale Aladin deguisee lat-lon
!     NSC2ALF  = supplement a NSEC2AL dependant du fichier
!     XSEC2    = coordonnee verticale
!     LISEC2() = .T. s'il faut initialiser les tableaux ci-dessus sauf NSC2ALF
!     LISC2F() = .T. s'il faut initialiser NSC2ALF
!
!  3 - PARAMETRES DEFINISSANT LE CODAGE GRIBEX
!
!     NCODGRI  = tableau contenant les parametres de codage implicites
!     NCOGRIF  = tableau contenant les parametres de codage pour chaque fichier
!     CIPREF   = tableau contenant les prefixes des noms des champs connus
!     CISUFF   = tableau contenant les suffixes des noms des champs connus
!     NCODPA   = tableau contenant les 6 descripteurs GRIB des champs connus
!                NCODPA(1)= numero de version de la table de code parametre,
!                           KSEC1(1)
!                NCODPA(2)= indicateur de parametre, KSEC1(6)
!                NCODPA(3)= indicateur de type de niveau, KSEC1(7)
!                NCODPA(4)= niveau (premier niveau de la couche), KSEC1(8)
!                NCODPA(5)= deuxieme niveau de la couche, KSEC1(9)
!                NCODPA(6)= indicateur de type de champ, KSEC1(18)
!                           (0 sauf si min/max dans le temps => 2,
!                                ou si cumul dans le temps   => 4,
!                                ou cumul depuis le debut    => 8 )
!                NCODPA(7)= facteur d'echelle decimal, KSEC1(23)
!     JPXPAR   = nombre maximal de champs connus pour CISUFF, CIPREF et NCODPA
!     NBPARC   = nombre de champs connus pour CISUFF, CIPREF et NCODPA
!
!  4 - TABLEAU POUR CODER LES COEF SPECTRAUX ALADIN AVEC GRIBEX
!
!     NOMPAR   = tableau decrivant la position des coeff spectraux (CSP) ALADIN
!                en fonction du nombre d'onde zonal dans un tableau de donnees
!                stocke dans FA avec la methode de codage 3 ou -1 (rangt modele).
!                NOMPAR est l'equivalent de NOZPAR mais pour un rangement vertical
!                des CSP: NOMPAR(1)=NSMAX, NOMPAR(2)=NMSMAX (ces 2 valeurs de
!                NOMPAR sont speciales commme pour NOZPAR) et pour un JM donne,
!                compris entre 0 et NMSMAX, NOMPAR(2*JM+3) donne l'indice du
!                premier CSP associe a JM qui est contenu dans un champ spectral
!                et NOMPAR(2*JM+4) donne l'indice du dernier CSP associe a JM
!                qui est contenu dans un champ spectral.
!                
!  ----------------------------------------------------------------------

!  1 - COEFFICIENTS MULTIPLICATIFS DES COEFF SPECTRAUX

  REAL (KIND=JPDBLR), POINTER :: xlap1d(:,:)     => null ()
  REAL (KIND=JPDBLR), POINTER :: xlap1da(:,:)    => null ()
  REAL (KIND=JPDBLR), POINTER :: xlap2d(:,:,:)   => null ()
  REAL (KIND=JPDBLR), POINTER :: xlap2da(:,:,:)  => null ()

  LOGICAL lixlap
 
!  2 - EN-TETE POUR GRIBEX (SECTIONS 1 ET 2)

  INTEGER (KIND=JPLIKB) :: jpsec1, jpsec2
  INTEGER (KIND=JPLIKB) :: jpsec4

  INTEGER (KIND=JPLIKB) :: ioptgrsx2o   = nundef
  INTEGER (KIND=JPLIKB) :: ioptgrsn2o   = nundef
 
!  3 - PARAMETRES DEFINISSANT LE CODAGE GRIBEX

  INTEGER (KIND=JPLIKB) :: ncodgri(12) = (/ nundef, nundef, nundef, nundef, nundef, nundef, &
                                          & nundef, nundef, nundef, nundef, nundef, nundef /)
  INTEGER (KIND=JPLIKB) jpxpar
  INTEGER (KIND=JPLIKB) nbparc
  INTEGER (KIND=JPLIKB) :: nidcen = 85_jplikb
  
  
  type(fagr1tab), POINTER :: ygr1tab(:) => null()

!  4 - TABLEAU POUR CODER LES COEF SPECTRAUX ALADIN AVEC GRIBEX


  LOGICAL :: facade_llprea = .true.
  LOGICAL :: facage_llprea = .true.
  LOGICAL :: facies_llprea = .true.
  LOGICAL :: factum_llprea = .true.
  LOGICAL :: fagiot_llprea = .true.
  LOGICAL :: falimu_llprea = .true.
  LOGICAL :: famiso_llprea = .true.
  LOGICAL :: fanerg_llprea = .true.
  LOGICAL :: fanmsg_llprea = .true.
  LOGICAL :: fanuca_llprea = .true.
  LOGICAL :: fanumu_llprea = .true.
  LOGICAL :: faregi_llprea = .true.
  LOGICAL :: farflu_llprea = .true.
  LOGICAL :: farine_llprea = .true.
  LOGICAL :: favori_llprea = .true.
  LOGICAL :: faxion_llprea = .true.
  LOGICAL :: farine_lldefm = .false.
  INTEGER (KIND=JPLIKB) :: faxion_iscalx
  REAL (KIND=JPDBLR) faxion_zepsil

  INTEGER (KIND=JPLIKB) :: nulout = 0
  LOGICAL :: lopenmp = .true.

  INTEGER (KIND=JPLIKB) :: jplspx = jplspx
  INTEGER (KIND=JPLIKB) :: jplmes = 1024

  TYPE(facadr), POINTER :: cadre   (:) => null ()
  TYPE(fafich), POINTER :: fichier (:) => null ()

END TYPE fa_com

INTEGER, SAVE :: ngrib2_glo_sh = nundef  ! Spherical harmonics
INTEGER, SAVE :: ngrib2_glo_gp = nundef  ! Gaussian grid
INTEGER, SAVE :: ngrib2_lam_gp = nundef  ! Grid-point LAM 
INTEGER, SAVE :: ngrib2_lam_bf = nundef  ! LAM bi-Fourier
INTEGER, SAVE :: ngrib1_latlon = nundef  
INTEGER, SAVE :: ngrib2_latlon = nundef 
LOGICAL, SAVE :: lgrib2_lam_ex = .false. ! Extension zone metadata are available
LOGICAL, SAVE :: lgrib2_lam_bf = .false. ! LAM bi-Fourier is available
LOGICAL, SAVE :: lgrib2_init   = .false.

TYPE(fa_com), SAVE, TARGET :: fa_com_default
LOGICAL, SAVE :: fa_com_default_init = .false.

CONTAINS

SUBROUTINE new_cadre (CA, KTYPTR, KPXLAT, KPXTRO, KPXNIV)
type(facadr) :: ca
INTEGER (KIND=JPLIKB), INTENT (IN) :: KTYPTR, KPXLAT, KPXTRO, KPXNIV
LOGICAL :: LLMLAM

INTEGER (KIND=JPLIKB) :: &
&      IPXAU1, IPXLON, IPXAU2, IPXPAH, &
&      IPXIND, IPXGEO, IPXCSP, IPXPDG, &
&      IPXCHA
INTEGER (KIND=JPLIKB) :: INPAHE
INTEGER (KIND=JPLIKB) :: JM, JN, IPOS

llmlam = ktyptr .LE. 0

CALL cparams (kpxlat, kpxtro, ipxau1,  &
&      ipxlon, ipxau2, ipxpah, ipxind, &
&      ipxgeo, ipxcsp, ipxpdg, ipxcha)
   
IF (.NOT. llmlam) THEN
  inpahe=(1+kpxlat)/2
  ALLOCATE (                     &
 &    ca%NLOPAR (inpahe),        &
 &    ca%NOZPAR (inpahe),        &
 &    ca%SINLAT (inpahe),        &
 &    ca%NOMPAR (2*kpxtro+4))
ELSE
  ALLOCATE (                     &
 &    ca%NLOPAR (jnexpl),        &
 &    ca%NOZPAR (2*kpxtro+4),    &
 &    ca%SINLAT (jngeom),        &
 &    ca%NOMPAR (2*max(-ktyptr, kpxtro)+4))
ENDIF

ALLOCATE (                       &
&  ca%SFOHYB  (2,0:kpxniv),      &
&  ca%NSEC2SP (22),              &
&  ca%NSEC2LL (22),              &
&  ca%NSEC2GG (22+kpxlat),       &
&  ca%NSEC2LA (22),              &
&  ca%NSEC2AL (22),              &
&  ca%XSEC2   (10+2*(kpxniv+1)))

IF (llmlam) THEN

  ca%NSMAX  = kpxtro
  ca%NMSMAX = - ktyptr

  ALLOCATE (ca%NISNAX (0:ca%NMSMAX), ca%NISMAX (0:ca%NSMAX), &
          & ca%NCPL4M (0:ca%NMSMAX), ca%NDIM0GG (0:ca%NMSMAX))

  CALL ellips64 (ca%NSMAX, ca%NMSMAX, ca%NISNAX, ca%NISMAX)

  ca%NSEFRE = 0
  DO jm = 0, ca%NMSMAX
    ca%NSEFRE = ca%NSEFRE + 4*(ca%NISNAX(jm)+1)
  ENDDO

  DO jm = 0, ca%NMSMAX
    ca%NCPL4M(jm) = 4*(ca%NISNAX(jm)+1)
  ENDDO

  ipos = 1
  DO jm = 0, ca%NMSMAX
    ca%NDIM0GG (jm) = ipos
    ipos = ipos + ca%NCPL4M (jm)
  ENDDO

ELSE
  ca%NSMAX  = kpxtro
  ca%NMSMAX = kpxtro
  ca%NSEFRE = (ca%NSMAX+1)*(ca%NSMAX+1)
  ALLOCATE (ca%NDIM0GG (0:ca%NSMAX))
  
  ipos = 1
  DO jn = 0, ca%NSMAX
     ca%NDIM0GG (jn) = ipos
     ipos = ipos + (ca%NSMAX+1-jn) * 2
  ENDDO

ENDIF

END SUBROUTINE new_cadre

SUBROUTINE free_cadre (CA)

type(facadr) :: ca

type(facadr) :: cadum

IF (ASSOCIATED (ca%NLOPAR )) DEALLOCATE (ca%NLOPAR )
IF (ASSOCIATED (ca%NOZPAR )) DEALLOCATE (ca%NOZPAR )
IF (ASSOCIATED (ca%SINLAT )) DEALLOCATE (ca%SINLAT )
IF (ASSOCIATED (ca%SFOHYB )) DEALLOCATE (ca%SFOHYB )
IF (ASSOCIATED (ca%NSEC2SP)) DEALLOCATE (ca%NSEC2SP)
IF (ASSOCIATED (ca%NSEC2LL)) DEALLOCATE (ca%NSEC2LL)
IF (ASSOCIATED (ca%NSEC2GG)) DEALLOCATE (ca%NSEC2GG)
IF (ASSOCIATED (ca%NSEC2LA)) DEALLOCATE (ca%NSEC2LA)
IF (ASSOCIATED (ca%NSEC2AL)) DEALLOCATE (ca%NSEC2AL)
IF (ASSOCIATED (ca%XSEC2  )) DEALLOCATE (ca%XSEC2  )
IF (ASSOCIATED (ca%NOMPAR )) DEALLOCATE (ca%NOMPAR )

IF (ASSOCIATED (ca%NCPL4M )) DEALLOCATE (ca%NCPL4M )
IF (ASSOCIATED (ca%NISMAX )) DEALLOCATE (ca%NISMAX )
IF (ASSOCIATED (ca%NISNAX )) DEALLOCATE (ca%NISNAX )
IF (ASSOCIATED (ca%NDIM0GG)) DEALLOCATE (ca%NDIM0GG)

NULLIFY (ca%NLOPAR )
NULLIFY (ca%NOZPAR )
NULLIFY (ca%SINLAT )
NULLIFY (ca%SFOHYB )
NULLIFY (ca%NSEC2SP)
NULLIFY (ca%NSEC2LL)
NULLIFY (ca%NSEC2GG)
NULLIFY (ca%NSEC2LA)
NULLIFY (ca%NSEC2AL)
NULLIFY (ca%XSEC2  )
NULLIFY (ca%NOMPAR )

NULLIFY (ca%NCPL4M )
NULLIFY (ca%NISMAX )
NULLIFY (ca%NISNAX )
NULLIFY (ca%NDIM0GG)

ca = cadum

END SUBROUTINE free_cadre

SUBROUTINE new_fichier (FA, FI, KPLDAT, KPXTRO, KTYPTR)

type(fa_com) :: fa
type(fafich) :: fi
INTEGER (KIND=JPLIKB), INTENT (IN) :: KPLDAT, KPXTRO, KTYPTR
LOGICAL :: LLMLAM

llmlam = ktyptr .LE. 0

ALLOCATE (fi%MADATE (kpldat), fi%MADATX (kpldat))

fi%MADATE  = nundef
fi%MADATX  = nundef
fi%NCOGRIF = nundef
fi%NSEC1   = nundef
fi%NIDCEN  = fa%NIDCEN

IF (llmlam) THEN
  ALLOCATE (fi%NSC2ALF (max(-ktyptr, kpxtro)-1))
ELSE
  ALLOCATE (fi%NSC2ALF (kpxtro-1))
ENDIF

END SUBROUTINE new_fichier

SUBROUTINE free_fichier (FI)

type(fafich) :: fi
type(fafich) :: fidum

IF (ASSOCIATED (fi%MADATE )) DEALLOCATE (fi%MADATE )
IF (ASSOCIATED (fi%MADATX )) DEALLOCATE (fi%MADATX )
IF (ASSOCIATED (fi%NSC2ALF)) DEALLOCATE (fi%NSC2ALF)
IF (ASSOCIATED (fi%FLAP1D )) DEALLOCATE (fi%FLAP1D )
IF (ASSOCIATED (fi%FLAP1DA)) DEALLOCATE (fi%FLAP1DA)

fi = fidum

END SUBROUTINE free_fichier

SUBROUTINE new_fa_default ()
USE lfimod, ONLY : lficom_default, new_lfi_default
INTEGER :: IERR
REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FA_COM:NEW_FA_DEFAULT',0,zhook_handle)

CALL new_lfi_default
IF (.NOT. fa_com_default_init) THEN
  CALL new_fa (fa_com_default, ierr)
  fa_com_default_init = .true.
  fa_com_default%LFI => lficom_default
ENDIF

IF (lhook) CALL dr_hook ('FA_COM:NEW_FA_DEFAULT',1,zhook_handle)

END SUBROUTINE new_fa_default

SUBROUTINE new_fa (FA, KERR, KPXTRO, KPXLAT,  &
&                  KPXNIV, KPNXFA, KPNXCA)
TYPE(fa_com) :: FA
INTEGER, INTENT(OUT) :: KERR
INTEGER, OPTIONAL, INTENT(IN) :: KPXTRO
INTEGER, OPTIONAL, INTENT(IN) :: KPXLAT
INTEGER, OPTIONAL, INTENT(IN) :: KPXNIV
INTEGER, OPTIONAL, INTENT(IN) :: KPNXFA
INTEGER, OPTIONAL, INTENT(IN) :: KPNXCA
REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FA_COM:NEW_FA',0,zhook_handle)


fa%JPXNOM = jpxnom
fa%JPXPRF = jpxprf
fa%JPXSUF = jpxsuf

!
! Reglage de la troncature maximum gerable (JPXTRO)
! et du nombre maximum de niveaux verticaux (JPXNIV)
!
#if defined ( HIGHRES )
!
!     Setup high resolution parameters 
!
fa%JPXTRO = 1280
fa%JPXLAT = 2560
fa%JPXNIV = 200 
!
#else
! 
!     Setup low resolution parameters to save memory
!
fa%JPXTRO = 599 
fa%JPXLAT = 1200 
fa%JPXNIV = 200 
!
#endif
!
!
fa%JPNXFA=20 
fa%JPNXCA=20 

IF (PRESENT (kpxtro)) fa%JPXTRO = int(kpxtro, jplikb)
IF (PRESENT (kpxlat)) fa%JPXLAT = int(kpxlat, jplikb)
IF (PRESENT (kpxniv)) fa%JPXNIV = int(kpxniv, jplikb)
IF (PRESENT (kpnxfa)) fa%JPNXFA = int(kpnxfa, jplikb)
IF (PRESENT (kpnxca)) fa%JPNXCA = int(kpnxca, jplikb)

fa%JPLDAT=11 
fa%JPUILA=3 
fa%JPTNIV=14
CALL cparams (fa%JPXLAT, fa%JPXTRO, &
&   fa%JPXAU1, fa%JPXLON, fa%JPXAU2, fa%JPXPAH, &
&   fa%JPXIND, fa%JPXGEO, fa%JPXCSP, fa%JPXPDG, &
&   fa%JPXCHA)
fa%JPLB1P=19 
fa%JPLB2P=17 
fa%JPCADI=5 
fa%JPCAFS=4 
fa%JPNVER=1 
fa%CPCADI='CADRE-DIMENSIONS' 
fa%CPCAFS='CADRE-FRANKSCHMI'
fa%CPCARP='CADRE-REDPOINPOL' 
fa%CPCACH='CADRE-FOCOHYBRID'
fa%CPCASL='CADRE-SINLATITUD' 
fa%CPDATE='DATE-DES-DONNEES' 
fa%CPDATX='DATX-DES-DONNEES' 

fa%JPSEC1=37
fa%JPSEC2=22+max(fa%JPXTRO-1,fa%JPXLAT)
fa%JPSEC4=100
fa%JPXPAR=500

fa%XLAP1D  => null() 
fa%XLAP1DA => null()
fa%XLAP2D  => null() 
fa%XLAP2DA => null()

ALLOCATE (                                                       &
& fa%CTNPRF (fa%JPTNIV),        fa%NIVDSC (0:4,0:fa%JPTNIV),     &
& fa%CADRE  (fa%JPNXCA),        fa%FICHIER (0:fa%JPNXFA),        &
& fa%NULIND (fa%JPNXFA),        fa%NCAIND (fa%JPNXCA),           &
& stat = kerr )
IF (kerr /= 0) GOTO 999

fa%FACADE_LLPREA = .true.
fa%FACAGE_LLPREA = .true.
fa%FACIES_LLPREA = .true.
fa%FACTUM_LLPREA = .true.
fa%FAGIOT_LLPREA = .true.
fa%FALIMU_LLPREA = .true.
fa%FAMISO_LLPREA = .true.
fa%FANERG_LLPREA = .true.
fa%FANMSG_LLPREA = .true.
fa%FANUCA_LLPREA = .true.
fa%FANUMU_LLPREA = .true.
fa%FAREGI_LLPREA = .true.
fa%FARFLU_LLPREA = .true.
fa%FARINE_LLPREA = .true.
fa%FAVORI_LLPREA = .true.
fa%FAXION_LLPREA = .true.
fa%FARINE_LLDEFM = .false.
fa%NULOUT        = 0
fa%LOPENMP       = .true.

999 CONTINUE

IF (lhook) CALL dr_hook ('FA_COM:NEW_FA',1,zhook_handle)

END SUBROUTINE new_fa

SUBROUTINE free_fa (FA, KERR)
TYPE(fa_com) :: FA
INTEGER, INTENT(OUT) :: KERR

INTEGER (KIND=JPLIKB) :: ICAD, IFIC

REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FA_COM:FREE_FA',0,zhook_handle)

IF (ASSOCIATED (fa%XLAP1D  )) DEALLOCATE (fa%XLAP1D  )
IF (ASSOCIATED (fa%XLAP1DA )) DEALLOCATE (fa%XLAP1DA )
IF (ASSOCIATED (fa%XLAP2D  )) DEALLOCATE (fa%XLAP2D  )
IF (ASSOCIATED (fa%XLAP2DA )) DEALLOCATE (fa%XLAP2DA )

NULLIFY (fa%XLAP1D  )
NULLIFY (fa%XLAP1DA )
NULLIFY (fa%XLAP2D  )
NULLIFY (fa%XLAP2DA )

DEALLOCATE (               &
& fa%NIVDSC,  fa%CTNPRF,   &
& stat = kerr )
IF (kerr /= 0) GOTO 999

NULLIFY (fa%NIVDSC,  fa%CTNPRF)


IF (ASSOCIATED (fa%YGR1TAB)) THEN
  DEALLOCATE (fa%YGR1TAB, stat = kerr)
  IF (kerr /= 0) GOTO 999
  NULLIFY (fa%YGR1TAB)
ENDIF

DO icad = 1, int(ubound(fa%CADRE, 1), jplikb)
  CALL free_cadre (fa%CADRE (icad))
ENDDO

DO ific = 0, int(ubound(fa%FICHIER, 1), jplikb)
  CALL free_fichier (fa%FICHIER (ific))
ENDDO

DEALLOCATE (fa%CADRE, fa%FICHIER, stat = kerr)
NULLIFY (fa%CADRE, fa%FICHIER)

999 CONTINUE

IF (lhook) CALL dr_hook ('FA_COM:FREE_FA',1,zhook_handle)

END SUBROUTINE free_fa


SUBROUTINE cparams (KPXLAT, KPXTRO, &
&   KPXAU1, KPXLON, KPXAU2, KPXPAH, &
&   KPXIND, KPXGEO, KPXCSP, KPXPDG, &
&   KPXCHA)

INTEGER (KIND=JPLIKB), INTENT (IN)  :: KPXLAT, KPXTRO
INTEGER (KIND=JPLIKB), INTENT (OUT) :: &
&      KPXAU1, KPXLON, KPXAU2, KPXPAH, &
&      KPXIND, KPXGEO, KPXCSP, KPXPDG, &
&      KPXCHA

kpxau1=(1+kpxlat)/2 
kpxlon=2*kpxlat 
kpxau2=(2*kpxtro)+4 
kpxpah=(8*(8/kpxau1)+kpxau1*(kpxau1/8))    &
&          /((8/kpxau1)+(kpxau1/8)) 
kpxind=(kpxau1*(kpxau1/kpxau2)+kpxau2*     &
&         (kpxau2/kpxau1))                 &
&         /((kpxau1/kpxau2)+(kpxau2/kpxau1)) 
kpxgeo=(12*(12/kpxau1)+kpxau1*(kpxau1/12)) &
&          /((12/kpxau1)+(kpxau1/12)) 
kpxcsp=(1+kpxtro)*(2+kpxtro) 
kpxpdg=kpxlon*kpxlat 
kpxcha=(kpxcsp*(kpxcsp/kpxpdg)+            &
&         kpxpdg*(kpxpdg/kpxcsp))          &
&         /((kpxcsp/kpxpdg)+(kpxpdg/kpxcsp)) 
END SUBROUTINE cparams

END MODULE fa_mod