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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe LFI
00002       SUBROUTINE LFIREN_MT (LFI, KREP, KNUMER, CDNOM1, CDNOM2 )
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 RENOMMER UN ARTICLE (DE DONNEES)
00008 C     SUR UNE UNITE LOGIQUE OUVERTE POUR LE LOGICIEL DE FICHIERS INDEXES
00009 C     *LFI*. LE NOUVEAU NOM D'ARTICLE NE DOIT PAS Y ETRE DEJA UTILISE.
00010 C**
00011 C    ARGUMENTS : KREP   (SORTIE) ==> CODE-REPONSE DU SOUS-PROGRAMME;
00012 C                KNUMER (ENTREE) ==> LFI%NUMERO DE L'UNITE LOGIQUE;
00013 C                CDNOM1 (ENTREE) ==> NOM DE L'ARTICLE A RENOMMER;
00014 C                CDNOM2 (ENTREE) ==> NOUVEAU NOM A DONNER A L'ARTICLE.
00015 C
00016 #ifndef f77
00017 #include "precision.h"
00018 #endif
00019 C
00020       TYPE(LFICOM) :: LFI
00021       CHARACTER CDNOM1*(*), CDNOM2*(*), CLNOM1*(LFI%JPNCPN), 
00022      S          CLNOM2*(LFI%JPNCPN)
00023 C
00024       INTEGER KREP, KNUMER, IRANG, IREP, ILCDN1, ILCLN1, ILCDN2, ILCLN2
00025       INTEGER IDECBL, IPOSBL, IARTEX, INBALO, IRGPIM, IRETIN, INIMES
00026 C
00027       LOGICAL LLECR, LLVERF
00028 C
00029 #include "lficom2.h"
00030 #include "lficom_mt.h"
00031 C**
00032 C     1.  -  CONTROLES DES PARAMETRES D'APPEL, PUIS INITIALISATIONS.
00033 C-----------------------------------------------------------------------
00034 C
00035 C        Appel legerement anticipe a LFINUM, garantissant l'initialisa-
00036 C     tion des variables globales du logiciel a la 1ere utilisation.
00037 C
00038       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00039       IF (LHOOK) CALL DR_HOOK('LFIREN_MT',0,ZHOOK_HANDLE)
00040       CALL LFINUM_MT (LFI, KNUMER,IRANG)
00041       LLVERF=.FALSE.
00042       IREP=0
00043       LLECR=.FALSE.
00044       ILCDN1=LEN (CDNOM1)
00045       ILCDN2=LEN (CDNOM2)
00046 C
00047       IF (MIN0 (ILCDN1,ILCDN2).LE.0) THEN
00048 C
00049         IREP=-15
00050 C
00051         IF (ILCDN1.LE.0) THEN
00052           CLNOM1=LFI%CHINCO(:LFI%JPNCPN)
00053           ILCLN1=LFI%JPNCPN
00054         ELSE
00055           ILCLN1=MIN0 (ILCDN1,LFI%JPNCPN)
00056           CLNOM1=CDNOM1(:ILCLN1)
00057         ENDIF
00058 C
00059         IF (ILCDN2.LE.0) THEN
00060           CLNOM2=LFI%CHINCO(:LFI%JPNCPN)
00061           ILCLN2=LFI%JPNCPN
00062         ELSE
00063           ILCLN2=MIN0 (ILCDN2,LFI%JPNCPN)
00064           CLNOM2=CDNOM2(:ILCLN2)
00065         ENDIF
00066 C
00067         GOTO 1001
00068 C
00069       ELSEIF (CDNOM1.EQ.' '.OR.CDNOM2.EQ.' ') THEN
00070 C
00071         IREP=-18
00072 C
00073         IF (CDNOM1.EQ.' ') THEN
00074           CLNOM1=' '
00075           ILCLN1=1
00076         ELSE
00077           ILCLN1=MIN0 (ILCDN1,LFI%JPNCPN)
00078           CLNOM1=CDNOM1(:ILCLN1)
00079         ENDIF
00080 C
00081         IF (CDNOM2.EQ.' ') THEN
00082           CLNOM2=' '
00083           ILCLN2=1
00084         ELSE
00085           ILCLN2=MIN0 (ILCDN2,LFI%JPNCPN)
00086           CLNOM2=CDNOM2(:ILCLN2)
00087         ENDIF
00088 C
00089         GOTO 1001
00090 C
00091       ENDIF
00092 C
00093 C        Recherche de la longueur "utile" des noms d'article specifies.
00094 C        (c'est-a-dire sans tenir compte des blancs terminaux eventuels)
00095 C
00096       IDECBL=0
00097 C
00098   101 CONTINUE
00099       IPOSBL=IDECBL+INDEX (CDNOM1(IDECBL+1:),' ')
00100 C
00101       IF (IPOSBL.LE.IDECBL) THEN
00102         ILCLN1=ILCDN1
00103       ELSEIF (CDNOM1(IPOSBL:).EQ.' ') THEN
00104         ILCLN1=IPOSBL-1
00105       ELSE
00106         IDECBL=IPOSBL
00107         GOTO 101
00108       ENDIF
00109 C
00110       IDECBL=0
00111 C
00112   102 CONTINUE
00113       IPOSBL=IDECBL+INDEX (CDNOM2(IDECBL+1:),' ')
00114 C
00115       IF (IPOSBL.LE.IDECBL) THEN
00116         ILCLN2=ILCDN2
00117       ELSEIF (CDNOM2(IPOSBL:).EQ.' ') THEN
00118         ILCLN2=IPOSBL-1
00119       ELSE
00120         IDECBL=IPOSBL
00121         GOTO 102
00122       ENDIF
00123 C
00124       IF (ILCLN1.GT.LFI%JPNCPN) THEN
00125         ILCLN1=LFI%JPNCPN
00126         IREP=-15
00127       ENDIF
00128 C
00129       IF (ILCLN2.GT.LFI%JPNCPN) THEN
00130         ILCLN2=LFI%JPNCPN
00131         IREP=-15
00132       ENDIF
00133 C
00134       CLNOM1=CDNOM1(:ILCLN1)
00135       CLNOM2=CDNOM2(:ILCLN2)
00136       IF (IREP.NE.0) GOTO 1001
00137 C
00138       IF (IRANG.EQ.0) THEN
00139         IREP=-1
00140         GOTO 1001
00141       ENDIF
00142 C
00143        IF (LFI%LMULTI) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'ON')
00144       LLVERF=LFI%LMULTI
00145 C
00146       IF (LFI%NEXPOR(IRANG).GT.0) THEN
00147 C
00148 C         Fichier en cours d'export... la seule modification acceptee
00149 C         est l'ajout de nouveaux articles.
00150 C
00151         IREP=-37
00152         GOTO 1001
00153       ENDIF
00154 C
00155       IARTEX=0
00156       INBALO=LFI%MDES1D(IXM(LFI%JPNALO,IRANG))
00157 C
00158       IF (INBALO.NE.0) THEN
00159 C**
00160 C     2.  -  EXPLORATION DES (PAIRES DE) PAGES ET ARTICLES D'INDEX,
00161 C            A LA RECHERCHE DU NOUVEAU NOM D'ARTICLE, QUI NE DOIT
00162 C            PAS ETRE LE NOM D'UN ARTICLE EXISTANT.
00163 C-----------------------------------------------------------------------
00164 C
00165         CALL LFIRAN_MT (LFI, IREP,IRANG,CLNOM2(:ILCLN2),
00166      S                  IRGPIM,IARTEX,IRETIN)
00167 C
00168         IF (IRETIN.EQ.1) THEN
00169           GOTO 903
00170         ELSEIF (IRETIN.EQ.2) THEN
00171           GOTO 904
00172         ELSEIF (IRETIN.NE.0) THEN
00173           GOTO 1001
00174         ENDIF
00175 C
00176         IF (IARTEX.NE.0) THEN
00177           IREP=-25
00178           CLACTI=CLNOM2(:ILCLN2)
00179           GOTO 1001
00180         ENDIF
00181 C**
00182 C     3.  -  EXPLORATION DES (PAIRES DE) PAGES ET ARTICLES D'INDEX,
00183 C            A LA RECHERCHE DE L'ARTICLE LOGIQUE A RENOMMER.
00184 C-----------------------------------------------------------------------
00185 C
00186         CALL LFIRAN_MT (LFI, IREP,IRANG,CLNOM1(:ILCLN1),
00187      S                  IRGPIM,IARTEX,IRETIN)
00188 C
00189         IF (IRETIN.EQ.1) THEN
00190           GOTO 903
00191         ELSEIF (IRETIN.EQ.2) THEN
00192           GOTO 904
00193         ELSEIF (IRETIN.NE.0) THEN
00194           GOTO 1001
00195         ENDIF
00196 C
00197       ENDIF
00198 C
00199       IF (IARTEX.EQ.0) THEN
00200         IREP=-20
00201         CLACTI=CLNOM1(:ILCLN1)
00202         GOTO 1001
00203       ENDIF
00204 C**
00205 C     4.  -  TOUT EST OK... ON EFFECTUE LE CHANGEMENT DE NOM.
00206 C-----------------------------------------------------------------------
00207 C
00208       LFI%CNOMAR(IXC(IARTEX,IRGPIM))=CLNOM2(:ILCLN2)
00209       LFI%LECRPI(IRGPIM,1)=.TRUE.
00210       LFI%NBRENO(IRANG)=LFI%NBRENO(IRANG)+1
00211 C
00212 C        On met a jour ce qui a trait aux acces pseudo-sequentiels...
00213 C
00214       LFI%NDERGF(IRANG)=LFI%JPNAPP*LFI%MFACTM(IRANG)*
00215      S                  (LFI%MRGPIF(IRGPIM)-1)+IARTEX
00216       LFI%CNDERA(IRANG)=CLNOM2(:ILCLN2)
00217       LFI%NSUIVF(IRANG)=LFI%JPNIL
00218       LFI%NPRECF(IRANG)=LFI%JPNIL
00219 C
00220       IF (.NOT.LFI%LMODIF(IRANG)) THEN
00221 C
00222 C         CAS DE LA PREMIERE MODIFICATION DEPUIS L'OUVERTURE DU FICHIER.
00223 C
00224         LFI%LMODIF(IRANG)=.TRUE.
00225         CALL LFIMOE_MT (LFI, IREP,IRANG,IRETIN)
00226 C
00227         IF (IRETIN.EQ.1) THEN
00228           GOTO 903
00229         ELSEIF (IRETIN.EQ.2) THEN
00230           GOTO 904
00231         ELSEIF (IRETIN.NE.0) THEN
00232           GOTO 1001
00233         ENDIF
00234 C
00235       ENDIF
00236 C
00237       GOTO 1001
00238 C**
00239 C     9.  - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
00240 C-----------------------------------------------------------------------
00241 C
00242   903 CONTINUE
00243       CLACTI='WRITE'
00244       GOTO 909
00245 C
00246   904 CONTINUE
00247       CLACTI='READ'
00248 C
00249   909 CONTINUE
00250 C
00251 C      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
00252 C
00253       IREP=IABS (IREP)
00254 C**
00255 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00256 C            VIA LE SOUS-PROGRAMME "LFIEMS" .
00257 C-----------------------------------------------------------------------
00258 C
00259  1001 CONTINUE
00260       KREP=IREP
00261       LLFATA=LLMOER (IREP,IRANG)
00262 C
00263       IF (IRANG.NE.0) THEN
00264         LFI%NDEROP(IRANG)=13
00265         LFI%NDERCO(IRANG)=IREP
00266          IF (LLVERF) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'OFF')
00267       ENDIF
00268 C
00269       IF (LLFATA.OR.IXNIMS (IRANG).EQ.2) THEN
00270         INIMES=2
00271       ELSE
00272         IF (LHOOK) CALL DR_HOOK('LFIREN_MT',1,ZHOOK_HANDLE)
00273         RETURN
00274       ENDIF
00275 C
00276       CLNSPR='LFIREN'
00277       WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='
00278 ',I3,     S       '', CDNOM1='''''',A,'''''', CDNOM2='''''',A,'''''''')')
00279      S     KREP,KNUMER,CLNOM1(:ILCLN1),CLNOM2(:ILCLN2)
00280       CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,LLFATA,
00281      S                CLMESS,CLNSPR,CLACTI)
00282 C
00283       IF (LHOOK) CALL DR_HOOK('LFIREN_MT',1,ZHOOK_HANDLE)
00284       END
00285