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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe LFI
00002       SUBROUTINE LFISUP_MT (LFI, KREP, KNUMER, CDNOMA, KLONUT )
00003       USE LFIMOD, ONLY : LFICOM
00004       USE PARKIND1, ONLY : JPRB
00005       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00006 C****
00007 C        SOUS-PROGRAMME PERMETTANT DE *SUPPRIMER* UN ARTICLE LOGIQUE
00008 C     (DE DONNEES) SUR UNE UNITE LOGIQUE OUVERTE POUR LE LOGICIEL
00009 C     DE FICHIERS INDEXES *LFI*; L'ARTICLE EST TRANSFORME EN "TROU"
00010 C     DANS L'INDEX.
00011 C**
00012 C    ARGUMENTS : KREP   (SORTIE) ==> CODE-REPONSE DU SOUS-PROGRAMME;
00013 C                KNUMER (ENTREE) ==> LFI%NUMERO DE L'UNITE LOGIQUE;
00014 C                CDNOMA (ENTREE) ==> NOM DE L'ARTICLE A RECHERCHER;
00015 C                KLONUT (SORTIE) ==> LONGUEUR *REUTILISABLE*
00016 C                                    DE L'ARTICLE SUPPRIME.
00017 C
00018 #ifndef f77
00019 #include "precision.h"
00020 #endif
00021 C
00022       TYPE(LFICOM) :: LFI
00023       CHARACTER CDNOMA*(*), CLNOMA*(LFI%JPNCPN)
00024 C
00025       INTEGER KREP, KNUMER, KLONUT, IMDESC, IRANG, IREP, ILCDNO, ILCLNO
00026       INTEGER IDECBL, IPOSBL, IARTEX, INBALO, IRGPIM, IRGPIF, ILONGA, J
00027       INTEGER IPOSEX, IFACTM, ILARPH, INALPP, INALPI, INTPPI, INBPIR
00028       INTEGER INPPIM, IRECPI, IREC, IRGPI, IRPIMS, INPILE, IRNGMS
00029       INTEGER IRETIN, INIMES
00030 C
00031       LOGICAL LLVERF
00032 C
00033 #include "lficom2.h"
00034 #include "lficom_mt.h"
00035 C**
00036 C     1.  -  CONTROLES DES PARAMETRES D'APPEL, PUIS INITIALISATIONS.
00037 C-----------------------------------------------------------------------
00038 C
00039 C        Appel legerement anticipe a LFINUM, garantissant l'initialisa-
00040 C     tion des variables globales du logiciel a la 1ere utilisation.
00041 C
00042       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00043       IF (LHOOK) CALL DR_HOOK('LFISUP_MT',0,ZHOOK_HANDLE)
00044       CALL LFINUM_MT (LFI, KNUMER,IRANG)
00045       LLVERF=.FALSE.
00046       IREP=0
00047       KLONUT=0
00048       ILCDNO=LEN (CDNOMA)
00049 C
00050       IF (ILCDNO.LE.0) THEN
00051         IREP=-15
00052         CLNOMA=LFI%CHINCO(:LFI%JPNCPN)
00053         ILCLNO=LFI%JPNCPN
00054         GOTO 1001
00055       ELSEIF (CDNOMA.EQ.' ') THEN
00056         IREP=-18
00057         CLNOMA=' '
00058         ILCLNO=1
00059         GOTO 1001
00060       ENDIF
00061 C
00062 C        Recherche de la longueur "utile" du nom d'article specifie.
00063 C        (c'est-a-dire sans tenir compte des blancs terminaux eventuels)
00064 C
00065       IDECBL=0
00066 C
00067   101 CONTINUE
00068       IPOSBL=IDECBL+INDEX (CDNOMA(IDECBL+1:),' ')
00069 C
00070       IF (IPOSBL.LE.IDECBL) THEN
00071         ILCLNO=ILCDNO
00072       ELSEIF (CDNOMA(IPOSBL:).EQ.' ') THEN
00073         ILCLNO=IPOSBL-1
00074       ELSE
00075         IDECBL=IPOSBL
00076         GOTO 101
00077       ENDIF
00078 C
00079       IF (ILCLNO.LE.LFI%JPNCPN) THEN
00080         CLNOMA=CDNOMA(:ILCLNO)
00081       ELSE
00082         CLNOMA=CDNOMA(:LFI%JPNCPN)
00083         ILCLNO=LFI%JPNCPN
00084         IREP=-15
00085         GOTO 1001
00086       ENDIF
00087 C
00088       IF (IRANG.EQ.0) THEN
00089         IREP=-1
00090         GOTO 1001
00091       ENDIF
00092 C
00093        IF (LFI%LMULTI) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'ON')
00094       LLVERF=LFI%LMULTI
00095 C
00096       IF (LFI%NEXPOR(IRANG).GT.0) THEN
00097 C
00098 C         Fichier en cours d'export... la seule modification acceptee
00099 C         est l'ajout de nouveaux articles.
00100 C
00101         IREP=-37
00102         GOTO 1001
00103       ENDIF
00104 C
00105       IARTEX=0
00106       INBALO=LFI%MDES1D(IXM(LFI%JPNALO,IRANG))
00107 C
00108       IF (INBALO.NE.0) THEN
00109 C**
00110 C     2.  -  EXPLORATION DES (PAIRES DE) PAGES ET ARTICLES D'INDEX,
00111 C            A LA RECHERCHE DE L'ARTICLE LOGIQUE A SUPPRIMER.
00112 C-----------------------------------------------------------------------
00113 C
00114         CALL LFIRAN_MT (LFI, IREP,IRANG,CLNOMA(:ILCLNO),
00115      S                  IRGPIM,IARTEX,IRETIN)
00116 C
00117         IF (IRETIN.EQ.1) THEN
00118           GOTO 903
00119         ELSEIF (IRETIN.EQ.2) THEN
00120           GOTO 904
00121         ELSEIF (IRETIN.NE.0) THEN
00122           GOTO 1001
00123         ENDIF
00124 C
00125       ENDIF
00126 C
00127       IF (IARTEX.EQ.0) THEN
00128         IREP=-20
00129         CLACTI=CLNOMA(:ILCLNO)
00130         GOTO 1001
00131       ENDIF
00132 C
00133 C        ON COMPLETE LES CARACTERISTIQUES DE L'ARTICLE PAR SA LONGUEUR,
00134 C     EXPRIMEE EN TERME DE DONNEES "LISIBLES" POUR L'UTILISATEUR.
00135 C
00136       IRGPIF=LFI%MRGPIF(IRGPIM)
00137 C
00138       IF (.NOT.LFI%LPHASP(IRGPIM)) THEN
00139 C
00140         CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPIM,IRETIN)
00141 C
00142         IF (IRETIN.EQ.1) THEN
00143           GOTO 903
00144         ELSEIF (IRETIN.EQ.2) THEN
00145           GOTO 904
00146         ELSEIF (IRETIN.NE.0) THEN
00147           GOTO 1001
00148         ENDIF
00149 C
00150       ENDIF
00151 C
00152       ILONGA=LFI%MLGPOS(IXM(2*IARTEX-1,IRGPIM))
00153       IPOSEX=LFI%MLGPOS(IXM(2*IARTEX,IRGPIM))
00154       IFACTM=LFI%MFACTM(IRANG)
00155       ILARPH=LFI%JPLARD*IFACTM
00156       INALPP=LFI%JPNAPP*IFACTM
00157       INALPI=MIN0 (INALPP,INBALO-(IRGPIF-1)*INALPP)
00158       INTPPI=(INBALO-1+INALPP)/INALPP
00159       INBPIR=LFI%MDES1D(IXM(LFI%JPNPIR,IRANG))
00160       INPPIM=LFI%NPPIMM(IRANG)
00161 C**
00162 C     3.  -  AFIN D'ASSURER UN MEILLEUR RECYCLAGE (EVENTUEL) DE CE FUTUR
00163 C            TROU, ON CALCULE SA LONGUEUR EFFECTIVEMENT REUTILISABLE.
00164 C-----------------------------------------------------------------------
00165 C
00166       IF (IARTEX.EQ.1.AND.IRGPIF.GT.INBPIR) THEN
00167 C
00168 C            IL Y A EU DEBORDEMENT DES P.A.I. PREALLOUEES, ET IL Y A
00169 C        EN OUTRE UNE P.A.I. SUR LE FICHIER, JUSTE DERRIERE L'ARTICLE
00170 C        LOGIQUE AUQUEL ON S'INTERESSE.
00171 C
00172         IRECPI=LFI%MDES1D(IXM(ILARPH+1-(IRGPIF-INBPIR),IRANG))
00173         KLONUT=ILARPH*(IRECPI-1)-IPOSEX+1
00174       ELSEIF (IARTEX.EQ.INALPI.AND.IRGPIF.EQ.INTPPI) THEN
00175 C
00176 C           CAS OU L'ARTICLE TROUVE EST LE DERNIER ARTICLE LOGIQUE DE
00177 C        DONNEES, SANS P.A.I. JUSTE DERRIERE.
00178 C           LA DERNIERE POSITION REUTILISABLE SANS AUGMENTER LA TAILLE
00179 C       DU FICHIER CORRESPOND A LA FIN DU DERNIER ARTICLE PHYSIQUE
00180 C       CONTENANT DES DONNEES, OU A LA FIN DU DERNIER ARTICLE PHYSIQUE
00181 C       EFFECTIVEMENT ECRIT SUR LE FICHIER.
00182 C
00183         IMDESC=LFI%MDES1D(IXM(LFI%JPNAPH,IRANG))
00184         IREC=MAX0 (1+(IPOSEX+ILONGA-2)/ILARPH,IMDESC)
00185         KLONUT=ILARPH*IREC-IPOSEX+1
00186 C
00187 C          EN ARRIVANT AU TEST CI-DESSOUS, ON EST DONC SUR QUE L'ARTICLE
00188 C        TROUVE N'EST PAS LE DERNIER ARTICLE LOGIQUE.
00189 C          ON VA CALCULER LA DISTANCE ENTRE LES DEBUTS D'ARTICLE,
00190 C        CE QUI CONSTITUE LA LONGUEUR REUTILISABLE CHERCHEE.
00191 C
00192       ELSEIF (IARTEX.NE.INALPP) THEN
00193 C
00194 C           L'ARTICLE SUIVANT EST DANS LA MEME PAGE D'INDEX...
00195 C
00196         KLONUT=LFI%MLGPOS(IXM(2*IARTEX+2,IRGPIM))-IPOSEX
00197       ELSE
00198 C
00199 C           L'ARTICLE TROUVE EST EN PLUS EN FIN DE PAGE D'INDEX...
00200 C       RECHERCHE DANS LES P.P.I. DE LA P.A.I. SUIVANTE.
00201 C
00202         DO 302 J=2,INPPIM
00203         IRGPI=LFI%MRGPIM(J,IRANG)
00204 C
00205         IF (LFI%MRGPIF(IRGPI).EQ.(IRGPIF+1)) THEN
00206 C
00207           IRPIMS=IRGPI
00208 C
00209           IF (.NOT.LFI%LPHASP(IRPIMS)) THEN
00210 C
00211             CALL LFIPHA_MT (LFI, IREP,IRANG,IRPIMS,IRETIN)
00212 C
00213             IF (IRETIN.EQ.1) THEN
00214               GOTO 903
00215             ELSEIF (IRETIN.EQ.2) THEN
00216               GOTO 904
00217             ELSEIF (IRETIN.NE.0) THEN
00218               GOTO 1001
00219             ENDIF
00220 C
00221           ENDIF
00222 C
00223           GOTO 305
00224 C
00225         ENDIF
00226 C
00227   302   CONTINUE
00228 C
00229 C             LA P.A.I. SUIVANTE (EN RANG DANS LE FICHIER) N'EST PAS
00230 C          EN MEMOIRE; DECIDEMENT, CELA SE GATE ! ... ON L'Y MET.
00231 C
00232         INPILE=2
00233         CALL LFIPIM_MT (LFI, KREP,IRANG,IRNGMS,IRPIMS,
00234      S                  IRGPIF+1,IRGPIF,INPILE, IRETIN)
00235 C
00236         IF (IRETIN.EQ.1) THEN
00237           GOTO 903
00238         ELSEIF (IRETIN.EQ.2) THEN
00239           GOTO 904
00240         ELSEIF (IRETIN.NE.0) THEN
00241           GOTO 1001
00242         ENDIF
00243 C
00244   305   CONTINUE
00245 C
00246         KLONUT=LFI%MLGPOS(IXM(2,IRPIMS))-IPOSEX
00247       ENDIF
00248 C**
00249 C     4  -  TRANSFORMATION EFFECTIVE DE L'ARTICLE LOGIQUE DE DONNEES
00250 C           EN "TROU" D'INDEX.
00251 C-----------------------------------------------------------------------
00252 C
00253       LFI%CNOMAR(IXC(IARTEX,IRGPIM))=' '
00254       IF (LFI%NDERGF(IRANG).NE.LFI%JPNIL.AND.
00255      S    LFI%CNDERA(IRANG).EQ.CLNOMA(:ILCLNO))
00256      S    LFI%CNDERA(IRANG)=' '
00257       LFI%LECRPI(IRGPIM,1)=.TRUE.
00258       LFI%NBSUPP(IRANG)=LFI%NBSUPP(IRANG)+1
00259       LFI%LMIMAL(IRANG)=LFI%LMIMAL(IRANG).OR.
00260      S                  ILONGA.EQ.LFI%MDES1D(IXM(LFI%JPLNAL,IRANG))
00261      S              .OR.ILONGA.EQ.LFI%MDES1D(IXM(LFI%JPLXAL,IRANG))
00262       LFI%NBTROU(IRANG)=LFI%NBTROU(IRANG)+1
00263       LFI%MDES1D(IXM(LFI%JPLTAL,IRANG))=
00264      S                  LFI%MDES1D(IXM(LFI%JPLTAL,IRANG))-ILONGA
00265 C
00266       IF (KLONUT.NE.ILONGA) THEN
00267         LFI%MLGPOS(IXM(2*IARTEX-1,IRGPIM))=KLONUT
00268         LFI%LECRPI(IRGPIM,2)=.TRUE.
00269       ENDIF
00270 C
00271       IF (.NOT.LFI%LMODIF(IRANG)) THEN
00272 C
00273 C         CAS DE LA PREMIERE MODIFICATION DEPUIS L'OUVERTURE DU FICHIER.
00274 C
00275         LFI%LMODIF(IRANG)=.TRUE.
00276         CALL LFIMOE_MT (LFI, IREP,IRANG,IRETIN)
00277 C
00278         IF (IRETIN.EQ.1) THEN
00279           GOTO 903
00280         ELSEIF (IRETIN.EQ.2) THEN
00281           GOTO 904
00282         ELSEIF (IRETIN.NE.0) THEN
00283           GOTO 1001
00284         ENDIF
00285 C
00286       ENDIF
00287 C
00288       GOTO 1001
00289 C**
00290 C     9.  - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
00291 C-----------------------------------------------------------------------
00292 C
00293   903 CONTINUE
00294       CLACTI='WRITE'
00295       GOTO 909
00296 C
00297   904 CONTINUE
00298       CLACTI='READ'
00299 C
00300   909 CONTINUE
00301 C
00302 C      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
00303 C
00304       IREP=IABS (IREP)
00305 C**
00306 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00307 C            VIA LE SOUS-PROGRAMME "LFIEMS" .
00308 C-----------------------------------------------------------------------
00309 C
00310  1001 CONTINUE
00311       KREP=IREP
00312       LLFATA=LLMOER (IREP,IRANG)
00313 C
00314       IF (IRANG.NE.0) THEN
00315         LFI%NDEROP(IRANG)=15
00316         LFI%NDERCO(IRANG)=IREP
00317          IF (LLVERF) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'OFF')
00318       ENDIF
00319 C
00320       IF (LLFATA.OR.IXNIMS (IRANG).EQ.2) THEN
00321         INIMES=2
00322       ELSE
00323         IF (LHOOK) CALL DR_HOOK('LFISUP_MT',1,ZHOOK_HANDLE)
00324         RETURN
00325       ENDIF
00326 C
00327       CLNSPR='LFISUP'
00328       WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='
00329 ',I3,     S       '', CDNOMA='''''',A,'''''', KLONUT='',I8)')
00330      S     KREP,KNUMER,CLNOMA(:ILCLNO),KLONUT
00331       CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,LLFATA,
00332      S                CLMESS,CLNSPR,CLACTI)
00333 C
00334       IF (LHOOK) CALL DR_HOOK('LFISUP_MT',1,ZHOOK_HANDLE)
00335       END
00336