SURFEX v8.1
General documentation of Surfex
fanion.F90
Go to the documentation of this file.
1 ! Oct-2012 P. Marguinaud 64b LFI
2 ! Jan-2011 P. Marguinaud Thread-safe FA
3 SUBROUTINE fanion_fort &
4 & (fa, krep, knumer, cdpref, knivau, cdsuff, &
5 & ldexis, ldcosp, kngrib, knarg1, knarg2, knarg3)
6 USE fa_mod, ONLY : fa_com
7 USE parkind1, ONLY : jprb
8 USE yomhook , ONLY : lhook, dr_hook
9 USE lfi_precision
10 IMPLICIT NONE
11 !****
12 ! Sous-programme renseignant sur l'EXISTENCE et les CARACTERISTI-
13 ! QUES eventuelles d'un Article de type CHAMP dans un Fichier ARPEGE
14 ! ( LDEXIS est le "fanion" leve si l'article existe )
15 !**
16 ! Arguments : KREP (Sortie) ==> Code-reponse du sous-programme;
17 ! KNUMER (Entree) ==> Numero de l'unite logique;
18 ! CDPREF (Entree) ==> Prefixe eventuel du nom d'article;
19 ! KNIVAU (Entree) ==> Niveau vertical eventuel;
20 ! CDSUFF (Entree) ==> Suffixe eventuel du nom d'article;
21 ! LDEXIS (Sortie) ==> Vrai si l'article de type CHAMP
22 ! existe bien dans le Fichier;
23 ! LDCOSP (Sortie) ==> Vrai si le champ est represente
24 ! par des coefficients spectraux;
25 ! KNGRIB (Sortie) ==> Niveau de codage GRIB;
26 ! Si KNGRIB vaut -1,0,1,2,3, alors les arguments de sortie ont la
27 ! signification suivante:
28 ! KNARG1 (Sortie) ==> Nombre de bits de codage eventuel;
29 ! KNARG2 (Sortie) ==> Sous-troncature non codee " -le;
30 ! KNARG3 (Sortie) ==> Puissance de laplacien eventuelle.
31 ! Si KNGRIB vaut 4, alors les arguments de sortie ont la signification
32 ! suivante:
33 ! KNARG1 (Sortie) ==> Taille de la couronne a conserver
34 ! KNARG2 (Sortie) ==> Nombre de bits utilises pour le codage
35 ! KNARG3 (Sortie) ==> Inutilise
36 !
37 !
38 ! KNARG1 n'a de sens que si l'article existe et a ete code;
39 ! de meme pour KNARG2 et KNARG3, qui ne sont applicables qu'a un
40 ! champ represente en coefficients spectraux.
41 ! Les arguments de sortie n'ayant pas de sens sont mis a
42 ! 0 pour les entiers, .FALSE. pour les logiques.
43 !
44 !
45 !
46 TYPE(fa_com) :: FA
47 INTEGER (KIND=JPLIKB) KREP, KNUMER, KNIVAU, KNGRIB
48 INTEGER (KIND=JPLIKB) KNARG1, KNARG2, KNARG3
49 !
50 INTEGER (KIND=JPLIKB) IREP, ILPRFU, ILSUFU, ILNOMU
51 INTEGER (KIND=JPLIKB) ILONGA, IRANG, INIMES
52 INTEGER (KIND=JPLIKB) ILPREF, ILSUFF, IPOSEX
53 INTEGER (KIND=JPLIKB) IRANGC, ILCHAM
54 !
55 INTEGER (KIND=JPLIKB) IVALCO (5)
56 INTEGER (KIND=JPLIKB) IB1PAR (3)
57 !
58 LOGICAL LLVERF, LLRLFI, LDCOSP, LDEXIS, LLTEMP, LLNOMU, LLMLAM
59 !
60 CHARACTER CDPREF*(*), CDSUFF*(*)
61 CHARACTER CLPREF*(fa%jpxnom), CLSUFF*(fa%jpxsuf)
62 !
63 CHARACTER(LEN=FA%JPXNOM) CLNOMA
64 CHARACTER(LEN=FA%JPLMES) CLMESS
65 CHARACTER(LEN=FA%JPLSPX) CLNSPR
66 LOGICAL LLFATA
67 
68 !**
69 ! 1. - CONTROLES ET INITIALISATIONS.
70 !-----------------------------------------------------------------------
71 !
72 REAL(KIND=JPRB) :: ZHOOK_HANDLE
73 IF (lhook) CALL dr_hook('FANION_MT',0,zhook_handle)
74 irep=0
75 llverf=.false.
76 lltemp=.false.
77 llrlfi=.false.
78 llnomu=.false.
79 ilprfu=int(len(cdpref), jplikb)
80 ilsufu=int(len(cdsuff), jplikb)
81 ldexis=.false.
82 ldcosp=.false.
83 kngrib=0
84 knarg1=0
85 knarg2=0
86 knarg3=0
87 CALL fanumu_fort &
88 & (fa, knumer,irang)
89 !
90 IF (irang.EQ.0) THEN
91  irep=-51
92  GOTO 1001
93 ENDIF
94 !
95 ! Verrouillage eventuel du fichier.
96 !
97 IF (fa%LFAMUL) CALL lfiver_fort &
98 & (fa%LFI, fa%FICHIER(irang)%VRFICH,'ON')
99 llverf=fa%LFAMUL
100 !
101 IF (fa%FICHIER(irang)%LCREAF) GOTO 1001
102 !**
103 ! 2. - FABRICATION DU NOM D'ARTICLE VIA LE SOUS-PROGRAMME "FANFAR"
104 ! ( controles de CDPREF, KNIVAU, CDSUFF inclus )
105 !-----------------------------------------------------------------------
106 !
107 CALL fanfar_fort &
108 & (fa, irep,irang,cdpref,knivau,cdsuff,clnoma, &
109 & ib1par,ilprfu,ilsufu,ilnomu)
110 IF (irep.NE.0) GOTO 1001
111 llnomu=.true.
112 !**
113 ! 3. - RECHERCHE DE L'ARTICLE SUR LE FICHIER, LECTURE PARTIELLE.
114 !-----------------------------------------------------------------------
115 !
116 CALL lfinfo_fort &
117 & (fa%LFI, irep,knumer,clnoma(1:ilnomu), &
118 & ilonga,iposex)
119 llrlfi=irep.NE.0
120 IF (llrlfi.OR.ilonga.EQ.0) GOTO 1001
121 ldexis=.true.
122 !
123 IF (ilonga.GT.fa%JPXCHA+2) THEN
124  irep=-90
125  GOTO 1001
126 ENDIF
127 !
128 IF (fa%FICHIER(irang)%LERRFA) THEN
129 !
130 ! Le fichier est gere en mode "toute erreur est fatale".
131 ! Ce mode etant normalement couple au mode correspondant du logiciel
132 ! LFI, on va temporairement annuler l'option LFI afin de pouvoir
133 ! faire une lecture partielle de l'entete de l'article Champ.
134 !
135  CALL lfierf_fort &
136 & (fa%LFI, irep,knumer,.false.)
137  llrlfi=irep.NE.0
138  IF (llrlfi) GOTO 1001
139  lltemp=.true.
140 ENDIF
141 !
142 CALL lfilec_fort &
143 & (fa%LFI, irep,knumer,clnoma(1:ilnomu), &
144 & ivalco,5_jplikb )
145 !
146 IF (irep.EQ.0) THEN
147  irep=-93
148  GOTO 1001
149 ELSEIF (irep.NE.-21) THEN
150  llrlfi=.true.
151  GOTO 1001
152 ELSEIF ((ivalco(1).LT.-2 .OR. ivalco(1).GT.4 .OR. &
153 & (ivalco(2).LT.0 .OR. ivalco(2).GT.1 .OR. &
154 & (ivalco(1).GT.0 .AND. ivalco(2).EQ.1 .AND. ivalco(4).LT.0)))&
155 & .AND. (.NOT. falgra(ivalco(1)))) THEN
156  irep=-91
157  GOTO 1001
158 ELSE
159  irep=0
160  kngrib=ivalco(1)
161  ldcosp=ivalco(2).EQ.1
162 ENDIF
163 !
164 irangc=fa%FICHIER(irang)%NUCADR
165 llmlam=fa%CADRE(irangc)%LIMLAM
166 !
167 IF (ldcosp) THEN
168  IF (llmlam) THEN
169  ilcham=fa%CADRE(irangc)%NSFLAM
170  ELSE
171  IF (kngrib.EQ.3 .OR. kngrib.EQ.-1) THEN
172  ilcham=(1+fa%CADRE(irangc)%MTRONC)*(2+fa%CADRE(irangc)%MTRONC)
173  ELSE
174  ilcham=(1+fa%CADRE(irangc)%MTRONC)**2
175  ENDIF
176  ENDIF
177 ELSE
178  ilcham=fa%CADRE(irangc)%NVAPDG
179 ENDIF
180 !
181 IF (kngrib.EQ.-1 .OR. kngrib.EQ.0) THEN
182 !
183 ! Cas ou il n'y a aucun codage... controle longueur d'article
184 !
185  IF (ilonga.LT.(ilcham+2)) THEN
186  irep=-93
187  GOTO 1001
188  ELSEIF (ilonga.GT.(ilcham+2)) THEN
189  irep=-94
190  IF (llmoer(irep,irang)) GOTO 1001
191  ENDIF
192 !
193 ELSEIF (kngrib.EQ.-2) THEN
194  IF (ilonga .LT. ((ilcham+1)/2+2)) THEN
195  irep=-93
196  GOTO 1001
197  ELSEIF (ilonga .GT. ((ilcham+1)/2+2)) THEN
198  irep=-94
199  IF (llmoer(irep,irang)) GOTO 1001
200  ENDIF
201 ELSEIF (kngrib.EQ.4) THEN
202  knarg1=ivalco(3)
203  knarg2=ivalco(4)
204 ELSEIF (falgra(kngrib)) THEN
205  ldcosp=ivalco(2).EQ.1
206  knarg1=ivalco(3)
207 ELSE
208 !
209 ! Cas avec codage GRIB (standard ou non).
210 !
211  knarg1=ivalco(3)
212 !
213  IF (ldcosp) THEN
214  knarg2=ivalco(4)
215  knarg3=ivalco(5)
216 !
217  IF (kngrib.EQ.2.AND.ilonga.LT.(5+(1+knarg2)**2)) THEN
218  irep=-93
219  GOTO 1001
220  ENDIF
221 !
222  ENDIF
223 !
224 ENDIF
225 !**
226 ! 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
227 ! VIA LE SOUS-PROGRAMME "FAIPAR" .
228 !-----------------------------------------------------------------------
229 !
230 1001 CONTINUE
231 !
232 IF (lltemp) THEN
233 !
234 ! On remet le fichier en mode "toute erreur fatale" au niveau
235 ! du logiciel LFI.
236 !
237  CALL lfierf_fort &
238 & (fa%LFI, irep,knumer,.true.)
239  llrlfi=irep.NE.0
240 ENDIF
241 !
242 krep=irep
243 llfata=llmoer(irep,irang)
244 !
245 ! Deverrouillage eventuel du fichier.
246 !
247 IF (llverf) CALL lfiver_fort &
248 & (fa%LFI, fa%FICHIER(irang)%VRFICH,'OFF')
249 !
250 IF (llfata) THEN
251  inimes=2
252 ELSE
253  inimes=ixnvms(irang)
254 ENDIF
255 !
256 IF (.NOT.llfata.AND.inimes.NE.2) THEN
257  IF (lhook) CALL dr_hook('FANION_MT',1,zhook_handle)
258  RETURN
259 ENDIF
260 !
261 clnspr='FANION'
262 !
263 IF (ilprfu.GE.1) THEN
264  ilpref=min(ilprfu,int(len(clpref), jplikb))
265  clpref(1:ilpref)=cdpref(1:ilpref)
266 ELSE
267  ilpref=8
268  clpref(1:ilpref)=fa%CHAINC(:ilpref)
269 ENDIF
270 !
271 IF (ilsufu.GE.1) THEN
272  ilsuff=min(ilsufu,int(len(clsuff), jplikb))
273  clsuff(1:ilsuff)=cdsuff(1:ilsuff)
274 ELSE
275  ilsuff=8
276  clsuff(1:ilsuff)=fa%CHAINC(:ilsuff)
277 ENDIF
278 !
279 IF (.NOT.llnomu) THEN
280  ilnomu=min(ilpref,fa%NCPCAD)
281  clnoma(1:ilnomu)=clpref(1:ilpref)
282 ENDIF
283 !
284 WRITE (unit=clmess, &
285 & fmt='(''ARGUMENTS:'',I4,'','',I3,'','''''',A, &
286 & '''''','',I6,'','''''',A,'''''', LDEXIS= '',L1, &
287 & '', LDCOSP= '',L1,'', KNGRIB='',I2,'', KNARG1='',I3, &
288 & '',KNARG2='',I3,'',KNARG3='',I6)') &
289 & krep,knumer,clpref(1:ilpref),knivau,clsuff(1:ilsuff),ldexis, &
290 & ldcosp,kngrib,knarg1,knarg2,knarg3
291 CALL faipar_fort &
292 & (fa, knumer,inimes,irep,llfata,clmess, &
293 & clnspr,clnoma(1:ilnomu),llrlfi)
294 !
295 IF (lhook) CALL dr_hook('FANION_MT',1,zhook_handle)
296 
297 CONTAINS
298 
299 #include "facom2.llmoer.h"
300 #include "facom2.ixnvms.h"
301 #include "falgra.h"
302 
303 END SUBROUTINE fanion_fort
304 
305 
306 
307 ! Oct-2012 P. Marguinaud 64b LFI
308 SUBROUTINE fanion64 &
309 & (krep, knumer, cdpref, knivau, cdsuff, ldexis, &
310 & ldcosp, kngrib, knarg1, knarg2, knarg3)
311 USE fa_mod, ONLY : fa => fa_com_default, &
312 & fa_com_default_init, &
313 & new_fa_default
314 USE lfi_precision
315 IMPLICIT NONE
316 ! Arguments
317 INTEGER (KIND=JPLIKB) KREP ! OUT
318 INTEGER (KIND=JPLIKB) KNUMER ! IN
319 CHARACTER (LEN=*) CDPREF ! IN
320 INTEGER (KIND=JPLIKB) KNIVAU ! IN
321 CHARACTER (LEN=*) CDSUFF ! IN
322 LOGICAL LDEXIS ! OUT
323 LOGICAL LDCOSP ! OUT
324 INTEGER (KIND=JPLIKB) KNGRIB ! OUT
325 INTEGER (KIND=JPLIKB) KNARG1 ! OUT
326 INTEGER (KIND=JPLIKB) KNARG2 ! OUT
327 INTEGER (KIND=JPLIKB) KNARG3 ! OUT
328 
329 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
330 
331 CALL fanion_fort &
332 & (fa, krep, knumer, cdpref, knivau, cdsuff, ldexis, &
333 & ldcosp, kngrib, knarg1, knarg2, knarg3)
334 
335 END SUBROUTINE fanion64
336 
337 SUBROUTINE fanion &
338 & (krep, knumer, cdpref, knivau, cdsuff, ldexis, &
339 & ldcosp, kngrib, knarg1, knarg2, knarg3)
340 USE fa_mod, ONLY : fa => fa_com_default, &
341 & fa_com_default_init, &
342 & new_fa_default
343 USE lfi_precision
344 IMPLICIT NONE
345 ! Arguments
346 INTEGER (KIND=JPLIKM) KREP ! OUT
347 INTEGER (KIND=JPLIKM) KNUMER ! IN
348 CHARACTER (LEN=*) CDPREF ! IN
349 INTEGER (KIND=JPLIKM) KNIVAU ! IN
350 CHARACTER (LEN=*) CDSUFF ! IN
351 LOGICAL LDEXIS ! OUT
352 LOGICAL LDCOSP ! OUT
353 INTEGER (KIND=JPLIKM) KNGRIB ! OUT
354 INTEGER (KIND=JPLIKM) KNARG1 ! OUT
355 INTEGER (KIND=JPLIKM) KNARG2 ! OUT
356 INTEGER (KIND=JPLIKM) KNARG3 ! OUT
357 
358 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
359 
360 CALL fanion_mt &
361 & (fa, krep, knumer, cdpref, knivau, cdsuff, ldexis, &
362 & ldcosp, kngrib, knarg1, knarg2, knarg3)
363 
364 END SUBROUTINE fanion
365 
366 SUBROUTINE fanion_mt &
367 & (fa, krep, knumer, cdpref, knivau, cdsuff, ldexis, &
368 & ldcosp, kngrib, knarg1, knarg2, knarg3)
369 USE fa_mod, ONLY : fa_com
370 USE lfi_precision
371 IMPLICIT NONE
372 ! Arguments
373 type(fa_com) fa ! INOUT
374 INTEGER (KIND=JPLIKM) KREP ! OUT
375 INTEGER (KIND=JPLIKM) KNUMER ! IN
376 CHARACTER (LEN=*) CDPREF ! IN
377 INTEGER (KIND=JPLIKM) KNIVAU ! IN
378 CHARACTER (LEN=*) CDSUFF ! IN
379 LOGICAL LDEXIS ! OUT
380 LOGICAL LDCOSP ! OUT
381 INTEGER (KIND=JPLIKM) KNGRIB ! OUT
382 INTEGER (KIND=JPLIKM) KNARG1 ! OUT
383 INTEGER (KIND=JPLIKM) KNARG2 ! OUT
384 INTEGER (KIND=JPLIKM) KNARG3 ! OUT
385 ! Local integers
386 INTEGER (KIND=JPLIKB) IREP ! OUT
387 INTEGER (KIND=JPLIKB) INUMER ! IN
388 INTEGER (KIND=JPLIKB) INIVAU ! IN
389 INTEGER (KIND=JPLIKB) INGRIB ! OUT
390 INTEGER (KIND=JPLIKB) INARG1 ! OUT
391 INTEGER (KIND=JPLIKB) INARG2 ! OUT
392 INTEGER (KIND=JPLIKB) INARG3 ! OUT
393 ! Convert arguments
394 
395 inumer = int( knumer, jplikb)
396 inivau = int( knivau, jplikb)
397 
398 CALL fanion_fort &
399 & (fa, irep, inumer, cdpref, inivau, cdsuff, ldexis, &
400 & ldcosp, ingrib, inarg1, inarg2, inarg3)
401 
402 krep = int( irep, jplikm)
403 kngrib = int( ingrib, jplikm)
404 knarg1 = int( inarg1, jplikm)
405 knarg2 = int( inarg2, jplikm)
406 knarg3 = int( inarg3, jplikm)
407 
408 END SUBROUTINE fanion_mt
409 
410 !INTF KREP OUT
411 !INTF KNUMER IN
412 !INTF CDPREF IN
413 !INTF KNIVAU IN
414 !INTF CDSUFF IN
415 !INTF LDEXIS OUT
416 !INTF LDCOSP OUT
417 !INTF KNGRIB OUT
418 !INTF KNARG1 OUT
419 !INTF KNARG2 OUT
420 !INTF KNARG3 OUT
lfi_precision::jplikb
integer, parameter jplikb
Definition: lfi_precision.F90:25
lfierf_fort
subroutine lfierf_fort(LFI, KREP, KNUMER, LDERFA)
Definition: lfierf.F90:6
yomhook::dr_hook
Definition: yomhook.F90:20
fa_mod::fa_com_default_init
logical, save fa_com_default_init
Definition: fa_mod.F90:477
fa_mod::new_fa_default
subroutine new_fa_default()
Definition: fa_mod.F90:649
fanion_mt
subroutine fanion_mt(FA, KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, LDEXIS, LDCOSP, KNGRIB, KNARG1, KNARG2, KNARG3)
Definition: fanion.F90:369
fanion64
subroutine fanion64(KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, LDEXIS, LDCOSP, KNGRIB, KNARG1, KNARG2, KNARG3)
Definition: fanion.F90:311
fa_mod
Definition: fa_mod.F90:1
lfinfo_fort
subroutine lfinfo_fort(LFI, KREP, KNUMER, CDNOMA, KLONG, KPOSEX)
Definition: lfinfo.F90:6
lfiver_fort
subroutine lfiver_fort(LFI, PVEROU, CDSENS)
Definition: lfiver.F90:6
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
fanfar_fort
subroutine fanfar_fort(FA, KREP, KRANG, CDPREF, KNIVAU, CDSUFF, CDNOMA, KB1PAR, KLPRFU, KLSUFU, KLNOMU)
Definition: fanfar.F90:6
fanion
subroutine fanion(KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, LDEXIS, LDCOSP, KNGRIB, KNARG1, KNARG2, KNARG3)
Definition: fanion.F90:340
lfilec_fort
subroutine lfilec_fort(LFI, KREP, KNUMER, CDNOMA, KTAB, KLONG)
Definition: lfilec.F90:6
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
fanion_fort
subroutine fanion_fort(FA, KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, LDEXIS, LDCOSP, KNGRIB, KNARG1, KNARG2, KNARG3)
Definition: fanion.F90:6
lfi_precision::jplikm
integer, parameter jplikm
Definition: lfi_precision.F90:25
fa_mod::fa_com_default
type(fa_com), target, save fa_com_default
Definition: fa_mod.F90:476
faipar_fort
subroutine faipar_fort(FA, KNUMER, KNIMES, KCODE, LDFATA, CDMESS, CDNSPR, CDACTI, LDRLFI)
Definition: faipar.F90:6
fa_mod::fa_com
Definition: fa_mod.F90:252
fanumu_fort
subroutine fanumu_fort(FA, KNUMER, KRANG)
Definition: fanumu.F90:5
lfi_precision
Definition: lfi_precision.F90:1
Generated on Tue Jan 16 2018 16:23:21 for SURFEX v8.1 by   doxygen 1.8.13