SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/LFI/mt/lfiecr

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe LFI
00002       SUBROUTINE LFIECR_MT (LFI, KREP, KNUMER, CDNOMA, KTAB, KLONG )
00003       USE LFIMOD, ONLY : LFICOM
00004       USE PARKIND1, ONLY : JPRB
00005       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00006 C****
00007 C        SOUS-PROGRAMME D'ECRITURE D'UN ARTICLE (DE DONNEES) SUR UNE
00008 C     UNITE LOGIQUE OUVERTE POUR LE LOGICIEL DE FICHIERS INDEXES LFI;
00009 C     L'ARTICLE DOIT ETRE UN "BLOC" DE DONNEES ADJACENTES.
00010 C**
00011 C    ARGUMENTS : KREP   (SORTIE) ==> CODE-REPONSE DU SOUS-PROGRAMME;
00012 C                KNUMER (ENTREE) ==> LFI%NUMERO DE L'UNITE LOGIQUE;
00013 C                CDNOMA (ENTREE) ==> NOM DE L'ARTICLE A ECRIRE;
00014 C                KTAB   (ENTREE) ==> PREMIER MOT A ECRIRE
00015 C                KLONG  (ENTREE) ==> LONGUEUR DE L'ARTICLE A ECRIRE.
00016 C
00017 #ifndef f77
00018 #include "precision.h"
00019 #endif
00020 C
00021       TYPE(LFICOM) :: LFI
00022       CHARACTER CDNOMA*(*), CLNOMA*(LFI%JPNCPN)
00023 C
00024       INTEGER KREP, KNUMER, KLONG
00025 #ifndef f77
00026       INTEGER (KIND=JPDBLE)  KTAB (KLONG)
00027 #else
00028       INTEGER KTAB (KLONG)
00029 #endif
00030       INTEGER IRANG, IREP, ILCLNO, IDECBL, IPOSBL, INBALO, INBPIR
00031       INTEGER IFACTM, ILARPH, INALPP, IRPIEX, IARTEX, ILONEX, IRPIEC
00032       INTEGER IARTEC, IPOSEC, IDTROU, ILONUT, INPPIM, IRETIN, IRGPI, J
00033       INTEGER IRGPIM, ILFORC, INPILE, INAPHY, IRANGM, INAPXX, INDMAX
00034       INTEGER IMDESC, INIMES, ILCDNO
00035 C
00036       LOGICAL LLLECT, LLECR, LLVERF
00037 C
00038 #include "lficom2.h"
00039 #include "lficom_mt.h"
00040 C**
00041 C     1.  -  CONTROLES DES PARAMETRES D'APPEL, PUIS INITIALISATIONS.
00042 C-----------------------------------------------------------------------
00043 C
00044 C        Appel legerement anticipe a LFINUM, garantissant l'initialisa-
00045 C     tion des variables globales du logiciel a la 1ere utilisation.
00046 C
00047       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00048       IF (LHOOK) CALL DR_HOOK('LFIECR_MT',0,ZHOOK_HANDLE)
00049       CALL LFINUM_MT (LFI, KNUMER,IRANG)
00050       LLVERF=.FALSE.
00051       ILCDNO=LEN (CDNOMA)
00052 C
00053       IF (ILCDNO.LE.0) THEN
00054         IREP=-15
00055         CLNOMA=LFI%CHINCO(:LFI%JPNCPN)
00056         ILCLNO=LFI%JPNCPN
00057         GOTO 1001
00058       ELSEIF (CDNOMA.EQ.' ') THEN
00059         IREP=-18
00060         CLNOMA=' '
00061         ILCLNO=1
00062         GOTO 1001
00063       ENDIF
00064 C
00065 C        Recherche de la longueur "utile" du nom d'article specifie.
00066 C        (c'est-a-dire sans tenir compte des blancs terminaux eventuels)
00067 C
00068       IDECBL=0
00069 C
00070   101 CONTINUE
00071       IPOSBL=IDECBL+INDEX (CDNOMA(IDECBL+1:),' ')
00072 C
00073       IF (IPOSBL.LE.IDECBL) THEN
00074         ILCLNO=ILCDNO
00075       ELSEIF (CDNOMA(IPOSBL:).EQ.' ') THEN
00076         ILCLNO=IPOSBL-1
00077       ELSE
00078         IDECBL=IPOSBL
00079         GOTO 101
00080       ENDIF
00081 C
00082       IF (ILCLNO.LE.LFI%JPNCPN) THEN
00083         CLNOMA=CDNOMA(:ILCLNO)
00084       ELSE
00085         CLNOMA=CDNOMA(:LFI%JPNCPN)
00086         ILCLNO=LFI%JPNCPN
00087         IREP=-15
00088         GOTO 1001
00089       ENDIF
00090 C
00091       IF (KLONG.LE.0) THEN
00092         IREP=-14
00093         GOTO 1001
00094       ELSEIF (IRANG.EQ.0) THEN
00095         IREP=-1
00096         GOTO 1001
00097       ENDIF
00098 C
00099        IF (LFI%LMULTI) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'ON')
00100       LLVERF=LFI%LMULTI
00101 C
00102       IF (LFI%NEXPOR(IRANG).GT.0) THEN
00103 C
00104 C         Fichier en cours d'export... ne devant donc pas etre modifie.
00105 C
00106         IREP=-37
00107         GOTO 1001
00108       ENDIF
00109 C
00110       LLLECT=.TRUE.
00111       LLECR =.FALSE.
00112       INBALO=LFI%MDES1D(IXM(LFI%JPNALO,IRANG))
00113       INBPIR=LFI%MDES1D(IXM(LFI%JPNPIR,IRANG))
00114       IFACTM=LFI%MFACTM(IRANG)
00115       ILARPH=LFI%JPLARD*IFACTM
00116       INALPP=LFI%JPNAPP*IFACTM
00117 C**
00118 C     2.  -  EXPLORATION DES (PAIRES DE) PAGES ET ARTICLES D'INDEX,
00119 C            A LA RECHERCHE DE L'ARTICLE LOGIQUE ET/OU D'UN "TROU"
00120 C            DANS L'INDEX, SUFFISANT POUR Y "CASER" LEDIT ARTICLE.
00121 C-----------------------------------------------------------------------
00122 C
00123       INAPHY=0
00124       CALL LFIREE_MT (LFI, IREP,IRANG,CLNOMA(:ILCLNO),KLONG,IRPIEX,
00125      S                IARTEX, ILONEX,IRPIEC,IARTEC,IPOSEC,
00126      S                IDTROU,ILONUT,IRETIN)
00127 C
00128       IF (IRETIN.EQ.1) THEN
00129         GOTO 903
00130       ELSEIF (IRETIN.EQ.2) THEN
00131         GOTO 904
00132       ELSEIF (IRETIN.NE.0) THEN
00133         GOTO 1001
00134       ENDIF
00135 C
00136       INPPIM=LFI%NPPIMM(IRANG)
00137 C
00138       IF (IARTEX.NE.0.AND.LFI%NEXPOR(IRANG).GT.0) THEN
00139 C
00140 C         Fichier en cours d'export... la seule modification acceptee
00141 C         est l'ajout de nouveaux articles.
00142 C
00143         IREP=-37
00144         GOTO 1001
00145       ENDIF
00146 C**
00147 C     3.  -   PARTIE ECRITURE DES DONNEES .
00148 C-----------------------------------------------------------------------
00149 C
00150       CALL LFIECD_MT (LFI, IREP,IRANG,KTAB,KLONG,IPOSEC,IRETIN)
00151 C
00152       IF (IRETIN.EQ.1) THEN
00153         GOTO 903
00154       ELSEIF (IRETIN.EQ.2) THEN
00155         GOTO 904
00156       ELSEIF (IRETIN.NE.0) THEN
00157         GOTO 1001
00158       ENDIF
00159 C**
00160 C     4.  -   MODIFICATION(S) EVENTUELLE(S) DE L'INDEX.
00161 C-----------------------------------------------------------------------
00162 C
00163       IF (IARTEX.NE.0.AND.IARTEC.NE.IARTEX) THEN
00164 C*
00165 C     4.1 - CAS OU L'ON CREE UN TROU DANS L'INDEX.
00166 C-----------------------------------------------------------------------
00167 C
00168 C           RECHERCHE OU MISE EN MEMOIRE DE L'ARTICLE D'INDEX "NOMS"
00169 C        CONTENANT LES CARACTERISTIQUES DE L'ARTICLE LOGIQUE
00170 C        QUE L'ON "TROUE".
00171 C
00172         DO 411 J=1,INPPIM
00173         IRGPI=LFI%MRGPIM(J,IRANG)
00174 C
00175         IF (LFI%MRGPIF(IRGPI).EQ.IRPIEX) THEN
00176           IRGPIM=IRGPI
00177           GOTO 413
00178         ENDIF
00179 C
00180   411   CONTINUE
00181 C
00182         ILFORC=1
00183         INPILE=1
00184         INAPHY=0
00185         CALL LFIPIM_MT (LFI, IREP,IRANG,IRANGM,IRGPIM,IRPIEX,
00186      S                  ILFORC,INPILE, IRETIN)
00187 C
00188         IF (IRETIN.EQ.1) THEN
00189           GOTO 903
00190         ELSEIF (IRETIN.EQ.2) THEN
00191           GOTO 904
00192         ELSEIF (IRETIN.NE.0) THEN
00193           GOTO 1001
00194         ENDIF
00195 C
00196         INPPIM=MAX0 (INPPIM,IRANGM)
00197 C
00198   413   CONTINUE
00199         LFI%CNOMAR(IXC(IARTEX,IRGPIM))=' '
00200         LFI%LECRPI(IRGPIM,1)=.TRUE.
00201 C
00202         IF (ILONEX.NE.ILONUT) THEN
00203 C
00204 C           STOCKAGE DE LA LONGUEUR TOTALE UTILISABLE DU TROU .
00205 C         DANS CE CAS, ON EST SUR QUE LA PAGE D'INDEX "LONG./POS."
00206 C         EST TOUJOURS PHASEE.
00207 C
00208           LFI%MLGPOS(IXM(2*IARTEX-1,IRGPIM))=ILONUT
00209           LFI%LECRPI(IRGPIM,2)=.TRUE.
00210         ENDIF
00211 C
00212       ENDIF
00213 C
00214       IF (INALPP*(IRPIEC-1)+IARTEC.GT.INBALO) THEN
00215 C*
00216 C     4.2 - CAS OU L'ON A CREE UN ARTICLE LOGIQUE SUPPLEMENTAIRE.
00217 C-----------------------------------------------------------------------
00218 C
00219         LFI%MDES1D(IXM(LFI%JPNALO,IRANG))=INBALO+1
00220 C
00221         IF (INBALO.NE.0.AND.IARTEC.EQ.1) THEN
00222 C
00223 C             ON DOIT CREER UNE P.A.I. SUPPLEMENTAIRE.
00224 C
00225           IF (IRPIEC.GT.INBPIR) THEN
00226 C
00227 C             CETTE NOUVELLE P.A.I. EST "EXCEDENTAIRE".
00228 C             RECHERCHE DU PREMIER ARTICLE PHYSIQUE DISPONIBLE
00229 C             POUR Y ECRIRE (ULTERIEUREMENT) CETTE P.A.I. EXCEDENTAIRE.
00230 C             LE CONTROLE DE DEPASSEMENT DE CAPACITE DE L'INDEX
00231 C             DU FICHIER A ETE FAIT DANS LE SOUS-PROGRAMME *LFIREE*.
00232 C
00233             INAPXX=LFI%MDES1D(IXM(LFI%JPAXPD,IRANG))
00234             INDMAX=LFI%JPNIL
00235 C
00236             DO 421 J=0,LFI%JPNPDF-1
00237 C
00238             IF (LFI%NUMAPD(J,IRANG).GT.INAPXX) THEN
00239               INAPXX=LFI%NUMAPD(J,IRANG)
00240               INDMAX=J
00241             ENDIF
00242 C
00243   421       CONTINUE
00244 C
00245             IF (IRPIEC.GT.(INBPIR+1)) THEN
00246               IMDESC=LFI%MDES1D(IXM(ILARPH+2-IRPIEC+INBPIR,IRANG))
00247               INAPXX=MAX0 (INAPXX,IMDESC+1)
00248             ENDIF
00249 C
00250             LFI%MDES1D(IXM(ILARPH+1-IRPIEC+INBPIR,IRANG))=INAPXX+1
00251 C
00252 C      L'ON A AUSSI CREE, EN GENERAL, UNE ZONE "PERDUE" (MAIS NEANMOINS
00253 C     REUTILISABLE DANS UNE CERTAINE MESURE) A LA FIN DU DERNIER
00254 C     ARTICLE PHYSIQUE DES DONNEES QUE L'ON VIENT D'ECRIRE.
00255 C           IL EST ALORS NECESSAIRE DE "COMPLETER" LA ZONE PERDUE,
00256 C     POUR NE PAS AVOIR DE PROBLEME ULTERIEUR DANS *LFIECX*.
00257 C
00258             IF (INDMAX.NE.LFI%JPNIL) THEN
00259 C
00260               DO 423 J=LFI%NLONPD(INDMAX,IRANG)+1,ILARPH
00261               LFI%MTAMPD(IXT(J,INDMAX,IRANG))=0
00262   423         CONTINUE
00263 C
00264               LFI%NLONPD(INDMAX,IRANG)=ILARPH
00265             ENDIF
00266 C
00267           ENDIF
00268 C
00269           ILFORC=1
00270           INPILE=0
00271           INAPHY=0
00272           CALL LFIPIM_MT (LFI, IREP,IRANG,IRANGM,IRGPIM,IRPIEC,
00273      S                    ILFORC,INPILE, IRETIN)
00274 C
00275           IF (IRETIN.EQ.1) THEN
00276             GOTO 903
00277           ELSEIF (IRETIN.EQ.2) THEN
00278             GOTO 904
00279           ELSEIF (IRETIN.NE.0) THEN
00280             GOTO 1001
00281           ENDIF
00282 C
00283           LFI%NPODPI(IRANG)=IRANGM
00284 C
00285 C           REMARQUE: LA DERNIERE P.P.I. EST TOUJOURS "PHASEE".
00286 C
00287           LFI%LPHASP(IRGPIM)=.TRUE.
00288         ELSE
00289           IRGPIM=LFI%MRGPIM(LFI%NPODPI(IRANG),IRANG)
00290         ENDIF
00291 C
00292         LFI%NALDPI(IRANG)=IARTEC
00293         LFI%CNOMAR(IXC(IARTEC,IRGPIM))=CLNOMA(:ILCLNO)
00294         LFI%MLGPOS(IXM(2*IARTEC-1,IRGPIM))=KLONG
00295         LFI%MLGPOS(IXM(2*IARTEC  ,IRGPIM))=IPOSEC
00296         LFI%LECRPI(IRGPIM,1)=.TRUE.
00297         LFI%LECRPI(IRGPIM,2)=.TRUE.
00298 C
00299       ELSEIF (IARTEX.EQ.0.OR.KLONG.NE.ILONEX) THEN
00300 C*
00301 C     4.3 - CAS OU L'ON REUTILISE UN ARTICLE OU TROU QUI EXISTAIT
00302 C           AU PREALABLE, EN MODIFIANT SES CARACTERISTIQUES DE NOM ET/OU
00303 C           DE LONGUEUR.
00304 C-----------------------------------------------------------------------
00305 C
00306         DO 431 J=1,INPPIM
00307         IRGPI=LFI%MRGPIM(J,IRANG)
00308 C
00309         IF (LFI%MRGPIF(IRGPI).EQ.IRPIEC) THEN
00310           IRANGM=J
00311           IRGPIM=IRGPI
00312 C
00313 C           L'ARTICLE D'INDEX "NOMS" CORRESPONDANT EST EN MEMOIRE...
00314 C       PHASAGE EVENTUEL DE LA PAGE D'INDEX "LONG/POS" .
00315 C
00316           INAPHY=0
00317 C
00318           IF (.NOT.LFI%LPHASP(IRGPIM)) THEN
00319 C
00320             CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPIM,IRETIN)
00321 C
00322             IF (IRETIN.EQ.1) THEN
00323               GOTO 903
00324             ELSEIF (IRETIN.EQ.2) THEN
00325               GOTO 904
00326             ELSEIF (IRETIN.NE.0) THEN
00327               GOTO 1001
00328             ENDIF
00329 C
00330           ENDIF
00331 C
00332           GOTO 434
00333         ENDIF
00334 C
00335   431   CONTINUE
00336 C
00337 C            ARTICLE D'INDEX CORRESPONDANT NON PRESENT EN MEMOIRE...
00338 C         ON L'Y AMENE.
00339 C
00340         ILFORC=1
00341         INPILE=2
00342         INAPHY=0
00343         CALL LFIPIM_MT (LFI, IREP,IRANG,IRANGM,IRGPIM,IRPIEC,
00344      S                  ILFORC,INPILE, IRETIN)
00345 C
00346         IF (IRETIN.EQ.1) THEN
00347           GOTO 903
00348         ELSEIF (IRETIN.EQ.2) THEN
00349           GOTO 904
00350         ELSEIF (IRETIN.NE.0) THEN
00351           GOTO 1001
00352         ENDIF
00353 C
00354   434   CONTINUE
00355 C
00356         IF (IARTEC.NE.IARTEX.OR.IRPIEC.NE.IRPIEX) THEN
00357           LFI%CNOMAR(IXC(IARTEC,IRGPIM))=CLNOMA(:ILCLNO)
00358           LFI%LECRPI(IRGPIM,1)=.TRUE.
00359         ENDIF
00360 C
00361         LFI%MLGPOS(IXM(2*IARTEC-1,IRGPIM))=KLONG
00362         LFI%LECRPI(IRGPIM,2)=.TRUE.
00363 C
00364       ENDIF
00365 C**
00366 C     5.  -   MISE A JOUR: STATISTIQUES, TABLES, PAGE DOCUMENTAIRE.
00367 C-----------------------------------------------------------------------
00368 C
00369       IF (IARTEX.EQ.0) THEN
00370         LFI%NBNECR(IRANG)=LFI%NBNECR(IRANG)+1
00371       ELSEIF (KLONG.EQ.ILONEX) THEN
00372         LFI%NREESP(IRANG)=LFI%NREESP(IRANG)+1
00373       ELSEIF (KLONG.LT.ILONEX) THEN
00374         LFI%NREECO(IRANG)=LFI%NREECO(IRANG)+1
00375         LFI%LMIMAL(IRANG)=LFI%LMIMAL(IRANG).OR.
00376      S                ILONEX.EQ.LFI%MDES1D(IXM(LFI%JPLXAL,IRANG))
00377       ELSE
00378         LFI%NREELO(IRANG)=LFI%NREELO(IRANG)+1
00379         LFI%LMIMAL(IRANG)=LFI%LMIMAL(IRANG).OR.
00380      S                ILONEX.EQ.LFI%MDES1D(IXM(LFI%JPLNAL,IRANG))
00381       ENDIF
00382 C
00383       LFI%NBTROU(IRANG)=LFI%NBTROU(IRANG)+IDTROU
00384       IF (LFI%LMISOP) WRITE (UNIT=LFI%NULOUT,FMT=*)
00385      S        'IDTROU = ',IDTROU,', ILONEX = ',ILONEX,', KLONG = ',KLONG
00386 C
00387 C        On met a jour ce qui a trait aux acces pseudo-sequentiels...
00388 C
00389       LFI%NDERGF(IRANG)=INALPP*(IRPIEC-1)+IARTEC
00390       LFI%CNDERA(IRANG)=CLNOMA(:ILCLNO)
00391       LFI%NSUIVF(IRANG)=LFI%JPNIL
00392       LFI%NPRECF(IRANG)=LFI%JPNIL
00393 C
00394       IMDESC=LFI%MDES1D(IXM(LFI%JPLNAL,IRANG))
00395       LFI%MDES1D(IXM(LFI%JPLNAL,IRANG))=MIN0 (IMDESC,KLONG)
00396       IMDESC=LFI%MDES1D(IXM(LFI%JPLXAL,IRANG))
00397       LFI%MDES1D(IXM(LFI%JPLXAL,IRANG))=MAX0 (IMDESC,KLONG)
00398       LFI%MDES1D(IXM(LFI%JPLTAL,IRANG))=
00399      S             LFI%MDES1D(IXM(LFI%JPLTAL,IRANG))+KLONG-ILONEX
00400       IF (INBALO.EQ.0) LFI%MDES1D(IXM(LFI%JPLNAL,IRANG))=KLONG
00401 C
00402       IF (.NOT.LFI%LMODIF(IRANG)) THEN
00403 C
00404 C         CAS DE LA PREMIERE ECRITURE DEPUIS L'OUVERTURE DU FICHIER.
00405 C
00406         LFI%LMODIF(IRANG)=.TRUE.
00407         INAPHY=0
00408         CALL LFIMOE_MT (LFI, IREP,IRANG,IRETIN)
00409 C
00410         IF (IRETIN.EQ.1) THEN
00411           GOTO 903
00412         ELSEIF (IRETIN.EQ.2) THEN
00413           GOTO 904
00414         ELSEIF (IRETIN.NE.0) THEN
00415           GOTO 1001
00416         ENDIF
00417 C
00418       ENDIF
00419 C
00420       IREP=0
00421       LFI%NBMOEC(IRANG)=LFI%NBMOEC(IRANG)+KLONG
00422       GOTO 1001
00423 C**
00424 C     9.  - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
00425 C-----------------------------------------------------------------------
00426 C
00427   903 CONTINUE
00428       CLACTI='WRITE'
00429       GOTO 909
00430 C
00431   904 CONTINUE
00432       CLACTI='READ'
00433 C
00434   909 CONTINUE
00435 C
00436 C      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
00437 C
00438       IREP=IABS (IREP)
00439       IF (INAPHY.NE.0) LFI%NUMAPH(IRANG)=INAPHY
00440 C**
00441 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00442 C            VIA LE SOUS-PROGRAMME "LFIEMS" .
00443 C-----------------------------------------------------------------------
00444 C
00445  1001 CONTINUE
00446       KREP=IREP
00447       LLFATA=LLMOER (IREP,IRANG)
00448 C
00449       IF (IRANG.NE.0) THEN
00450         LFI%NDEROP(IRANG)=1
00451         LFI%NDERCO(IRANG)=IREP
00452          IF (LLVERF) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'OFF')
00453       ENDIF
00454 C
00455       IF (LLFATA.OR.IXNIMS (IRANG).EQ.2) THEN
00456         INIMES=2
00457       ELSE
00458         IF (LHOOK) CALL DR_HOOK('LFIECR_MT',1,ZHOOK_HANDLE)
00459         RETURN
00460       ENDIF
00461 C
00462       CLNSPR='LFIECR'
00463       WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='
00464 ',I3,     S       '', CDNOMA='''''',A,'''''', KLONG='',I7)')
00465      S     KREP,KNUMER,CLNOMA(:ILCLNO),KLONG
00466       CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,LLFATA,
00467      S                CLMESS,CLNSPR,CLACTI)
00468 C
00469       IF (LHOOK) CALL DR_HOOK('LFIECR_MT',1,ZHOOK_HANDLE)
00470       END
00471