SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/FA/mt/fanouv

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FANOUV_MT (FA,  KREP, KNUMER, LDNOMM, CDNOMF, CDSTTU, 
00003      S                      LDERFA,
00004      S                     LDIMST, KNIMES, KNBARP, KNBARI, CDNOMC )
00005       USE FA_MOD, ONLY : FA_COM
00006       USE PARKIND1, ONLY : JPRB
00007       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00008 C****
00009 C        Sous-programme d'initialisation SANS OUVERTURE d'une unite logique 
00010 C        "Fichier ARPEGE". Il s'agit d'un fichier indexe, 
00011 C        traite par le logiciel LFI.
00012 C
00013 C      FANOUV est derive de FAITOU, mais ne fait pas l'appel a la couche LFI
00014 C             pour l'ouverture reelle.
00015 C
00016 C      utilise pour la seule compression des donnees par des processeurs
00017 C      qui ne font pas d'ecriture effective sur disque
00018 C
00019 C**
00020 C     ARGUMENTS : Ce sont les memes que pour "LFIOUV", avec CDNOMC comme
00021 C                 argument supplementaire.
00022 C
00023 C                 KREP   (Sortie) ==> Code-reponse du sous-programme;
00024 C                 KNUMER (Entree) ==> Numero de l'unite logique;
00025 C                 LDNOMM (Entree) ==> Vrai si l'unite logique doit etre
00026 C                                     associee a un NOM de Fichier EXP-
00027 C                                     LICITE lors de l'"OPEN" FORTRAN;
00028 C                 CDNOMF (Entree) ==> Nom de fichier explicite, si
00029 C                                     *LDNOMM* est VRAI - Meme si ce
00030 C                                     n'est pas le cas, ce *DOIT* ETRE
00031 C                                     UN OBJET DE TYPE "CHARACTER" .
00032 C                 CDSTTU (Entree) ==> "STATUS" pour l'"OPEN" FORTRAN
00033 C                                     ('OLD','NEW','UNKNOWN','SCRATCH')
00034 C                                     par defaut, mettre 'UNKNOWN';
00035 C                 LDERFA (Entree) ==> Option d'erreur fatale;
00036 C                 LDIMST (Entree) ==> Option impression de Statistiques
00037 C                                     au moment de la fermeture;
00038 C                 KNIMES (Entree) ==> Niveau de la Messagerie (0,1 ou 2)
00039 C                                     ( 0==>Rien, 2==>Tout )
00040 C                 KNBARP (Entree) ==> Nombre d'articles logiques prevus,
00041 C                                     ce qui n'est utilise que lors de
00042 C                                     la Creation du fichier,
00043 C                                     et qui n'empeche quand meme pas
00044 C                                     d'avoir plus d'articles logiques;
00045 C                 KNBARI (Sortie) ==> Nombre d'articles logiques de don-
00046 C                                     nees sur le fichier, initialement.
00047 C                                     (zero si creation)
00048 C                 CDNOMC (Entree) ==> Nom du CADRE associe au fichier.
00049 C*
00050 C     N.B. :  Pour un fichier en mode creation, ce cadre doit avoir ete
00051 C          defini au prealable (via le sous-programme FACADE, ou par
00052 C          l'ouverture d'un fichier preexistant).
00053 C             Pour un fichier ARPEGE preexistant, le cadre est lu sur le
00054 C          fichier; s'il etait deja defini auparavant, il y a controle
00055 C          de coherence entre les deux versions du cadre.
00056 C
00057 #include "precision.h"
00058 C
00059 C
00060       TYPE(FA_COM) :: FA
00061       INTEGER KREP, KNUMER, KNIMES, KNBARP, KNBARI
00062 C
00063       CHARACTER CPNOMD*(*)
00064       PARAMETER ( CPNOMD='%%%%% FICHIER SANS NOM %%%%%' )
00065 C
00066       INTEGER IRANG, INUMER, IRANMS, IREPOU, ILNOMC, ILOMIN, IREP, J
00067       INTEGER INBARP, IRANER, IRANGC
00068       INTEGER ILONGA, ITRONC, ILACTI, INIMES, INXLON
00069       INTEGER ITYPTR, IPHASE, IGARDE, IPOSEX, IPUILA
00070 C
00071       INTEGER IDATEF (FA%JPLDAT)
00072       INTEGER (KIND=JPDBLE) ILDIMEN(FA%JPCADI),
00073      S                      ILRDPOL(FA%JPXPAH+FA%JPXIND)
00074       INTEGER (KIND=JPDBLE) ILPNVER, ILDATEF(FA%JPLDAT)
00075 C
00076       LOGICAL LDNOMM, LDERFA, LDIMST, LLNOUF, LLNOUC, LLRLFI
00077       LOGICAL LLMODC, LLREDF, LLMODA
00078 C
00079       CHARACTER CDNOMF*(*), CDSTTU*(*), CDNOMC*(*)
00080 C
00081 #include "facom2.h"
00082 #include "facom_mt.h"
00083 C**
00084 C     1.  -  CONTROLES DIVERS
00085 C-----------------------------------------------------------------------
00086 C
00087 C     Controle sommaire sur les arguments...
00088 C
00089       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00090       IF (LHOOK) CALL DR_HOOK('FANOUV_MT',0,ZHOOK_HANDLE)
00091       IRANG=0
00092       IRANER=0
00093       IRANMS=0
00094       IREPOU=FA%JPNIIL
00095       LLRLFI=.FALSE.
00096       ILNOMC=LEN (CDNOMC)
00097       ILOMIN=MIN ( LEN (CDNOMF), LEN (CDSTTU), ILNOMC)
00098 C
00099 C        L'appel ci-dessous est legerement anticipe, de maniere a
00100 C     initialiser les variables globales du logiciel s'il s'agit
00101 C     du premier appel a un sous-programme de ce logiciel.
00102 C
00103       CALL FANUMU_MT (FA, KNUMER,IRANG)
00104 C
00105       IF (ILOMIN.LE.0) THEN
00106         IREP=-65
00107         GOTO 1001
00108       ELSEIF (IRANG.NE.0) THEN
00109 C
00110 C            Controle de non-ouverture prealable (au sens du logiciel)
00111 C
00112         IREP=-55
00113         IRANMS=IRANG
00114         GOTO 1001
00115       ENDIF
00116 C
00117 C             Verrouillage global, si necessaire.
00118 C
00119 C        A-t-on deja atteint le nombre limite de fichiers ARPEGE
00120 C     ouverts simultanement ? Si non, on cherche un emplacement libre
00121 C     dans la table FA%NULOGI (logiquement, il devrait en exister un)
00122 C
00123       IF (FA%NFIOUV.GE.FA%JPNXFA) THEN
00124         IREP=-56
00125         GOTO 1001
00126       ELSE
00127 C
00128         DO 101 J=1,FA%JPNXFA
00129 C
00130         IF (FA%NULOGI(J).EQ.FA%JPNIIL) THEN
00131           IRANG=J
00132           GOTO 102
00133         ENDIF
00134 C
00135   101   CONTINUE
00136 C
00137         IREP=-66
00138         GOTO 1001
00139 C
00140   102   CONTINUE
00141 C
00142       ENDIF
00143 C
00144 C**
00145 C     2.  -  CONTROLES SPECIFIQUES AU LOGICIEL DE FICHIERS ARPEGE.
00146 C-----------------------------------------------------------------------
00147 C
00148       LLNOUF=KNBARI.EQ.0
00149       CALL FANUCA_MT (FA, CDNOMC,IRANGC,.FALSE.)
00150       LLNOUC=IRANGC.EQ.0
00151 C
00152       IF (LLNOUF) THEN
00153 C
00154         IF (LLNOUC) THEN
00155           IREP=-57
00156           GOTO 1001
00157         ELSE
00158 C
00159 C         Fichier en mode creation et cadre predefini... OK a ce niveau.
00160 C
00161 C       On ecrit les articles definissant le cadre sur le fichier,
00162 C     ainsi qu'un article ayant pour nom l'identificateur "par defaut",
00163 C     (en fait, le nom du cadre) de maniere a ce que cet article soit
00164 C     sequentiellement celui qui suit le dernier article du cadre.
00165 C
00166           ILNOMC=FA%NLCCAD(IRANGC)
00167 C
00168         ENDIF
00169 C
00170       ENDIF
00171 C*
00172 C        Controle de la Date fichier, et stockage dans FA%MADATE.
00173 C
00174 !  IDATEF arbitraire pour contenter FACOND
00175       IDATEF(1) = 1993
00176       IDATEF(2) = 9
00177       IDATEF(3) = 2
00178       IDATEF(4) = 0
00179       IDATEF(5) = 0
00180       IDATEF(6) = 1
00181       IDATEF(7) = 0
00182       IDATEF(8) = 0
00183       IDATEF(9) = 1
00184       IDATEF(10) = 0
00185       IDATEF(11) = 0
00186 
00187       DO J=1,FA%JPLDAT
00188         FA%MADATE(J,IRANG)=IDATEF(J)
00189       ENDDO
00190 
00191 C**
00192 C     3.  -  ON MET A JOUR LES TABLES RELATIVES AUX FICHIERS.
00193 C-----------------------------------------------------------------------
00194 C
00195   300 CONTINUE
00196 !
00197       IREPOU=0
00198 !
00199 C
00200       FA%NFIOUV=FA%NFIOUV+1
00201       FA%NULIND(FA%NFIOUV)=IRANG
00202       FA%NULOGI(IRANG)=KNUMER
00203       FA%NUCADR(IRANG)=IRANGC
00204 C
00205       FA%LNOMME(IRANG)=LDNOMM
00206       FA%NIVOMS(IRANG)=KNIMES
00207       FA%LERRFA(IRANG)=LDERFA
00208       FA%LCREAF(IRANG)=.FALSE.
00209       FA%NBFPDG(IRANG)=FA%NBIPDG
00210       FA%NBFCSP(IRANG)=FA%NBICSP
00211       FA%NPUFLA(IRANG)=FA%NPUILA
00212       FA%NMFDPL(IRANG)=FA%NMIDPL
00213       FA%NFGRIB(IRANG)=FA%NIGRIB
00214       FA%CIDENT(IRANG)=CDNOMC
00215       ITRONC=FA%MTRONC(IRANGC)
00216       ITYPTR=FA%NTYPTR(IRANGC)
00217 C
00218       IF (ITYPTR.LT.0) THEN
00219         FA%NSTROF(IRANG)=MIN (FA%NSTROI,ITRONC-1,-ITYPTR-1)
00220       ELSE
00221         FA%NSTROF(IRANG)=MIN (FA%NSTROI,ITRONC-1)
00222       ENDIF
00223 C
00224 C Appel a FAINOC pour interpreter les eventuels defauts
00225 C de -1 pris par FA%NBFPDG, FA%NBFCSP, FA%NSTROF et FA%NPUFLA en
00226 C IRANG-ieme position.
00227 C
00228       CALL FAINOC_MT (FA,  IRANG )
00229 C
00230       IRANER=IRANG
00231       IRANMS=IRANG
00232       IPUILA=FA%NPUFLA(IRANG)
00233 C
00234       FA%NCOGRIF(:,IRANG)=FA%NCODGRI(:)
00235       FA%NRASHO(IRANG) = 0
00236       FA%NRASVE(IRANG) = 0
00237 C
00238 C   L'initialisation de FLAP1Dx sera faite dans FACSIM
00239 C
00240       FA%LIFLAP(IRANG)=.TRUE.
00241 C
00242 C        On incremente le nombre de fichiers attaches au cadre specifie.
00243 C
00244       FA%NULCAD(IRANGC)=FA%NULCAD(IRANGC)+1
00245       IREP=IREPOU
00246       GOTO 1001
00247 C**
00248 C     9.  - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
00249 C-----------------------------------------------------------------------
00250 C
00251   901 CONTINUE
00252       CLACTI='INQUIRE'
00253 C
00254 C      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
00255 C
00256       IREP=IABS (IREP)
00257 C**
00258 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00259 C            VIA LE SOUS-PROGRAMME "LFIEMS" .
00260 C-----------------------------------------------------------------------
00261 C
00262  1001 CONTINUE
00263       KREP=IREP
00264       LLFATA=LLMOER (IREP,IRANER)
00265 C
00266       IF (LLFATA) THEN
00267         INIMES=2
00268       ELSE
00269         INIMES=IXNVMS (IRANMS)
00270       ENDIF
00271 C
00272       IF (.NOT.LLFATA.AND.INIMES.EQ.0)  THEN 
00273         IF (LHOOK) CALL DR_HOOK('FANOUV_MT',1,ZHOOK_HANDLE)
00274         RETURN
00275       ENDIF
00276 C
00277       CLNSPR='FANOUV'
00278 C
00279       IF (INIMES.EQ.2) THEN
00280 C
00281         IF (ILNOMC.GT.0) THEN
00282           ILACTI=MIN (LEN (CLACTI),ILNOMC)
00283           CLACTI(1:ILACTI)=CDNOMC(1:ILNOMC)
00284         ELSE
00285           ILACTI=8
00286           CLACTI=FA%CHAINC(:ILACTI)
00287         ENDIF
00288 C
00289         WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='
00290 ',I3,     S     '', LDNOMM= '',L1,'', CDSTTU='''''',A7,'''''', LDERFA= '
00291 ',L1,     S     '',  LDIMST= '
00292 ',L1,     S         '', KNIMES='',I2,'', KNBARP='',I6,'' KNBARI='',I6)')
00293      S   KREP,KNUMER,LDNOMM,CDSTTU,LDERFA,LDIMST,KNIMES,KNBARP,KNBARI
00294         CALL FAIPAR_MT (FA, KNUMER,INIMES,IREP,.FALSE.,CLMESS,
00295      S                  CLNSPR,CLACTI(1:ILACTI),LLRLFI)
00296         CLMESS='CDNOMC='''//CLACTI(1:ILACTI)//''''
00297         CALL FAIPAR_MT (FA, KNUMER,INIMES,IREP,LLFATA,CLMESS,
00298      S               CLNSPR,
00299      S               CLACTI(1:ILACTI),LLRLFI)
00300       ENDIF
00301 C
00302       IF (LHOOK) CALL DR_HOOK('FANOUV_MT',1,ZHOOK_HANDLE)
00303       END
00304