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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe LFI
00002       SUBROUTINE LFIPXF_MT (LFI, KREP, KNUMER, KNUMEX, CDCFGX, 
00003      S                      KLAREX, KXCNEX,
00004      S                      KFACEX, KNUTRA, CDNOMA, KLONG )
00005       USE LFIMOD, ONLY : LFICOM
00006       USE PARKIND1, ONLY : JPRB
00007       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00008 C****
00009 C        Sous-programme Preparatoire a la realisation d'une
00010 C        "version eXport" d'un Fichier LFI vers un systeme
00011 C        a priori different. La methode utilisee suppose:
00012 C
00013 C     - que les fichiers a acces direct FORTRAN soient implantes ou
00014 C       traitables comme des fichiers non bloques sur le systeme
00015 C       destinataire;
00016 C
00017 C     - que l'on puisse ecrire par WRITE FORTRAN des fichiers
00018 C       non bloques sur le systeme ou est fait la "version export",
00019 C       aussi appelee "fichier export";
00020 C
00021 C     - que la conversion des variables, numeriques voire aussi
00022 C       caracteres, soit faite au niveau des couches d'entrees/sorties
00023 C       FORTRAN sur le systeme ou est fait le fichier export;
00024 C
00025 C     ( dans la pratique, les deux points qui precedent impliquent un
00026 C       parametrage au niveau du langage de controle, a priori )
00027 C
00028 C     - que le programme utilisateur ait ouvert au prealable le fichier
00029 C       LFI dont on veut realiser une "version export", et appelle le
00030 C       sous-programme LFIPXF;
00031 C
00032 C     - que le programme utilisateur specifie le contenu des articles
00033 C       a exporter en termes de types FORTRAN; ceci pouvant se faire
00034 C       de deux manieres, eventuellement combinables:
00035 C
00036 C       1) Si le fichier contient (essentiellement) des donnees
00037 C          utilisateur pouvant se decrire de maniere homogene,
00038 C          par exemple rien que des variables reelles, et doit etre
00039 C          exporte dans la totalite des articles, alors il suffira
00040 C          d'appeler le sous-programme LFIXPH avec la description
00041 C          correspondant a ces articles, que l'on peut aussi voir
00042 C          comme une "description par defaut" (ou implicite);
00043 C
00044 C       2) Si ce n'est pas le cas, ou si une partie des articles ne
00045 C          peut pas etre decrite de la meme maniere que les autres
00046 C          articles, alors il faudra  que le programme utilisateur
00047 C          specifie, pour chacun de ces articles,
00048 C          le contenu en termes de types FORTRAN en appelant le sous-
00049 C          programme LFIXPA: il s'agit la d'une description explicite,
00050 C          ayant precedence sur une eventuelle description implicite;
00051 C
00052 C     - qu'en fin de compte le programme utilisateur appelle le sous-
00053 C       programme LFIXPF qui fabriquera vraiment la version export,
00054 C       a partir des specifications donnees via LFIPXF, LFIXPH, LFIXPA.
00055 C**
00056 C    ARGUMENTS : KREP   (Sortie) ==> Code-Reponse du sous-programme;
00057 C                KNUMER (Entree) ==> Numero d'Unite Logique associe
00058 C                                    au fichier LFI a exporter;
00059 C                KNUMEX (Entree) ==> Numero d'Unite Logique associe
00060 C                                    a la version export a realiser;
00061 C                CDCFGX (Entree) ==> Configuration du systeme
00062 C                                    destinataire du fichier export;
00063 C                KLAREX (Entree) ==> Longueur d'ARticle Elementaire du
00064 C                                    logiciel LFI du systeme destinatai-
00065 C                                    re, exprimee en mots du systeme
00066 C                                    destinataire;
00067 C                                    (LFI%JPLARD du logiciel "distant")
00068 C                KXCNEX (Entree) ==> Nombre maXimum de Caracteres par
00069 C                                    Nom d'article du logiciel LFI du
00070 C                                    systeme destinataire;
00071 C                                    (LFI%JPNCPN du logiciel "distant")
00072 C                KFACEX (Entree) ==> Facteur multiplicatif du fichier
00073 C                                    export;
00074 C                KNUTRA (Entree) ==> Numero d'Unite Logique utilisable
00075 C                                    pour un fichier de travail eventuel
00076 C                                    (si utilisation de LFIXPA), de type
00077 C                                    LFI;
00078 C                CDNOMA (Sortie) ==> Nom du premier article "candidat"
00079 C                                    (potentiel) a l'export;
00080 C                KLONG  (Sortie) ==> Longueur de cet article.
00081 C
00082 C     REMARQUE: Le fichier de travail n'est utilise que si l'on n'a pas
00083 C               assez de place dans les tables pour stocker en memoire
00084 C               les descripteurs. Mais si on en a besoin, il faut penser
00085 C               que ce fichier occupera (temporairement, jusqu'a appel a
00086 C               LFIXPF) une entree dans les tables LFI, et donc ne pas
00087 C               avoir les tables saturees auparavant.
00088 C
00089 #ifndef f77
00090 #include "precision.h"
00091 #endif
00092 C
00093       TYPE(LFICOM) :: LFI
00094       CHARACTER CDNOMA*(*), CLNOMA*(LFI%JPNCPN)
00095       CHARACTER CDCFGX*(*), CLCFGX*(LFI%JPXCCF)
00096 C
00097       INTEGER KREP, KNUMER, KNUMEX, KLAREX, KXCNEX, KFACEX, KNUTRA
00098       INTEGER KLONG, ILCLNO, ILCDNO, IRANMX, ILCFGX, IDECBL, IPOSBL
00099       INTEGER IRANG, IREP, INUMER, INBALO, INTTRU, J, IRANIE, INIMES
00100       INTEGER IRGPIM, IRGPIF, IARTIC, IRETIN, ILCDCF
00101 C
00102       LOGICAL LLVERG, LLVERF, LLEXUL, LLOUVR
00103 C
00104 #include "lficom2.h"
00105 #include "lficom_mt.h"
00106 C**
00107 C     1.  -  CONTROLES DES PARAMETRES D'APPEL, PUIS INITIALISATIONS.
00108 C-----------------------------------------------------------------------
00109 C
00110 C        Appel legerement anticipe a LFINUM, garantissant l'initialisa-
00111 C     tion des variables globales du logiciel a la 1ere utilisation.
00112 C
00113       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00114       IF (LHOOK) CALL DR_HOOK('LFIPXF_MT',0,ZHOOK_HANDLE)
00115       CALL LFINUM_MT (LFI, KNUMER,IRANG)
00116       IREP=0
00117       INUMER=KNUMER
00118       LLVERF=.FALSE.
00119       LLVERG=.FALSE.
00120       ILCDNO=LEN (CDNOMA)
00121       ILCDCF=LEN (CDCFGX)
00122       CLNOMA=' '
00123       ILCLNO=1
00124       CLCFGX=' '
00125       ILCFGX=1
00126       KLONG=0
00127 C
00128       IF (MIN0 (KLAREX,KXCNEX,KFACEX).LE.0) THEN
00129         IREP=-14
00130         GOTO 1001
00131       ELSEIF (ILCDNO.LE.0) THEN
00132         IREP=-15
00133         CLNOMA=LFI%CHINCO(:LFI%JPNCPN)
00134         ILCLNO=LFI%JPNCPN
00135       ENDIF
00136 C
00137       IF (ILCDCF.LE.0) THEN
00138         IREP=-15
00139         CLCFGX=LFI%CHINCO(:LFI%JPNCPN)
00140         ILCFGX=LFI%JPNCPN
00141       ENDIF
00142 C
00143       IF (IREP.NE.0) THEN
00144         GOTO 1001
00145       ELSE
00146         CDNOMA=' '
00147       ENDIF
00148 C
00149 C        Recherche de la longueur "utile" de la configuration specifiee.
00150 C        (c'est-a-dire sans tenir compte des blancs terminaux eventuels)
00151 C
00152       IDECBL=0
00153 C
00154   101 CONTINUE
00155       IPOSBL=IDECBL+INDEX (CDCFGX(IDECBL+1:),' ')
00156 C
00157       IF (IPOSBL.LE.IDECBL) THEN
00158         ILCFGX=ILCDCF
00159       ELSEIF (CDCFGX(IPOSBL:).EQ.' ') THEN
00160         ILCFGX=IPOSBL-1
00161       ELSE
00162         IDECBL=IPOSBL
00163         GOTO 101
00164       ENDIF
00165 C
00166       IF (ILCFGX.LE.LFI%JPXCCF) THEN
00167         CLCFGX=CDCFGX(:ILCFGX)
00168       ELSE
00169         CLCFGX=CDCFGX(:LFI%JPXCCF)
00170         ILCFGX=LFI%JPXCCF
00171         IREP=-15
00172         GOTO 1001
00173       ENDIF
00174 C
00175       DO 102 J=0,LFI%JPCFMX
00176 C
00177       IF (CDCFGX.EQ.LFI%CFGMXD(J)) THEN
00178         IRANMX=J
00179         GOTO 103
00180       ENDIF      
00181 C
00182   102 CONTINUE
00183 C
00184 C        Configuration du systeme destinataire inconnue ou non prevue.
00185 C
00186       IREP=-32
00187       GOTO 1001
00188 C
00189   103 CONTINUE
00190 C
00191       IF (KXCNEX.GT.LFI%JPXCIE) THEN
00192         IREP=-33
00193         GOTO 1001
00194       ENDIF
00195 C
00196 C        Controle de validite FORTRAN et de non ouverture prealable
00197 C        des Numeros d'Unite Logique KNUMEX et KNUTRA.
00198 C
00199       INUMER=KNUMEX
00200       INQUIRE (UNIT=KNUMEX,EXIST=LLEXUL,OPENED=LLOUVR,ERR=901,
00201      S         IOSTAT=IREP)
00202       CLACTI='EXPORT'
00203 C
00204       IF (.NOT.LLEXUL) THEN
00205         IREP=-30
00206         GOTO 1001
00207       ELSEIF (LLOUVR) THEN
00208         IREP=-34
00209         GOTO 1001
00210       ENDIF
00211 C
00212       INUMER=KNUTRA
00213       INQUIRE (UNIT=KNUTRA,EXIST=LLEXUL,OPENED=LLOUVR,ERR=901,
00214      S         IOSTAT=IREP)
00215 C
00216       IF (LFI%LFRANC) THEN
00217         CLACTI='DE TRAVAIL'
00218       ELSE
00219         CLACTI='WORK'
00220       ENDIF
00221 C
00222       IF (.NOT.LLEXUL) THEN
00223         IREP=-30
00224         GOTO 1001
00225       ELSEIF (LLOUVR) THEN
00226         IREP=-34
00227         GOTO 1001
00228       ENDIF
00229 C
00230       INUMER=KNUMER
00231 C
00232       IF (IRANG.EQ.0) THEN
00233         IREP=-1
00234         GOTO 1001
00235       ENDIF
00236 C
00237        IF (LFI%LMULTI) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'ON')
00238       LLVERF=LFI%LMULTI
00239 C
00240       IF (LFI%NEXPOR(IRANG).GT.0) THEN
00241         IREP=-35
00242         CLACTI='EXPORT'
00243         GOTO 1001
00244       ELSEIF (LFI%NIMPOR(IRANG).GT.0) THEN
00245         IREP=-35
00246         CLACTI='IMPORT'
00247         GOTO 1001
00248       ENDIF
00249 C
00250       INBALO=LFI%MDES1D(IXM(LFI%JPNALO,IRANG))
00251       INTTRU=LFI%MDES1D(IXM(LFI%JPNTRU,IRANG))+LFI%NBTROU(IRANG)
00252 C
00253       IF (INBALO.EQ.INTTRU) THEN
00254 C
00255 C         Fichier vide de donnees... inexportable.
00256 C
00257         IREP=-36
00258         CLACTI='EXPORT'
00259         GOTO 1001
00260       ENDIF
00261 C
00262 C               Ouverture de l'unite logique KNUMEX.
00263 C
00264       INUMER=KNUMEX
00265       OPEN (UNIT=KNUMEX,STATUS='UNKNOWN',ACCESS='SEQUENTIAL',
00266      S      FORM='UNFORMATTED',IOSTAT=IREP,ERR=902)
00267       REWIND (UNIT=KNUMEX,IOSTAT=IREP,ERR=906)
00268       INUMER=KNUMER
00269 C**
00270 C     2.  -  RECHERCHE DU PREMIER ARTICLE LOGIQUE DE DONNEES DU FICHIER.
00271 C-----------------------------------------------------------------------
00272 C
00273 C       Reinitialisation des caracteristiques de type "pointeur".
00274 C
00275       LFI%NDERGF(IRANG)=LFI%JPNIL
00276       LFI%CNDERA(IRANG)=' '
00277       LFI%NSUIVF(IRANG)=LFI%JPNIL
00278       LFI%NPRECF(IRANG)=LFI%JPNIL
00279 C
00280       CALL LFICAX_MT (LFI, IREP,IRANG,IRGPIM,IARTIC,IRETIN)
00281 C
00282       IF (IRETIN.EQ.1) THEN
00283         GOTO 903
00284       ELSEIF (IRETIN.EQ.2) THEN
00285         GOTO 904
00286       ELSEIF (IRETIN.NE.0) THEN
00287         GOTO 1001
00288       ELSEIF (IARTIC.EQ.0) THEN
00289         IREP=-16
00290         GOTO 1001
00291       ENDIF
00292 C
00293       IRGPIF=LFI%MRGPIF(IRGPIM)
00294 C
00295       IF (.NOT.LFI%LPHASP(IRGPIM)) THEN
00296 C
00297         CALL LFIPHA_MT (LFI, IREP,IRANG,IRGPIM,IRETIN)
00298 C
00299         IF (IRETIN.EQ.1) THEN
00300           GOTO 903
00301         ELSEIF (IRETIN.EQ.2) THEN
00302           GOTO 904
00303         ELSEIF (IRETIN.NE.0) THEN
00304           GOTO 1001
00305         ENDIF
00306 C
00307       ENDIF
00308 C
00309       KLONG=LFI%MLGPOS(IXM(IARTIC,IRGPIM))
00310       CLNOMA=LFI%CNOMAR(IXC(IARTIC,IRGPIM))
00311 C
00312 C        Recherche de la longueur "utile" du nom d'article.
00313 C        (c'est-a-dire sans tenir compte des blancs terminaux eventuels)
00314 C
00315       IDECBL=0
00316 C
00317   211 CONTINUE
00318       IPOSBL=IDECBL+INDEX (CLNOMA(IDECBL+1:),' ')
00319 C
00320       IF (IPOSBL.LE.IDECBL) THEN
00321         ILCLNO=LFI%JPNCPN
00322       ELSEIF (CLNOMA(IPOSBL:).EQ.' ') THEN
00323         ILCLNO=IPOSBL-1
00324       ELSE
00325         IDECBL=IPOSBL
00326         GOTO 211
00327       ENDIF
00328 C
00329       IF (ILCDNO.GE.ILCLNO) THEN
00330         CDNOMA=CLNOMA(:ILCLNO)
00331       ELSE
00332         IREP=-24
00333         CLACTI=CLNOMA
00334         GOTO 1001
00335       ENDIF
00336 C**
00337 C     3.  -  STOCKAGE DES PARAMETRES D'APPEL DANS LES TABLES.
00338 C-----------------------------------------------------------------------
00339 C
00340 C           VERROUILLAGE GLOBAL EVENTUEL.
00341 C
00342        IF (LFI%LMULTI) CALL LFIVER_MT (LFI, LFI%VERGLA,'ON')
00343       LLVERG=LFI%LMULTI
00344 C
00345       IF (LFI%NUIMEX.LT.LFI%JPIMEX) THEN
00346 C
00347         DO 301 J=1,LFI%JPIMEX
00348 C
00349         IF (LFI%MNUIEX(J).EQ.LFI%JPNIL) THEN
00350           IRANIE=J
00351           LFI%NUIMEX=LFI%NUIMEX+1
00352           LFI%NINIEX(LFI%NUIMEX)=J
00353           LFI%MNUIEX(J)=KNUMER
00354           GOTO 302
00355         ENDIF
00356 C
00357   301   CONTINUE
00358 C
00359         IREP=-16
00360         GOTO 1001
00361 C
00362       ELSE
00363 C
00364 C        Tables deja pleines...
00365 C
00366         IREP=-37
00367         GOTO 1001
00368       ENDIF
00369 C
00370   302   CONTINUE
00371 C
00372 C         Deverrouillage Global eventuel.
00373 C
00374        IF (LFI%LMULTI) CALL LFIVER_MT (LFI, LFI%VERGLA,'OFF')
00375       LLVERG=.FALSE.
00376 C
00377       LFI%NEXPOR(IRANG)=IRANIE
00378       LFI%NAEXPL(IRANIE)=0
00379       LFI%CNIMPL(IRANIE)=' '
00380       LFI%NIMPEX(IRANIE)=KNUMEX
00381       LFI%NUTRAV(IRANIE)=KNUTRA
00382       LFI%NLAPFD(IRANIE)=KLAREX*KFACEX
00383       LFI%NXCNLD(IRANIE)=KXCNEX
00384       LFI%NRCFMX(IRANIE)=IRANMX
00385 C
00386       GOTO 1001
00387 C**
00388 C     9.  - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
00389 C-----------------------------------------------------------------------
00390 C
00391   901 CONTINUE
00392       CLACTI='INQUIRE'
00393       GOTO 909
00394 C
00395   902 CONTINUE
00396       CLACTI='OPEN'
00397       GOTO 909
00398 C
00399   903 CONTINUE
00400       CLACTI='WRITE'
00401       GOTO 909
00402 C
00403   904 CONTINUE
00404       CLACTI='READ'
00405       GOTO 909
00406 C
00407   906 CONTINUE
00408       CLACTI='REWIND'
00409 C
00410   909 CONTINUE
00411 C
00412 C      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
00413 C
00414       IREP=IABS (IREP)
00415 C**
00416 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00417 C            VIA LE SOUS-PROGRAMME "LFIEMS" .
00418 C-----------------------------------------------------------------------
00419 C
00420  1001 CONTINUE
00421       KREP=IREP
00422       LLFATA=LLMOER (IREP,IRANG)
00423        IF (LLVERG) CALL LFIVER_MT (LFI, LFI%VERGLA,'OFF')
00424 C
00425       IF (IRANG.NE.0) THEN
00426         LFI%NDEROP(IRANG)=22
00427         LFI%NDERCO(IRANG)=IREP
00428          IF (LLVERF) CALL LFIVER_MT (LFI, LFI%VERRUE(IRANG),'OFF')
00429       ENDIF
00430 C
00431       IF (LLFATA.OR.IXNIMS (IRANG).EQ.2) THEN
00432         INIMES=2
00433       ELSE
00434         IF (LHOOK) CALL DR_HOOK('LFIPXF_MT',1,ZHOOK_HANDLE)
00435         RETURN
00436       ENDIF
00437 C
00438       CLNSPR='LFIPXF'
00439         WRITE (UNIT=CLMESS,FMT='(''ARGUMENTS='',I4,2('','
00440 ',I3),A,     S         '','',I5,2('','',I2),'','',I3,A,'','',I6)')
00441      S     KREP,KNUMER,KNUMEX,CLCFGX(:ILCFGX),KLAREX,KXCNEX,KFACEX,
00442      S     KNUTRA,CLNOMA(:ILCLNO),KLONG
00443       CALL LFIEMS_MT (LFI, INUMER,INIMES,IREP,LLFATA,
00444      S                CLMESS,CLNSPR,CLACTI)
00445 C
00446       IF (LHOOK) CALL DR_HOOK('LFIPXF_MT',1,ZHOOK_HANDLE)
00447       END
00448