SURFEX v8.1
General documentation of Surfex
lfiran.F90
Go to the documentation of this file.
1 ! Oct-2012 P. Marguinaud 64b LFI
2 ! Jan-2011 P. Marguinaud Thread-safe LFI
3 SUBROUTINE lfiran_fort &
4 & (lfi, krep, krang, cdnoma, krgpim, &
5 & kartex, kretin )
6 USE lfimod, ONLY : lficom
7 USE parkind1, ONLY : jprb
8 USE yomhook , ONLY : lhook, dr_hook
9 USE lfi_precision
10 IMPLICIT NONE
11 !****
12 ! SOUS-PROGRAMME *INTERNE* DU LOGICIEL DE FICHIERS INDEXES LFI
13 ! RECHERCHE D'UN ARTICLE LOGIQUE PAR NOM, DANS UNE UNITE LOGIQUE.
14 !**
15 ! ARGUMENTS : KREP (SORTIE) ==> CODE-REPONSE DU SOUS-PROGRAMME;
16 ! KRANG (ENTREE) ==> RANG ( DANS LA TABLE *LFI%NUMERO* )
17 ! DE L'UNITE LOGIQUE CONCERNEE;
18 ! CDNOMA (ENTREE) ==> NOM DE L'ARTICLE A RECHERCHER;
19 ! KRGPIM (SORTIE) ==> RANG DANS LES TABLES LFI%CNOMAR,LFI%MLGPOS,
20 ! ETC. DE LA P.P.I OU FIGURE
21 ! L'ARTICLE ( 0 SI PAS TROUVE );
22 ! KARTEX (SORTIE) ==> RANG ( DANS LA PAGE D'INDEX ) DE L'
23 ! ARTICLE S'IL EXISTE ( 0 SINON );
24 ! KRETIN (SORTIE) ==> CODE-RETOUR INTERNE.
25 !
26 !
27 TYPE(lficom) :: LFI
28 CHARACTER CDNOMA*(*)
29 !
30 INTEGER (KIND=JPLIKB) KREP, KRANG, KRGPIM, KARTEX
31 INTEGER (KIND=JPLIKB) ILCDNO, IRANG, IFACTM, INALPP
32 INTEGER (KIND=JPLIKB) INBALO, INTPPI, IRANGF, IRGPIF
33 INTEGER (KIND=JPLIKB) J, ILFORC, INPILE, IRANGM
34 INTEGER (KIND=JPLIKB) IRGPIM, IARTIC, INPIME, IRPIFN
35 INTEGER (KIND=JPLIKB) INPPIM, IDEBEX, INUMER
36 INTEGER (KIND=JPLIKB) JNPAGE, INALPI, IRETOU, INIMES
37 INTEGER (KIND=JPLIKB) KRETIN, IRETIN
38 INTEGER (KIND=JPLIKB) IEXPLO (lfi%jpnpia+lfi%jpnpis)
39 !
40 CHARACTER(LEN=LFI%JPLSPX) CLNSPR
41 CHARACTER(LEN=LFI%JPLMES) CLMESS
42 CHARACTER(LEN=LFI%JPLFTX) CLACTI
43 LOGICAL LLFATA
44 
45 !**
46 ! 1. - PREAMBULES.
47 !-----------------------------------------------------------------------
48 !*
49 ! 1.1 - CONTROLES DES PARAMETRES D'APPEL ET INITIALISATIONS.
50 !-----------------------------------------------------------------------
51 !
52 REAL(KIND=JPRB) :: ZHOOK_HANDLE
53 IF (lhook) CALL dr_hook('LFIRAN_FORT',0,zhook_handle)
54 clacti=''
55 ilcdno=int(len(cdnoma), jplikb)
56 !
57 IF (krang.LE.0.OR.krang.GT.lfi%JPNXFI.OR. &
58 & ilcdno.LE.0.OR.ilcdno.GT.lfi%JPNCPN.OR.cdnoma.EQ.' ') THEN
59  krep=-16
60  GOTO 1001
61 ENDIF
62 !
63 irang=krang
64 krep=0
65 ifactm=lfi%MFACTM(irang)
66 inalpp=lfi%JPNAPP*ifactm
67 inbalo=lfi%MDES1D(ixm(lfi%JPNALO,irang))
68 intppi=(inbalo-1+inalpp)/inalpp
69 IF (lfi%LMISOP) &
70 & WRITE (unit=lfi%NULOUT,fmt=*)'LFIRAN - INBALO= ',inbalo, &
71 & ', INTPPI= ',intppi
72 !*
73 ! 1.2 - CAS "ELEMENTAIRES" OU CHANCEUX.
74 !-----------------------------------------------------------------------
75 !
76 IF (inbalo.EQ.0) THEN
77 !
78 ! Fichier vide ou depourvu d'articles logiques de donnees.
79 !
80  GOTO 300
81 !
82 ELSEIF (lfi%NDERGF(irang).NE.lfi%JPNIL &
83 & .AND.lfi%CNDERA(irang).EQ.cdnoma) THEN
84 !
85 ! Le dernier article demande via LFINFO (cas le plus probable)
86 ! ou LFILAS/LFILAP/LFICAS/LFICAP etait celui cherche !
87 !
88  irangf=lfi%NDERGF(irang)
89  irgpif=1+(irangf-1)/inalpp
90 !
91  IF (irangf.LE.inalpp) THEN
92  irgpim=lfi%MRGPIM(1,irang)
93  ELSEIF (irangf.GT.inalpp*(intppi-1)) THEN
94  irgpim=lfi%MRGPIM(lfi%NPODPI(irang),irang)
95  ELSE
96 !
97  DO j=2,lfi%NPPIMM(irang)
98  irgpim=lfi%MRGPIM(j,irang)
99  IF (lfi%MRGPIF(irgpim).EQ.irgpif) GOTO 122
100  ENDDO
101 !
102 ! MISE EN MEMOIRE DE L'ARTICLE D'INDEX "NOMS" CHERCHE.
103 !
104  ilforc=1
105  inpile=1
106  CALL lfipim_fort &
107 & (lfi, krep,irang,irangm,irgpim, &
108 & irgpif,ilforc,inpile, iretin)
109 !
110  IF (iretin.EQ.1) THEN
111  GOTO 903
112  ELSEIF (iretin.EQ.2) THEN
113  GOTO 904
114  ELSEIF (iretin.NE.0) THEN
115  GOTO 1001
116  ENDIF
117 !
118  ENDIF
119 !
120 122 CONTINUE
121  iartic=irangf-inalpp*(irgpif-1)
122 !
123  IF (lfi%CNOMAR(ixc(iartic,irgpim)).EQ.cdnoma) THEN
124  krgpim=irgpim
125  kartex=iartic
126  ELSE
127  krep=-16
128  ENDIF
129 !
130  GOTO 1001
131 !
132 ENDIF
133 !
134 inpime=0
135 irpifn=1
136 inppim=lfi%NPPIMM(irang)
137 !
138 IF (lfi%NPODPI(irang).EQ.2) THEN
139  idebex=3
140 ELSE
141  idebex=2
142 ENDIF
143 !**
144 ! 2. - EXPLORATION DES PAGES ET ARTICLES D'INDEX "NOMS",
145 ! A LA RECHERCHE DE L'ARTICLE LOGIQUE. ( ON COMMENCE
146 ! PAR EXPLORER LES PAGES D'INDEX )
147 !-----------------------------------------------------------------------
148 !
149 DO jnpage=1,intppi
150 !
151 IF (jnpage.LE.inppim) THEN
152 !
153 ! IL S'AGIT D'UNE EXPLORATION EN MEMOIRE ( PAGE D'INDEX ).
154 !
155  irgpim=lfi%MRGPIM(jnpage,irang)
156  irgpif=lfi%MRGPIF(irgpim)
157  inpime=inpime+1
158  iexplo(inpime)=irgpif
159  IF (irgpif.EQ.(irpifn+1)) irpifn=irgpif
160 ELSE
161 !
162 ! IL S'AGIT D'UNE EXPLORATION "HORS MEMOIRE";
163 ! ON CHERCHE LA PROCHAINE P.A.I. NON EXPLOREE .
164 !
165  IF (jnpage.EQ.inppim+1) irgpif=irpifn
166 !
167 201 CONTINUE
168  irgpif=irgpif+1
169 !
170  DO j=idebex,inpime
171  IF (iexplo(j).EQ.irgpif) GOTO 201
172  ENDDO
173 !
174  ilforc=1
175  inpile=1
176  CALL lfipim_fort &
177 & (lfi, krep,irang,irangm,irgpim,irgpif, &
178 & ilforc,inpile, iretin)
179 !
180  IF (iretin.EQ.1) THEN
181  GOTO 903
182  ELSEIF (iretin.EQ.2) THEN
183  GOTO 904
184  ELSEIF (iretin.NE.0) THEN
185  GOTO 1001
186  ENDIF
187 !
188 ENDIF
189 !
190 inalpi=min(inalpp,inbalo-(irgpif-1)*inalpp)
191 !
192 DO j=1,inalpi
193 !
194 IF (lfi%CNOMAR(ixc(j,irgpim)).EQ.cdnoma) THEN
195  krgpim=irgpim
196  kartex=j
197  GOTO 1001
198 ENDIF
199 !
200 ENDDO
201 !
202 ENDDO
203 !
204 300 CONTINUE
205 !**
206 ! 3. - CAS OU L'ARTICLE N'A PAS ETE TROUVE.
207 !-----------------------------------------------------------------------
208 !
209 krgpim=0
210 kartex=0
211 GOTO 1001
212 !**
213 ! 9. - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
214 ! AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
215 !-----------------------------------------------------------------------
216 !
217 903 CONTINUE
218 iretou=1
219 clacti='WRITE'
220 GOTO 909
221 !
222 904 CONTINUE
223 iretou=2
224 clacti='READ'
225 !
226 909 CONTINUE
227 krep=abs(krep)
228 !**
229 ! 10. - PHASE TERMINALE : MESSAGERIE INTERNE EVENTUELLE,
230 ! VIA LE SOUS-PROGRAMME "LFIEMS", PUIS RETOUR.
231 !-----------------------------------------------------------------------
232 !
233 1001 CONTINUE
234 llfata=llmoer(krep,krang)
235 !
236 IF (krep.EQ.0) THEN
237  kretin=0
238 ELSEIF (krep.GT.0) THEN
239  kretin=iretou
240 ELSE
241  kretin=3
242 ENDIF
243 !
244 IF (lfi%LMISOP.OR.llfata) THEN
245  inumer=lfi%NUMERO(krang)
246  inimes=2
247  clnspr='LFIRAN'
248  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KRANG='',I3, &
249 & '', CDNOMA='''''',A,'''''', KRGPIM='',I3,'', KARTEX='',I5, &
250 & '', KRETIN='',I2)') &
251 & krep,krang,cdnoma,krgpim,kartex,kretin
252  CALL lfiems_fort &
253 & (lfi, inumer,inimes,krep,.false., &
254 & clmess,clnspr,clacti)
255 ENDIF
256 !
257 IF (lhook) CALL dr_hook('LFIRAN_FORT',1,zhook_handle)
258 
259 CONTAINS
260 
261 #include "lficom2.ixc.h"
262 #include "lficom2.ixm.h"
263 #include "lficom2.llmoer.h"
264 
265 END SUBROUTINE lfiran_fort
266 
267 
268 
269 ! Oct-2012 P. Marguinaud 64b LFI
270 SUBROUTINE lfiran64 &
271 & (krep, krang, cdnoma, krgpim, kartex, kretin)
272 USE lfimod, ONLY : lfi => lficom_default, &
273 & lficom_default_init, &
274 & new_lfi_default
275 USE lfi_precision
276 IMPLICIT NONE
277 ! Arguments
278 INTEGER (KIND=JPLIKB) KREP ! OUT
279 INTEGER (KIND=JPLIKB) KRANG ! IN
280 CHARACTER (LEN=*) CDNOMA ! IN
281 INTEGER (KIND=JPLIKB) KRGPIM ! OUT
282 INTEGER (KIND=JPLIKB) KARTEX ! OUT
283 INTEGER (KIND=JPLIKB) KRETIN ! OUT
284 
285 IF (.NOT. lficom_default_init) CALL new_lfi_default ()
286 
287 CALL lfiran_fort &
288 & (lfi, krep, krang, cdnoma, krgpim, kartex, kretin)
289 
290 END SUBROUTINE lfiran64
291 
292 SUBROUTINE lfiran &
293 & (krep, krang, cdnoma, krgpim, kartex, kretin)
294 USE lfimod, ONLY : lfi => lficom_default, &
295 & lficom_default_init, &
296 & new_lfi_default
297 USE lfi_precision
298 IMPLICIT NONE
299 ! Arguments
300 INTEGER (KIND=JPLIKM) KREP ! OUT
301 INTEGER (KIND=JPLIKM) KRANG ! IN
302 CHARACTER (LEN=*) CDNOMA ! IN
303 INTEGER (KIND=JPLIKM) KRGPIM ! OUT
304 INTEGER (KIND=JPLIKM) KARTEX ! OUT
305 INTEGER (KIND=JPLIKM) KRETIN ! OUT
306 
307 IF (.NOT. lficom_default_init) CALL new_lfi_default ()
308 
309 CALL lfiran_mt &
310 & (lfi, krep, krang, cdnoma, krgpim, kartex, kretin)
311 
312 END SUBROUTINE lfiran
313 
314 SUBROUTINE lfiran_mt &
315 & (lfi, krep, krang, cdnoma, krgpim, kartex, kretin)
316 USE lfimod, ONLY : lficom
317 USE lfi_precision
318 IMPLICIT NONE
319 ! Arguments
320 type(lficom) lfi ! INOUT
321 INTEGER (KIND=JPLIKM) KREP ! OUT
322 INTEGER (KIND=JPLIKM) KRANG ! IN
323 CHARACTER (LEN=*) CDNOMA ! IN
324 INTEGER (KIND=JPLIKM) KRGPIM ! OUT
325 INTEGER (KIND=JPLIKM) KARTEX ! OUT
326 INTEGER (KIND=JPLIKM) KRETIN ! OUT
327 ! Local integers
328 INTEGER (KIND=JPLIKB) IREP ! OUT
329 INTEGER (KIND=JPLIKB) IRANG ! IN
330 INTEGER (KIND=JPLIKB) IRGPIM ! OUT
331 INTEGER (KIND=JPLIKB) IARTEX ! OUT
332 INTEGER (KIND=JPLIKB) IRETIN ! OUT
333 ! Convert arguments
334 
335 irang = int( krang, jplikb)
336 
337 CALL lfiran_fort &
338 & (lfi, irep, irang, cdnoma, irgpim, iartex, iretin)
339 
340 krep = int( irep, jplikm)
341 krgpim = int( irgpim, jplikm)
342 kartex = int( iartex, jplikm)
343 kretin = int( iretin, jplikm)
344 
345 END SUBROUTINE lfiran_mt
346 
347 !INTF KREP OUT
348 !INTF KRANG IN
349 !INTF CDNOMA IN
350 !INTF KRGPIM OUT
351 !INTF KARTEX OUT
352 !INTF KRETIN OUT
lfi_precision::jplikb
integer, parameter jplikb
Definition: lfi_precision.F90:25
lfiran_fort
subroutine lfiran_fort(LFI, KREP, KRANG, CDNOMA, KRGPIM, KARTEX, KRETIN)
Definition: lfiran.F90:6
yomhook::dr_hook
Definition: yomhook.F90:20
lfiran64
subroutine lfiran64(KREP, KRANG, CDNOMA, KRGPIM, KARTEX, KRETIN)
Definition: lfiran.F90:272
lfimod::new_lfi_default
subroutine new_lfi_default()
Definition: lfimod.F90:376
lfiran
subroutine lfiran(KREP, KRANG, CDNOMA, KRGPIM, KARTEX, KRETIN)
Definition: lfiran.F90:294
lfiran_mt
subroutine lfiran_mt(LFI, KREP, KRANG, CDNOMA, KRGPIM, KARTEX, KRETIN)
Definition: lfiran.F90:316
lfimod::lficom_default_init
logical, save lficom_default_init
Definition: lfimod.F90:371
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
lfimod::lficom_default
type(lficom), target, save lficom_default
Definition: lfimod.F90:370
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
lfi_precision::jplikm
integer, parameter jplikm
Definition: lfi_precision.F90:25
lfiems_fort
subroutine lfiems_fort(LFI, KNUMER, KNIMES, KCODE, LDFATA, CDMESS, CDNSPR, CDACTI)
Definition: lfiems.F90:7
lfimod
Definition: lfimod.F90:1
lfi_precision
Definition: lfi_precision.F90:1
lfipim_fort
subroutine lfipim_fort(LFI, KREP, KRANG, KRANGM, KRGPIM, KRGPIF, KRGFOR, KNPILE, KRETIN)
Definition: lfipim.F90:6
Generated on Tue Jan 16 2018 16:23:21 for SURFEX v8.1 by   doxygen 1.8.13