fanouv.F90

Go to the documentation of this file.

! Feb-2013 P. Marguinaud fix uninitialized output variable
! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
! Sep-2012 P. Marguinaud Remove unused local variables
SUBROUTINE fanouv_fort                                             &
&                     (fa, krep, knumer, ldnomm, cdnomf, cdsttu,   &
&                      lderfa, ldimst, knimes, knbarp, knbari,     &
&                      cdnomc)
USE fa_mod, ONLY : fa_com, new_fichier, jpniil
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        Sous-programme d'initialisation SANS OUVERTURE d'une unite logique 
!        "Fichier ARPEGE". Il s'agit d'un fichier indexe, 
!        traite par le logiciel LFI.
!
!      FANOUV est derive de FAITOU, mais ne fait pas l'appel a la couche LFI
!             pour l'ouverture reelle.
!
!      utilise pour la seule compression des donnees par des processeurs
!      qui ne font pas d'ecriture effective sur disque
!
!**
!     ARGUMENTS : Ce sont les memes que pour "LFIOUV", avec CDNOMC comme
!                 argument supplementaire.
!
!                 KREP   (Sortie) ==> Code-reponse du sous-programme;
!                 KNUMER (Entree) ==> Numero de l'unite logique;
!                 LDNOMM (Entree) ==> Vrai si l'unite logique doit etre
!                                     associee a un NOM de Fichier EXP-
!                                     LICITE lors de l'"OPEN" FORTRAN;
!                 CDNOMF (Entree) ==> Nom de fichier explicite, si
!                                     *LDNOMM* est VRAI - Meme si ce
!                                     n'est pas le cas, ce *DOIT* ETRE
!                                     UN OBJET DE TYPE "CHARACTER" .
!                 CDSTTU (Entree) ==> "STATUS" pour l'"OPEN" FORTRAN
!                                     ('OLD','NEW','UNKNOWN','SCRATCH')
!                                     par defaut, mettre 'UNKNOWN';
!                 LDERFA (Entree) ==> Option d'erreur fatale;
!                 LDIMST (Entree) ==> Option impression de Statistiques
!                                     au moment de la fermeture;
!                 KNIMES (Entree) ==> Niveau de la Messagerie (0,1 ou 2)
!                                     ( 0==>Rien, 2==>Tout )
!                 KNBARP (Entree) ==> Nombre d'articles logiques prevus,
!                                     ce qui n'est utilise que lors de
!                                     la Creation du fichier,
!                                     et qui n'empeche quand meme pas
!                                     d'avoir plus d'articles logiques;
!                 KNBARI (Sortie) ==> Nombre d'articles logiques de don-
!                                     nees sur le fichier, initialement.
!                                     (zero si creation)
!                 CDNOMC (Entree) ==> Nom du CADRE associe au fichier.
!*
!     N.B. :  Pour un fichier en mode creation, ce cadre doit avoir ete
!          defini au prealable (via le sous-programme FACADE, ou par
!          l'ouverture d'un fichier preexistant).
!             Pour un fichier ARPEGE preexistant, le cadre est lu sur le
!          fichier; s'il etait deja defini auparavant, il y a controle
!          de coherence entre les deux versions du cadre.
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KREP, KNUMER, KNIMES, KNBARP, KNBARI
!
INTEGER (KIND=JPLIKB) IRANG, IRANMS, IREPOU
INTEGER (KIND=JPLIKB) ILNOMC, ILOMIN, IREP, J
INTEGER (KIND=JPLIKB) IRANER, IRANGC
INTEGER (KIND=JPLIKB) ITRONC, ILACTI, INIMES
INTEGER (KIND=JPLIKB) ITYPTR, IPUILA
!
INTEGER (KIND=JPLIKB) IDATEF (fa%jpldat)
!
LOGICAL LDNOMM, LDERFA, LDIMST, LLNOUF, LLNOUC, LLRLFI
!
CHARACTER CDNOMF*(*), CDSTTU*(*), CDNOMC*(*)
!
CHARACTER(LEN=FA%JPXNOM) CLACTI 
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!**
!     1.  -  CONTROLES DIVERS
!-----------------------------------------------------------------------
!
!     Controle sommaire sur les arguments...
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FANOUV_MT',0,zhook_handle)
knbari=0
clacti=''
irang=0
iraner=0
iranms=0
irepou=jpniil
llrlfi=.false.
ilnomc=int(len(cdnomc), jplikb)
ilomin=min( int(len(cdnomf), jplikb),         &
&             int(len(cdsttu), jplikb), ilnomc)
!
!        L'appel ci-dessous est legerement anticipe, de maniere a
!     initialiser les variables globales du logiciel s'il s'agit
!     du premier appel a un sous-programme de ce logiciel.
!
CALL fanumu_fort                 &
&               (fa, knumer,irang)
!        Si KNUMER est nul, alors le numero d'unite logique est
!     attribué automatiquement
IF (knumer == 0) THEN
  CALL faauto_fort  (fa, knumer, .false.)
  irang=0
ENDIF
!
IF (ilomin.LE.0) THEN
  irep=-65
  GOTO 1001
ELSEIF (irang.NE.0) THEN
!
!            Controle de non-ouverture prealable (au sens du logiciel)
!
  irep=-55
  iranms=irang
  GOTO 1001
ENDIF
!
!             Verrouillage global, si necessaire.
!
!        A-t-on deja atteint le nombre limite de fichiers ARPEGE
!     ouverts simultanement ? Si non, on cherche un emplacement libre
!     dans la table FA%NULOGI (logiquement, il devrait en exister un)
!
IF (fa%NFIOUV.GE.fa%JPNXFA) THEN
  irep=-56
  GOTO 1001
ELSE
!
  DO j=1,fa%JPNXFA
!
  IF (fa%FICHIER(j)%NULOGI.EQ.jpniil) THEN
    irang=j
    GOTO 102
  ENDIF
!
  ENDDO
!
  irep=-66
  GOTO 1001
!
102 CONTINUE
!
ENDIF
!
!**
!     2.  -  CONTROLES SPECIFIQUES AU LOGICIEL DE FICHIERS ARPEGE.
!-----------------------------------------------------------------------
!
llnouf=knbari.EQ.0
CALL fanuca_fort                          &
&               (fa, cdnomc,irangc,.false.)
llnouc=irangc.EQ.0
!
IF (llnouf) THEN
!
  IF (llnouc) THEN
    irep=-57
    GOTO 1001
  ELSE
!
!         Fichier en mode creation et cadre predefini... OK a ce niveau.
!
!       On ecrit les articles definissant le cadre sur le fichier,
!     ainsi qu'un article ayant pour nom l'identificateur "par defaut",
!     (en fait, le nom du cadre) de maniere a ce que cet article soit
!     sequentiellement celui qui suit le dernier article du cadre.
!
    ilnomc=fa%CADRE(irangc)%NLCCAD
!
  ENDIF
!
ENDIF

itronc=fa%CADRE(irangc)%MTRONC
ityptr=fa%CADRE(irangc)%NTYPTR

CALL new_fichier (fa, fa%FICHIER(irang), fa%JPLDAT, itronc, ityptr)

!*
!        Controle de la Date fichier, et stockage dans FA%MADATE.
!
!  IDATEF arbitraire pour contenter FACOND
idatef(1) = 1993
idatef(2) = 9
idatef(3) = 2
idatef(4) = 0
idatef(5) = 0
idatef(6) = 1
idatef(7) = 0
idatef(8) = 0
idatef(9) = 1
idatef(10) = 0
idatef(11) = 0

DO j=1,fa%JPLDAT
  fa%FICHIER(irang)%MADATE(j)=idatef(j)
ENDDO

fa%FICHIER(irang)%MADATX (:) = 0

!**
!     3.  -  ON MET A JOUR LES TABLES RELATIVES AUX FICHIERS.
!-----------------------------------------------------------------------
!
!
irepou=0
!
!
fa%NFIOUV=fa%NFIOUV+1
fa%NULIND(fa%NFIOUV)=irang
fa%FICHIER(irang)%NULOGI=knumer
fa%FICHIER(irang)%NUCADR=irangc
!
fa%FICHIER(irang)%LNOMME=ldnomm
fa%FICHIER(irang)%NIVOMS=knimes
fa%FICHIER(irang)%LERRFA=lderfa
fa%FICHIER(irang)%LCREAF=.false.
fa%FICHIER(irang)%NBFPDG=fa%NBIPDG
fa%FICHIER(irang)%NBFCSP=fa%NBICSP
fa%FICHIER(irang)%NPUFLA=fa%NPUILA
fa%FICHIER(irang)%NMFDPL=fa%NMIDPL
fa%FICHIER(irang)%NFGRIB=fa%NIGRIB
fa%FICHIER(irang)%CIDENT=cdnomc
!
IF (ityptr.LT.0) THEN
  fa%FICHIER(irang)%NSTROF=min(fa%NSTROI,itronc-1,-ityptr-1)
ELSE
  fa%FICHIER(irang)%NSTROF=min(fa%NSTROI,itronc-1)
ENDIF
!
! Appel a FAINOC pour interpreter les eventuels defauts
! de -1 pris par FA%NBFPDG, FA%NBFCSP, FA%NSTROF et FA%NPUFLA en
! IRANG-ieme position.
!
CALL fainoc_fort            &
&               (fa,  irang )
!
iraner=irang
iranms=irang
ipuila=fa%FICHIER(irang)%NPUFLA
!
fa%FICHIER(irang)%NCOGRIF(:)=fa%NCODGRI(:)
fa%FICHIER(irang)%NRASHO = 0
fa%FICHIER(irang)%NRASVE = 0
!
!   L'initialisation de FLAP1Dx sera faite dans FACSIM
!
fa%FICHIER(irang)%LIFLAP=.true.
!
!        On incremente le nombre de fichiers attaches au cadre specifie.
!
fa%CADRE(irangc)%NULCAD=fa%CADRE(irangc)%NULCAD+1
irep=irepou
GOTO 1001
!**
!     9.  - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
!-----------------------------------------------------------------------
!
clacti='INQUIRE'
!
!      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
!
irep=abs(irep)
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE SOUS-PROGRAMME "LFIEMS" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
krep=irep
llfata=llmoer(irep,iraner)
!
IF (llfata) THEN
  inimes=2
ELSE
  inimes=ixnvms(iranms)
ENDIF
!
IF (.NOT.llfata.AND.inimes.EQ.0)  THEN 
  IF (lhook) CALL dr_hook('FANOUV_MT',1,zhook_handle)
  RETURN
ENDIF
!
clnspr='FANOUV'
!
IF (inimes.EQ.2) THEN
!
  IF (ilnomc.GT.0) THEN
    ilacti=min(int(len(clacti), jplikb),ilnomc)
    clacti(1:ilacti)=cdnomc(1:ilnomc)
  ELSE
    ilacti=8
    clacti=fa%CHAINC(:ilacti)
  ENDIF
!
  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KNUMER='',I3,          &
&     '', LDNOMM= '',L1,'', CDSTTU='''''',A7,'''''', LDERFA= '',L1, &
&     '',  LDIMST= '',L1,                                           &
&         '', KNIMES='',I2,'', KNBARP='',I6,'' KNBARI='',I6)')      &
&   krep,knumer,ldnomm,cdsttu,lderfa,ldimst,knimes,knbarp,knbari
  CALL faipar_fort                                      &
&                 (fa, knumer,inimes,irep,.false.,clmess, &
&                  clnspr,clacti(1:ilacti),llrlfi)
  clmess='CDNOMC='''//clacti(1:ilacti)//''''
  CALL faipar_fort                                     &
&                 (fa, knumer,inimes,irep,llfata,clmess, &
&               clnspr,                                  &
&               clacti(1:ilacti),llrlfi)
ENDIF
!
IF (lhook) CALL dr_hook('FANOUV_MT',1,zhook_handle)

CONTAINS

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

END SUBROUTINE fanouv_fort




! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE fanouv64                                      &
&           (krep, knumer, ldnomm, cdnomf, cdsttu, lderfa, &
&           ldimst, knimes, knbarp, knbari, cdnomc)
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
INTEGER (KIND=JPLIKB)  KNUMER                                 ! IN   
LOGICAL                LDNOMM                                 ! IN   
CHARACTER (LEN=*)      CDNOMF                                 ! IN   
CHARACTER (LEN=*)      CDSTTU                                 ! IN   
LOGICAL                LDERFA                                 ! IN   
LOGICAL                LDIMST                                 ! IN   
INTEGER (KIND=JPLIKB)  KNIMES                                 ! IN   
INTEGER (KIND=JPLIKB)  KNBARP                                 ! IN   
INTEGER (KIND=JPLIKB)  KNBARI                                 !   OUT
CHARACTER (LEN=*)      CDNOMC                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fanouv_fort                                             &
&           (fa, krep, knumer, ldnomm, cdnomf, cdsttu, lderfa, &
&           ldimst, knimes, knbarp, knbari, cdnomc)

END SUBROUTINE fanouv64

SUBROUTINE fanouv                                        &
&           (krep, knumer, ldnomm, cdnomf, cdsttu, lderfa, &
&           ldimst, knimes, knbarp, knbari, cdnomc)
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
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
LOGICAL                LDNOMM                                 ! IN   
CHARACTER (LEN=*)      CDNOMF                                 ! IN   
CHARACTER (LEN=*)      CDSTTU                                 ! IN   
LOGICAL                LDERFA                                 ! IN   
LOGICAL                LDIMST                                 ! IN   
INTEGER (KIND=JPLIKM)  KNIMES                                 ! IN   
INTEGER (KIND=JPLIKM)  KNBARP                                 ! IN   
INTEGER (KIND=JPLIKM)  KNBARI                                 !   OUT
CHARACTER (LEN=*)      CDNOMC                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fanouv_mt                                               &
&           (fa, krep, knumer, ldnomm, cdnomf, cdsttu, lderfa, &
&           ldimst, knimes, knbarp, knbari, cdnomc)

END SUBROUTINE fanouv

SUBROUTINE fanouv_mt                                         &
&           (fa, krep, knumer, ldnomm, cdnomf, cdsttu, lderfa, &
&           ldimst, knimes, knbarp, knbari, cdnomc)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
! Arguments
type(fa_com)          fa                                     ! INOUT
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
LOGICAL                LDNOMM                                 ! IN   
CHARACTER (LEN=*)      CDNOMF                                 ! IN   
CHARACTER (LEN=*)      CDSTTU                                 ! IN   
LOGICAL                LDERFA                                 ! IN   
LOGICAL                LDIMST                                 ! IN   
INTEGER (KIND=JPLIKM)  KNIMES                                 ! IN   
INTEGER (KIND=JPLIKM)  KNBARP                                 ! IN   
INTEGER (KIND=JPLIKM)  KNBARI                                 !   OUT
CHARACTER (LEN=*)      CDNOMC                                 ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  INUMER                                 ! IN   
INTEGER (KIND=JPLIKB)  INIMES                                 ! IN   
INTEGER (KIND=JPLIKB)  INBARP                                 ! IN   
INTEGER (KIND=JPLIKB)  INBARI                                 !   OUT
! Convert arguments

inumer     = int(    knumer, jplikb)
inimes     = int(    knimes, jplikb)
inbarp     = int(    knbarp, jplikb)

CALL fanouv_fort                                             &
&           (fa, irep, inumer, ldnomm, cdnomf, cdsttu, lderfa, &
&           ldimst, inimes, inbarp, inbari, cdnomc)

krep       = int(      irep, jplikm)
knbari     = int(    inbari, jplikm)

IF (knumer == 0) THEN
  knumer = int(    inumer, jplikm)
ENDIF

END SUBROUTINE fanouv_mt



!INTF KREP            OUT 
!INTF KNUMER        IN    
!INTF LDNOMM        IN    
!INTF CDNOMF        IN    
!INTF CDSTTU        IN    
!INTF LDERFA        IN    
!INTF LDIMST        IN    
!INTF KNIMES        IN    
!INTF KNBARP        IN    
!INTF KNBARI          OUT 
!INTF CDNOMC        IN