farine.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE farine_fort             &
&                     (fa,  koptio )
USE fa_mod, ONLY : fa_com, jpniil
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        Ce sous-programme est charge des INITIALISATIONS du logiciel
!     de Fichiers ARPEGE FA ( Routine d'INitialisation )
!**
!        Argument : KOPTIO  ==> OPTION concernant le mode d'utilisation.
!                  (Entree)     (MULTI-TACHE ou NON)
!     VALEURS POSSIBLES : 0 ==> Mode MONO-Tache prescrit;
!                         1 ==> Mode MULTI-Taches prescrit;
!                         2 ==> Utilisation du mode par defaut si c'est
!                               le premier appel; sinon on garde le mode
!                               prescrit anterieurement .
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KOPTIO
!
INTEGER (KIND=JPLIKB) IREP, J
INTEGER (KIND=JPLIKB) INIMES, INUMER
!
LOGICAL LLNMUL, LLASGN, LLREL
!
!
CHARACTER(LEN=FA%JPXNOM) CLACTI 
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FARINE_MT',0,zhook_handle)
clacti=''
IF (koptio.LT.0.OR.koptio.GT.2) THEN
  irep=-52
  GOTO 1001
ENDIF
!
IF (fa%FARINE_LLPREA) THEN
!
!         C'EST LE PREMIER APPEL AU sous-programme - INITIALISATIONS .
!
  fa%NFIOUV=0
  fa%NCADEF=0
  fa%NRFAGA=1
  fa%NIMSGA=1
  fa%NBIPDG=24
  fa%NBICSP=24
  fa%NPUILA=1
  fa%NSTROI=10
  fa%NMIDPL=5
  fa%NIGRIB=2
  fa%LFAMOP=.false.
  fa%FICHIER(0)%LERRFA=.true.
  fa%FICHIER(0)%NIVOMS=0
  fa%NCPCAD=len(fa%CADRE(1)%CNOMCA)
  fa%SPSMIN=60000._jpdblr
  fa%SPSMAX=110000._jpdblr
  fa%MPRESX=100000
  fa%NBIMAC=64
  fa%NBIMAX=31
  fa%LIGARD=.false.
  fa%NTYPTX=2
  fa%NXNIVV=fa%JPXNIV
  fa%NXTRON=fa%JPXTRO
  fa%NXLATI=fa%JPXLAT
  fa%NXLONG=fa%JPXLON
!
  DO j=1,fa%JPNXFA
    fa%FICHIER(j)%NULOGI=jpniil
    fa%FICHIER(j)%NRASHO=0
    fa%FICHIER(j)%NRASVE=0
  ENDDO
!
  DO j=1,fa%JPNXCA
    fa%CADRE(j)%CNOMCA=' '
  ENDDO
!
  DO j=1,fa%JPXNOM
    fa%CHAINC(j:j)='?'
  ENDDO
!
!        Descripteurs lies aux types de niveaux verticaux:
!        prefixes reconnus, extrema possibles du niveau dans le cas
!        d'une coordonnee verticale, premiers elements de xB1PAR.
!
  DO j=0,fa%JPTNIV
!
!       Initialisation par defaut pour la serie d'affectations qui suit.
!
    fa%NIVDSC(0,j)=0
    fa%NIVDSC(1,j)=0
    fa%NIVDSC(2,j)=0
!
!        Tous les cas sont reputes "niveau vrai" (pas des couches).
!
    fa%NIVDSC(4,j)=0
  ENDDO
!
!           Cas du type non reconnu.
!
  fa%NIVDSC(0,0)=0
  fa%NIVDSC(3,0)=200
!
!           Niveau hybride.
!
  fa%CTNPRF(1)='S'
  fa%NIVDSC(0,1)=3
  fa%NIVDSC(2,1)=fa%JPXNIV
  fa%NIVDSC(3,1)=109
!
!           Niveau isobare.
!
  fa%CTNPRF(2)='P'
  fa%NIVDSC(0,2)=5
  fa%NIVDSC(1,2)=1
  fa%NIVDSC(2,2)=10**5
  fa%NIVDSC(3,2)=100
!
!           Niveau iso-hauteur (au-dessus d'un relief de reference).
!
  fa%CTNPRF(3)='H'
  fa%NIVDSC(0,3)=5
  fa%NIVDSC(2,3)=10**5-1
  fa%NIVDSC(3,3)=105
!
!           Niveau iso-tourbillon_potentiel.
!
  fa%CTNPRF(4)='V'
  fa%NIVDSC(0,4)=3
  fa%NIVDSC(2,4)=10**3-1
  fa%NIVDSC(3,4)=117
!
!           Niveau iso-temperature_potentielle.
!
  fa%CTNPRF(5)='T'
  fa%NIVDSC(0,5)=3
  fa%NIVDSC(2,5)=10**3-1
  fa%NIVDSC(3,5)=113
!
!           Niveau surface.
!
  fa%CTNPRF(6)='SURF'
  fa%NIVDSC(3,6)=1
!
!           Niveau de vent max (jet).
!
  fa%CTNPRF(7)='JET'
  fa%NIVDSC(3,7)=6
!
!           Niveau surface.
!
  fa%CTNPRF(8)='TROPO'
  fa%NIVDSC(3,8)=7
!
!           Niveau moyen de la mer.
!
  fa%CTNPRF(9)='MER'
  fa%NIVDSC(3,9)=102
!
!           Niveau hybride bis pour MOCAGE
!
  fa%CTNPRF(10)='L'
  fa%NIVDSC(0,10)=3
  fa%NIVDSC(2,10)=fa%JPXNIV
!  
!           Niveau iso-temperature.
!
  fa%CTNPRF(11)='KB'
  fa%NIVDSC(0,11)=3
  fa%NIVDSC(2,11)=10**3-1
  fa%NIVDSC(3,11)=113
!
  fa%CTNPRF(12)='KT'
  fa%NIVDSC(0,12)=3
  fa%NIVDSC(2,12)=10**3-1
  fa%NIVDSC(3,12)=113
!
!           Niveau iso-hauteur (au-dessus du niveau moyen de la mer).
!
  fa%CTNPRF(13)='F'
  fa%NIVDSC(0,13)=4
  fa%NIVDSC(2,13)=10**4-1
  fa%NIVDSC(3,13)=103
!
!           Niveau SURFEX
!
  fa%CTNPRF(14)='X'
  fa%NIVDSC(0,14)=3
  fa%NIVDSC(2,14)=10**3-1
  fa%NIVDSC(3,14)=113

!
!  Initialisations pour la mise en oeuvre de GRIBEX
!
!  1/ On force GRIBEX a calculer la puissance de laplacien
!  CALL GRSMKP(1)
!  2/ On retire l'arrondi du message GRIB a un multiple de 120 octets
!  CALL GRSRND(0)
!
!  3/ Creation de la correspondance "nom article FA" et
!                                   "descripteurs GRIBEX"
  IF (.NOT. ASSOCIATED (fa%YGR1TAB)) THEN
    CALL faicor_fort (fa)
  ENDIF
!
!
!  4/ Definition du codage GRIBEX par defaut:
!
!  Il s'agit d'une compression "APAC1" (meilleure solution entre
!  l'absence de compression et la compression ligne a ligne)
!  associee a la compression "general extended", a la differentiation
!  spatiale (-1: calcul dynamique de l'ordre) et au rearrangement
!  boustrophedonique.
!
!  "APAC1"
  fa%NCODGRI(1) = 1
  fa%NCODGRI(2) = 16
  fa%NCODGRI(3) = 0
  fa%NCODGRI(4) = 0
  fa%NCODGRI(5) = 16
  fa%NCODGRI(6) = 0
!  compression "general extended"
  fa%NCODGRI(7) = 8
!  arrangement boustrophedonique
  fa%NCODGRI(8) = 4
!  differentiation spatiale
  fa%NCODGRI( 9)= 0
  fa%NCODGRI(10)= -1
! Calcul automatique du facteur d'echelle decimal (KSEC1 (23))
  fa%NCODGRI(11)= 1
! Ecriture des champs GRIB1 dans un fichier externe
  fa%NCODGRI(12)= 0
!
!  5/ Initialisation de logiques pilotant des initialisations ulterieures
!
!  Il faudra initialiser XLAPxDx
  fa%LIXLAP=.true.
!  Il ne faut pas initialiser FLAP1Dx(): on attend l'ouverture du fichier
  fa%FICHIER(:)%LIFLAP=.false.
!  Il faudra initialiser le tableau FA%NSEC1 (section 1 GRIBEX) via FAISC1
  fa%FICHIER(:)%LISEC1=.true.
!  Il faudra initialiser les tableaux NSEC2xxx et FA%XSEC2
!  (section 2 GRIBEX) via FAISC2
  fa%CADRE(:)%LISEC2=.true.
!  Il faudra initialiser le tableau FA%NSC2ALF
!  (section 2 GRIBEX) via FAIS2F
  fa%FICHIER(:)%LISC2F=.true.
!
  fa%FARINE_LLPREA=.false.
  llnmul=(koptio.EQ.1).OR.(koptio.EQ.2.AND.fa%FARINE_LLDEFM)
  llasgn=llnmul
  llrel=.false.
  CALL lfiini_fort               &
&                (fa%LFI, koptio)
!
ELSEIF (koptio.EQ.2) THEN
!
!         CE N'EST PAS LE PREMIER APPEL, MAIS COMME L'ARGUMENT VAUT 2,
!         ON LAISSE LES CHOSES EN PLACE .
!
  llnmul=fa%LFAMUL
  llasgn=.false.
  llrel =.false.
!
ELSE
  llnmul=koptio.EQ.1
  llasgn=llnmul.AND.(.NOT.fa%LFAMUL)
  llrel =(.NOT.llnmul).AND.fa%LFAMUL
!
!     CE N'EST PAS LE PREMIER APPEL ET LE MODE EST PASSE 'EXPLICITEMENT'
!
  IF ((llasgn.OR.llrel).AND.fa%NFIOUV.NE.0) THEN
    irep=-54
    GOTO 1001
  ENDIF
!
  CALL lfiini_fort               &
&                (fa%LFI, koptio)
!
ENDIF
!
fa%LFAMUL=llnmul
irep=0
!
IF (llasgn) THEN
  CALL lfiver_fort                          &
&                 (fa%LFI, fa%VRGLAS,'ASGN')
ELSEIF (llrel) THEN
  CALL lfiver_fort                         &
&                 (fa%LFI, fa%VRGLAS,'REL')
ENDIF
!
1001 CONTINUE
!
!        MESSAGERIE EVENTUELLE, AVEC ABORT SI NECESSAIRE .
!
llfata=irep.NE.0.AND.fa%NRFAGA.NE.2
!
IF (llfata.OR.fa%LFAMOP) THEN
  inimes=2
ELSEIF (irep.NE.0) THEN
  inimes=0
ELSEIF (fa%NIMSGA.EQ.2) THEN
  inimes=2
ELSE
  IF (lhook) CALL dr_hook('FARINE_MT',1,zhook_handle)
  RETURN
ENDIF
!
clnspr='FARINE'
inumer=jpniil
!
IF (max(inimes,fa%NIMSGA).EQ.2) THEN
  WRITE (unit=clmess,                                  &
&         fmt='(''KOPTIO='',I5,'', CODE INTERNE='',I4)' &
&         ) koptio,irep
  IF (inimes.NE.2) CALL faipar_fort                          &
&                                  (fa, inumer,fa%NIMSGA,irep, &
&                                .false.,clmess,               &
&                                clnspr,clacti,.false.)
ENDIF
!
CALL faipar_fort                                     &
&               (fa, inumer,inimes,irep,llfata,clmess, &
&             clnspr,clacti,.false.)
!
IF (lhook) CALL dr_hook('FARINE_MT',1,zhook_handle)
END SUBROUTINE farine_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE farine64           &
&           (koptio)
USE fa_mod, ONLY : fa => fa_com_default, &
&                   fa_com_default_init,  &
&                   new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKB)  KOPTIO                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL farine_fort           &
&           (fa, koptio)

END SUBROUTINE farine64

SUBROUTINE farine             &
&           (koptio)
USE fa_mod, ONLY : fa => fa_com_default, &
&                   fa_com_default_init,  &
&                   new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKM)  KOPTIO                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL farine_mt             &
&           (fa, koptio)

END SUBROUTINE farine

SUBROUTINE farine_mt             &
&           (fa, koptio)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
! Arguments
type(fa_com)          fa                                     ! INOUT
INTEGER (KIND=JPLIKM)  KOPTIO                                 ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IOPTIO                                 ! IN   
! Convert arguments

ioptio     = int(    koptio, jplikb)

CALL farine_fort           &
&           (fa, ioptio)


END SUBROUTINE farine_mt

!INTF KOPTIO        IN