SURFEX v8.1
General documentation of Surfex
fagote.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 fagote_fort &
4 & (fa, krep, knumer, kngrib, knarg1, knarg2, &
5 & knarg3, knarg4, knarg5)
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 ! Ce sous-programme permet d'ajuster, pour un fichier ARPEGE
13 ! ouvert, les options liees au codage GRIB des champs.
14 ! CES OPTIONS NE SONT UTILISEES QUE POUR (RE)ECRIRE DES CHAMPS
15 ! codes en GRIB.
16 ! ( Grib, Options Techniques Effectives )
17 !**
18 ! Arguments : KREP (Sortie) ==> Code-reponse du sous-programme;
19 ! KNUMER (Entree) ==> Numero d'Unite Logique concernee;
20 ! KNGRIB (Entree) ==> Niveau de codage GRIB (-1,0,1,2,3,4);
21 !
22 ! * Pour KNGRIB compris entre -1 et 3, les arguments
23 ! d'entree ont la signification suivante:
24 ! KNARG1 (Entree) ==> Nombre de bits par valeur point-
25 ! de-grille;
26 ! KNARG2 (Entree) ==> Nombre de bits par partie reelle/
27 ! imaginaire de coeff. spectral;
28 ! KNARG3 (Entree) ==> Sous-troncature non compactee;
29 ! KNARG4 (Entree) ==> Puissance de laplacien;
30 ! KNARG5 (Entree) ==> Degre de modulation de KNARG4.
31 !
32 ! Remarque: KNARG3 egal a -1 est accepte; dans ce cas on indexera
33 ! (pour chaque champ spectral ecrit) la sous-troncature
34 ! effective sur la troncature et sur le nombre de bits
35 ! par valeur compactee.
36 !
37 ! * Pour KNGRIB==4, les arguments d'entree ont la
38 ! signification suivante:
39 !
40 ! KNARG1 (Entree) ==> Taille de la couronne a conserver
41 ! KNARG2 (Entree) ==> Nombre de bits pour la mantisse
42 ! KNARG3 (Entree) ==> Inutilise
43 ! KNARG4 (Entree) ==> Inutilise
44 ! KNARG5 (Entree) ==> Inutilise
45 !
46 ! MODIF : 30/03/2007 JM AUDOIN FA%LFAMOP Pour limiter Impression
47 !
48 !
49 !
50 TYPE(fa_com) :: FA
51 INTEGER (KIND=JPLIKB) KREP, KNUMER, KNGRIB
52 INTEGER (KIND=JPLIKB) KNARG1, KNARG2, KNARG3, KNARG4
53 INTEGER (KIND=JPLIKB) KNARG5
54 !
55 INTEGER (KIND=JPLIKB) IMINIM, IREP, IRANGC
56 INTEGER (KIND=JPLIKB) ITRONC, INIMES, IRANG, ITYPTR
57 !
58 LOGICAL LLVERF, LLMLAM
59 !
60 CHARACTER(LEN=FA%JPXNOM) CLACTI
61 CHARACTER(LEN=FA%JPLMES) CLMESS
62 CHARACTER(LEN=FA%JPLSPX) CLNSPR
63 LOGICAL LLFATA
64 
65 !**
66 ! 1. - CONTROLES ET INITIALISATIONS.
67 !-----------------------------------------------------------------------
68 !
69 REAL(KIND=JPRB) :: ZHOOK_HANDLE
70 IF (lhook) CALL dr_hook('FAGOTE_MT',0,zhook_handle)
71 clacti=''
72 llverf=.false.
73 CALL fanumu_fort &
74 & (fa, knumer,irang)
75 !
76 
77 IF (irang.EQ.0) THEN
78  irep=-51
79  GOTO 1001
80 ENDIF
81 
82 IF (((kngrib >= -1) .AND. (kngrib <= 3)) .OR. falgra(kngrib)) THEN
83 
84  iminim=min(2+kngrib,2+knarg1,2+knarg2,2+knarg3,1+knarg5)
85 
86  IF (iminim.LE.0) THEN
87  irep=-64
88  GOTO 1001
89  ELSEIF (knarg1*knarg2.EQ.0 .AND. kngrib.GT.0) THEN
90  irep=-124
91  GOTO 1001
92  ELSEIF ((max(knarg1,knarg2).GT.fa%NBIMAX) .AND. (.NOT. falgra(kngrib)) .AND. (kngrib /= 0)) THEN
93  irep=-97
94  GOTO 1001
95  ELSEIF (abs(knarg4).GT.2**15-1) THEN
96  irep=-98
97  GOTO 1001
98  ENDIF
99 
100 ELSEIF (kngrib == 4) THEN
101 
102  IF ((knarg1 < 0) .OR. (knarg2 < 0)) THEN
103  irep=-64
104  GOTO 1001
105  ENDIF
106 
107 ELSE
108  irep=-96
109  GOTO 1001
110 ENDIF
111 !
112 ! Verrouillage eventuel du fichier.
113 !
114 IF (fa%LFAMUL) CALL lfiver_fort &
115 & (fa%LFI, fa%FICHIER(irang)%VRFICH,'ON')
116 llverf=fa%LFAMUL
117 !
118 irangc=fa%FICHIER(irang)%NUCADR
119 itronc=fa%CADRE(irangc)%MTRONC
120 ityptr=fa%CADRE(irangc)%NTYPTR
121 llmlam=fa%CADRE(irangc)%LIMLAM
122 !
123 
124 IF (kngrib /= 4) THEN
125 
126  IF (knarg3.GE.itronc) THEN
127  irep=-99
128  GOTO 1001
129  ELSEIF (ityptr.LT.0.AND.knarg3.GE.(-ityptr)) THEN
130  irep=-99
131  GOTO 1001
132  ENDIF
133 !**
134 ! 2. - STOCKAGE DES NOUVEAUX PARAMETRES.
135 !-----------------------------------------------------------------------
136 !
137  IF (knarg4.NE.fa%FICHIER(irang)%NPUFLA) THEN
138  fa%FICHIER(irang)%NPUFLA=knarg4
139  fa%FICHIER(irang)%LIFLAP=.true.
140  ENDIF
141  IF (knarg3.NE.fa%FICHIER(irang)%NSTROF) THEN
142  fa%FICHIER(irang)%NSTROF=knarg3
143  fa%FICHIER(irang)%LISC2F=.true.
144  ENDIF
145 !
146  IF (fa%LFAMOP.AND.(fa%FICHIER(irang)%NFGRIB.EQ.3 &
147  & .OR.fa%FICHIER(irang)%NFGRIB.EQ.-1) &
148  & .AND.(kngrib.LT.3.AND.kngrib.GT.-1)) THEN
149  WRITE (unit=fa%NULOUT,fmt=*)'-----------------'
150  WRITE (unit=fa%NULOUT,fmt=*) &
151  & 'FAGOTE: WARNING!! Les champs spectraux NE devront', &
152  & ' PAS etre ranges comme dans le modele (rangt horiz.)', &
153  & ' pour l''unite logique ',knumer
154  WRITE (unit=fa%NULOUT,fmt=*)'-----------------'
155  ENDIF
156  IF (fa%LFAMOP.AND.(fa%FICHIER(irang)%NFGRIB.LT.3 &
157  & .AND.fa%FICHIER(irang)%NFGRIB.GT.-1) &
158  & .AND.(kngrib.EQ.3.OR.kngrib.EQ.-1)) THEN
159  WRITE (unit=fa%NULOUT,fmt=*)'-----------------'
160  WRITE (unit=fa%NULOUT,fmt=*) &
161  & 'FAGOTE: WARNING!! Les champs spectraux devront', &
162  & ' etre ranges comme dans le modele (rangt verti.) pour', &
163  & ' l''unite logique ',knumer
164  WRITE (unit=fa%NULOUT,fmt=*)'-----------------'
165  ENDIF
166 
167  fa%FICHIER(irang)%NBFPDG=knarg1
168  fa%FICHIER(irang)%NBFCSP=knarg2
169  fa%FICHIER(irang)%NMFDPL=knarg5
170 
171 ELSE
172 
173  IF (.NOT. llmlam) THEN
174  irep=-96
175  GOTO 1001
176  ENDIF
177 
178  fa%FICHIER(irang)%NCPLSIZE=knarg1
179  fa%FICHIER(irang)%NCPLBITS=knarg2
180 
181 ENDIF
182 
183 fa%FICHIER(irang)%NFGRIB=kngrib
184 irep=0
185 
186 IF (kngrib /= 4) THEN
187 !
188 ! Appel a FAINOC pour interpreter les eventuels defauts
189 ! de -1 pris par FA%NBFPDG, FA%NBFCSP, FA%NSTROF et FA%NPUFLA en
190 ! IRANG-ieme position.
191 !
192  CALL fainoc_fort (fa, irang)
193 ENDIF
194 !
195 !**
196 ! 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
197 ! VIA LE SOUS-PROGRAMME "FAIPAR" .
198 !-----------------------------------------------------------------------
199 !
200 1001 CONTINUE
201 krep=irep
202 llfata=llmoer(irep,irang)
203 !
204 ! Deverrouillage eventuel du fichier.
205 !
206 IF (llverf) CALL lfiver_fort &
207 & (fa%LFI, fa%FICHIER(irang)%VRFICH,'OFF')
208 !
209 IF (llfata) THEN
210  inimes=2
211 ELSE
212  inimes=ixnvms(irang)
213 ENDIF
214 !
215 IF (.NOT.llfata.AND.inimes.NE.2) THEN
216  IF (lhook) CALL dr_hook('FAGOTE_MT',1,zhook_handle)
217  RETURN
218 ENDIF
219 !
220 clnspr='FAGOTE'
221 !
222 !***** FAZZZZ - KREP=iiii, KNUMER=iii, KNGRIB=ii, KNARG1=iii, *****
223 !***** KNARG2=iii, KNARG3=ii, KNARG4=iii, KNARG5=iii *****
224 WRITE (unit=clmess,fmt='(''KREP='',I4,'', KNUMER='',I3, &
225 & '', KNGRIB='',I2,'', KNARG1='',I3,'', KNARG2='',I3, &
226 & '', KNARG3='',I2,'', KNARG4='',I3,'', KNARG5='',I3)') &
227 & krep,knumer,kngrib,knarg1,knarg2,knarg3,knarg4,knarg5
228 CALL faipar_fort &
229 & (fa, knumer,inimes,irep,llfata,clmess, &
230 & clnspr, clacti,.false.)
231 !
232 IF (lhook) CALL dr_hook('FAGOTE_MT',1,zhook_handle)
233 
234 CONTAINS
235 
236 #include "facom2.llmoer.h"
237 #include "facom2.ixnvms.h"
238 #include "falgra.h"
239 
240 END SUBROUTINE fagote_fort
241 
242 
243 
244 ! Oct-2012 P. Marguinaud 64b LFI
245 SUBROUTINE fagote64 &
246 & (krep, knumer, kngrib, knarg1, knarg2, knarg3, &
247 & knarg4, knarg5)
248 USE fa_mod, ONLY : fa => fa_com_default, &
249 & fa_com_default_init, &
250 & new_fa_default
251 USE lfi_precision
252 IMPLICIT NONE
253 ! Arguments
254 INTEGER (KIND=JPLIKB) KREP ! OUT
255 INTEGER (KIND=JPLIKB) KNUMER ! IN
256 INTEGER (KIND=JPLIKB) KNGRIB ! IN
257 INTEGER (KIND=JPLIKB) KNARG1 ! IN
258 INTEGER (KIND=JPLIKB) KNARG2 ! IN
259 INTEGER (KIND=JPLIKB) KNARG3 ! IN
260 INTEGER (KIND=JPLIKB) KNARG4 ! IN
261 INTEGER (KIND=JPLIKB) KNARG5 ! IN
262 
263 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
264 
265 CALL fagote_fort &
266 & (fa, krep, knumer, kngrib, knarg1, knarg2, knarg3, &
267 & knarg4, knarg5)
268 
269 END SUBROUTINE fagote64
270 
271 SUBROUTINE fagote &
272 & (krep, knumer, kngrib, knarg1, knarg2, knarg3, &
273 & knarg4, knarg5)
274 USE fa_mod, ONLY : fa => fa_com_default, &
275 & fa_com_default_init, &
276 & new_fa_default
277 USE lfi_precision
278 IMPLICIT NONE
279 ! Arguments
280 INTEGER (KIND=JPLIKM) KREP ! OUT
281 INTEGER (KIND=JPLIKM) KNUMER ! IN
282 INTEGER (KIND=JPLIKM) KNGRIB ! IN
283 INTEGER (KIND=JPLIKM) KNARG1 ! IN
284 INTEGER (KIND=JPLIKM) KNARG2 ! IN
285 INTEGER (KIND=JPLIKM) KNARG3 ! IN
286 INTEGER (KIND=JPLIKM) KNARG4 ! IN
287 INTEGER (KIND=JPLIKM) KNARG5 ! IN
288 
289 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
290 
291 CALL fagote_mt &
292 & (fa, krep, knumer, kngrib, knarg1, knarg2, knarg3, &
293 & knarg4, knarg5)
294 
295 END SUBROUTINE fagote
296 
297 SUBROUTINE fagote_mt &
298 & (fa, krep, knumer, kngrib, knarg1, knarg2, knarg3, &
299 & knarg4, knarg5)
300 USE fa_mod, ONLY : fa_com
301 USE lfi_precision
302 IMPLICIT NONE
303 ! Arguments
304 type(fa_com) fa ! INOUT
305 INTEGER (KIND=JPLIKM) KREP ! OUT
306 INTEGER (KIND=JPLIKM) KNUMER ! IN
307 INTEGER (KIND=JPLIKM) KNGRIB ! IN
308 INTEGER (KIND=JPLIKM) KNARG1 ! IN
309 INTEGER (KIND=JPLIKM) KNARG2 ! IN
310 INTEGER (KIND=JPLIKM) KNARG3 ! IN
311 INTEGER (KIND=JPLIKM) KNARG4 ! IN
312 INTEGER (KIND=JPLIKM) KNARG5 ! IN
313 ! Local integers
314 INTEGER (KIND=JPLIKB) IREP ! OUT
315 INTEGER (KIND=JPLIKB) INUMER ! IN
316 INTEGER (KIND=JPLIKB) INGRIB ! IN
317 INTEGER (KIND=JPLIKB) INBPDG ! IN
318 INTEGER (KIND=JPLIKB) INBCSP ! IN
319 INTEGER (KIND=JPLIKB) ISTRON ! IN
320 INTEGER (KIND=JPLIKB) IPUILA ! IN
321 INTEGER (KIND=JPLIKB) IDMOPL ! IN
322 ! Convert arguments
323 
324 inumer = int( knumer, jplikb)
325 ingrib = int( kngrib, jplikb)
326 inbpdg = int( knarg1, jplikb)
327 inbcsp = int( knarg2, jplikb)
328 istron = int( knarg3, jplikb)
329 ipuila = int( knarg4, jplikb)
330 idmopl = int( knarg5, jplikb)
331 
332 CALL fagote_fort &
333 & (fa, irep, inumer, ingrib, inbpdg, inbcsp, istron, &
334 & ipuila, idmopl)
335 
336 krep = int( irep, jplikm)
337 
338 END SUBROUTINE fagote_mt
339 
340 !INTF KREP OUT
341 !INTF KNUMER IN
342 !INTF KNGRIB IN
343 !INTF KNARG1 IN
344 !INTF KNARG2 IN
345 !INTF KNARG3 IN
346 !INTF KNARG4 IN
347 !INTF KNARG5 IN
fagote
subroutine fagote(KREP, KNUMER, KNGRIB, KNARG1, KNARG2, KNARG3, KNARG4, KNARG5)
Definition: fagote.F90:274
lfi_precision::jplikb
integer, parameter jplikb
Definition: lfi_precision.F90:25
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
fa_mod
Definition: fa_mod.F90:1
lfiver_fort
subroutine lfiver_fort(LFI, PVEROU, CDSENS)
Definition: lfiver.F90:6
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
fainoc_fort
subroutine fainoc_fort(FA, KRANG)
Definition: fainoc.F90:5
fagote_fort
subroutine fagote_fort(FA, KREP, KNUMER, KNGRIB, KNARG1, KNARG2, KNARG3, KNARG4, KNARG5)
Definition: fagote.F90:6
fagote_mt
subroutine fagote_mt(FA, KREP, KNUMER, KNGRIB, KNARG1, KNARG2, KNARG3, KNARG4, KNARG5)
Definition: fagote.F90:300
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
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
fagote64
subroutine fagote64(KREP, KNUMER, KNGRIB, KNARG1, KNARG2, KNARG3, KNARG4, KNARG5)
Definition: fagote.F90:248
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