facil1.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE facil1_fort                                             &
&                     (fa,  krep, knumer, cdpref, knivau, cdsuff,  &
&                      pchamp, ldcosp, ldundf, pundf, ydgr1tab)
USE fa_mod, ONLY : fa_com, fagr1tab
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Sous-programme de LECTURE d'un CHAMP HORIZONTAL sur un fichier
!     ARPEGE.
!       ( Champ d'Interet en LEcture )
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                KNUMER (Entree) ==> Numero de l'unite logique;
!                CDPREF (Entree) ==> Prefixe eventuel du nom d'article;
!                KNIVAU (Entree) ==> Niveau vertical eventuel;
!                CDSUFF (Entree) ==> Suffixe eventuel du nom d'article;
!    ( Tableau ) PCHAMP (Sortie) ==> Valeurs REELLES du champ lu;
!                LDCOSP (Entree) ==> Vrai si le champ est represente
!                                    par des coefficients spectraux.
!                LDUNDF (Sortie) ==> Vrai si ce champ a des valeurs 
!                                    indefinies
!                PUNDF  (Sortie) ==> Dans le cas ou LDUNDF est vrai,
!                                    valeur non definie
!     MODIF:
!     JM AUDOIN GMAP/EXT 10/05/95 intro de IVALC3 pour eviter ecrasement
!     D  PARADIS TTI/DEV 12/10/98 partie controle et decodage de l'article
!                                 demenagee dans un ss-prg a usage interne
!                                 du logiciel (FADECI).
!     D  PARADIS DSI/DEV 15/04/04 nettoyage code + declaration IVALCO en
!                                 ALLOCATABLE
!
!
TYPE(fa_com) :: FA
TYPE(fagr1tab) :: YDGR1TAB
INTEGER (KIND=JPLIKB) KREP, KNUMER, KNIVAU
!
INTEGER (KIND=JPLIKB) IREP, ILPRFU, ILSUFU, ILNOMU
INTEGER (KIND=JPLIKB) ILONGA, IRANG, INIMES
INTEGER (KIND=JPLIKB) ILPREF, ILSUFF, IPOSEX, IRANGC
!
REAL (KIND=JPDBLR) PCHAMP (*)
REAL (KIND=JPRB) PUNDF
INTEGER (KIND=JPLIKB), ALLOCATABLE :: IVALCO(:)
INTEGER (KIND=JPLIKB) IB1PAR (fa%jplb1p)
!
LOGICAL LLVERF, LLRLFI, LDCOSP, LLNOMU, LDUNDF
!
CHARACTER CDPREF*(*), CDSUFF*(*)
CHARACTER CLPREF*(fa%jpxnom), CLSUFF*(fa%jpxsuf)
!
CHARACTER(LEN=FA%JPXNOM) CLNOMA
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA
!**
!     1.  -  CONTROLES ET INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FACIL1_MT',0,zhook_handle)

llverf=.false.
llrlfi=.false.
llnomu=.false.
ilprfu=int(len(cdpref), jplikb)
ilsufu=int(len(cdsuff), jplikb)
CALL fanumu_fort                 &
&               (fa, knumer,irang)
!
IF (irang.EQ.0) THEN
  irep=-51
  GOTO 1001
ENDIF
!
!         Verrouillage eventuel du fichier.
!
IF (fa%LFAMUL) CALL lfiver_fort                               &
&                              (fa%LFI, fa%FICHIER(irang)%VRFICH,'ON')
llverf=fa%LFAMUL
!
IF (fa%FICHIER(irang)%LCREAF) THEN
  irep=-85
  GOTO 1001
ENDIF
!**
!     2.  -  FABRICATION DU NOM D'ARTICLE VIA LE SOUS-PROGRAMME "FANFAR"
!            ( controles de CDPREF, KNIVAU, CDSUFF inclus )
!-----------------------------------------------------------------------
!
CALL fanfar_fort                                             &
&               (fa, irep,irang,cdpref,knivau,cdsuff,clnoma, &
&                ib1par(6),ilprfu,ilsufu,ilnomu)
IF (irep.NE.0) GOTO 1001
llnomu=.true.
!**
!     3.  -  LECTURE DE L'ARTICLE SUR LE FICHIER
!-----------------------------------------------------------------------
!
CALL lfinfo_fort                                       &
&               (fa%LFI, irep,knumer,clnoma(1:ilnomu), &
&                ilonga,iposex)
!
IF (irep.NE.0) THEN
  llrlfi=.true.
  GOTO 1001
ELSEIF (ilonga.EQ.0) THEN
  irep=-89
  GOTO 1001
ELSEIF (ilonga.GT.fa%JPXCHA+2) THEN
  irep=-90
  GOTO 1001
ENDIF
!
ALLOCATE (ivalco(ilonga))
CALL lfilec_fort                                       &
&               (fa%LFI, irep,knumer,clnoma(1:ilnomu), &
&               ivalco,ilonga)
llrlfi=irep.NE.0
IF (llrlfi) GOTO 1001
!
!**
!     4.  -  CONTROLES ET DECODAGE DE L'ARTICLE
!----------------------------------------------
!
!  Controle de l'homogeneite du type de rangement de coeff. spectraux
!  parmi les champs lus/ecrits: ces champs compactes avec
!  FA%NIGRIB=-1 ou 3 doivent etre ranges comme dans le modele ("verticalement"
!  soit selon des colonnes JM=cst consecutives) et contrairement si compactes
!  avec FA%NIGRIB= 0,1 ou 2.
! 
irangc=fa%FICHIER(irang)%NUCADR
IF (ldcosp) THEN
  IF (ivalco(1).EQ.-1.OR.ivalco(1).EQ.3) THEN
    fa%FICHIER(irang)%NRASVE=fa%FICHIER(irang)%NRASVE+1
    IF (fa%FICHIER(irang)%NRASVE.EQ.1.AND.fa%FICHIER(irang)%NRASHO.GT.0) THEN
      WRITE(fa%NULOUT,*)                                 &
&      '------------------------------------------------'
      WRITE(fa%NULOUT,*)' FACIL1 :  WARNING !!!!!           '
      WRITE(fa%NULOUT,*)' Un champ de coeff. spectraux avec'
      WRITE(fa%NULOUT,*)                            &
&      ' rangement type modele va etre lu alors que'
      WRITE(fa%NULOUT,*)                                &
&      ' d''autres champs spec. ont un rangt different.'
      WRITE(fa%NULOUT,*)                                 &
&      ' ***  Prenez en compte cette heterogeneite!  ***'
      WRITE(fa%NULOUT,*)                                 &
&      '------------------------------------------------'
    ENDIF
  ELSEIF (ivalco(1).GE.0.AND.ivalco(1).LE.2) THEN
    fa%FICHIER(irang)%NRASHO=fa%FICHIER(irang)%NRASHO+1
    IF (fa%FICHIER(irang)%NRASHO.EQ.1.AND.fa%FICHIER(irang)%NRASVE.GT.0) THEN
      WRITE(fa%NULOUT,*)                                 &
&      '------------------------------------------------'
      WRITE(fa%NULOUT,*)' FACIL1 :  WARNING !!!!!           '
      WRITE(fa%NULOUT,*)' Un champ de coeff. spectraux avec'
      WRITE(fa%NULOUT,*)                                &
&      ' rangement autre que celui du modele va etre lu'
      WRITE(fa%NULOUT,*)                                &
&      ' alors que d''autres champs ont le rangt modele'
      WRITE(fa%NULOUT,*)                                 &
&      ' ***  Prenez en compte cette heterogeneite!  ***'
      WRITE(fa%NULOUT,*)                                 &
&      '------------------------------------------------'
    ENDIF
  ENDIF
ENDIF
!
IF (falgra(ivalco(1))) THEN
! Cas d'un champ gribe avec GRIB_API
  CALL fadgra_fort                             &
&                 (fa, irep,irang,clnoma,      &
&                  ivalco,ilonga,pchamp,ldcosp,&
&                  cdpref, knivau, cdsuff,     &
&                  ldundf, pundf)
ELSEIF (ivalco(1).EQ.3) THEN
! Cas d'un champ gribe avec GRIBEX
  CALL fadecx_fort                             &
&                 (fa, irep,irang,clnoma,      &
&                  ivalco,ilonga,pchamp,ldcosp,&
&                  cdpref, knivau, cdsuff,     &
&                  ldundf, pundf, ydgr1tab)
ELSEIF (ivalco(1).EQ.4) THEN
  CALL fadcpl_fort                             &
&                 (fa, irep,irang,clnoma,      &
&                  ivalco,ilonga,pchamp,ldcosp,&
&                  ldundf, pundf)
ELSE
  CALL fadeci_fort                             &
&                 (fa, irep,irang,clnoma,      &
&                  ivalco,ilonga,pchamp,ldcosp)
ENDIF
!
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE SOUS-PROGRAMME "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
IF (ALLOCATED( ivalco )) DEALLOCATE ( ivalco )
krep=irep
llfata=llmoer(irep,irang)
!
!        Deverrouillage eventuel du fichier.
!
IF (llverf) CALL lfiver_fort                                &
&                           (fa%LFI, fa%FICHIER(irang)%VRFICH,'OFF')

IF (llfata) THEN
  inimes=2
ELSE
  inimes=ixnvms(irang)
ENDIF
!
IF (.NOT.llfata.AND.inimes.NE.2)  THEN 
  IF (lhook) CALL dr_hook('FACIL1_MT',1,zhook_handle)
  RETURN
ENDIF
!
clnspr='FACIL1'
!
IF (ilprfu.GE.1) THEN
  ilpref=min(ilprfu,int(len(clpref), jplikb))
  clpref(1:ilpref)=cdpref(1:ilpref)
ELSE
  ilpref=8
  clpref(1:ilpref)=fa%CHAINC(:ilpref)
ENDIF
!
IF (ilsufu.GE.1) THEN
  ilsuff=min(ilsufu,int(len(clsuff), jplikb))
  clsuff(1:ilsuff)=cdsuff(1:ilsuff)
ELSE
  ilsuff=8
  clsuff(1:ilsuff)=fa%CHAINC(:ilsuff)
ENDIF
!
IF (.NOT.llnomu) THEN
  ilnomu=min(ilpref,fa%NCPCAD)
  clnoma(1:ilnomu)=clpref(1:ilpref)
ENDIF
!
WRITE (unit=clmess,fmt='(''KREP='',I5,'', KNUMER='',I3,        &
&       '', CDPREF='''''',A,'''''', KNIVAU='',I6,               &
&       '', CDSUFF='''''',A,'''''', LDCOSP= '',L1)')            &
&   krep,knumer,clpref(1:ilpref),knivau,clsuff(1:ilsuff),ldcosp
CALL faipar_fort                                     &
&               (fa, knumer,inimes,irep,llfata,clmess, &
&                clnspr, clnoma(1:ilnomu),llrlfi)
!
IF (lhook) CALL dr_hook('FACIL1_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"
#include "facom2.ixnvms.h"
#include "falgra.h"

END SUBROUTINE facil1_fort