SURFEX v8.1
General documentation of Surfex
faipag.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 faipag_fort &
4 & (fa, krep, knumer, cdpref, knivau, cdsuff, &
5 & knipar, ydgr1tab)
6 USE fa_mod, ONLY : fa_com, jpniil, fagr1tab, nundef
7 USE parkind1, ONLY : jprb
8 USE yomhook , ONLY : lhook, dr_hook
9 USE lfi_precision
10 IMPLICIT NONE
11 !****
12 ! Sous-programme du logiciel de Fichiers ARPEGE:
13 ! Initialisation de quelques descripteurs de l'entete Gribex
14 ! (section 1) relatifs au parametre, a partir du nom FA du champ.
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 ! ( Tableau ) KNIPAR (Sortie) ==> quelques descripteurs de la section 1 de
22 ! GRIBEX (KNIPAR(1) =KSEC1(1),
23 ! KNIPAR(2:5)=KSEC1(6:9),
24 ! KNIPAR(7)=KSEC1(23) ) et un
25 ! indicateur de type de champ (KNIPAR(6)=
26 ! KSEC1(18)):0->RAS; 2->min/max; 4->cumul,
27 ! 8->cumul depuis le debut
28 !
29 !
30 ! Original : 06 juillet 2004, Denis Paradis DSI/DEV
31 ! --------
32 !
33 ! Modifications
34 ! -------------
35 ! R. El Ouaraini: 03-Oct-2006, enlever le commentaire de l'initialisation de KNIPAR(3) pour
36 ! les types de niveaux : hauteur, iso-tourb potent, isentrope et modele.
37 ! R. El Khatib 24-Jul-2015 No use of the correspondence table if no external grib file
38 !
39 !*
40 !
41 !
42 TYPE(fa_com) :: FA
43 INTEGER (KIND=JPLIKB) KREP, KNUMER, KNIVAU, KNIPAR(8)
44 !
45 CHARACTER (LEN=*) CDPREF, CDSUFF
46 !
47 type(fagr1tab) :: ydgr1tab
48 !
49 INTEGER (KIND=JPLIKB) IRANG, INIMES, J, JMEM, ILENMIN
50 !
51 INTRINSIC len_trim
52 !
53 CHARACTER(LEN=FA%JPLMES) CLMESS
54 CHARACTER(LEN=FA%JPLSPX) CLNSPR
55 LOGICAL LLFATA
56 LOGICAL LLNIVA
57 type(fagr1tab) ydgr1dum
58 !
59 
60 !**
61 ! 0. - INITIALISATIONS PREALABLES
62 !-----------------------------------------------------------------------
63 !
64 !
65 REAL(KIND=JPRB) :: ZHOOK_HANDLE
66 IF (lhook) CALL dr_hook('FAIPAG_MT',0,zhook_handle)
67 krep=0
68 
69 CALL fanumu_fort &
70 & (fa, knumer,irang)
71 !
72 IF (irang.LE.0.OR.irang.GT.fa%JPNXFA) THEN
73  krep=-66
74  GOTO 1001
75 ENDIF
76 !
77 ! DEFAUTS:
78 !
79 ! Numero de version de la table de code parametres
80 knipar(1)=1
81 ! Indicateur de parametre (255=> valeur manquante)
82 knipar(2)=255
83 ! Indicateur de type de niveau (1=> surface)
84 knipar(3)=1
85 ! Niveau 1, Niveau 2 et type de champs
86 knipar(4:6)=0
87 !
88 knipar(7)=0
89 !**
90 ! 1. - UTILISATION DE LA TABLE DE CORRESPONDANCE (SEULEMENT POUR UN FICHIER EXTERNE AU FORMAT GRIB)
91 !--------------------------------------------------------------------------------------------------------
92 !
93 !
94 IF ((any(ydgr1tab%NCODPA == ydgr1dum%NCODPA)).AND.fa%FICHIER(irang)%NCOGRIF(12)==0) THEN
95  jmem = 0
96  DO j = 1,fa%NBPARC
97  ilenmin=min(len_trim(cdsuff),len_trim(fa%YGR1TAB(j)%CISUFF))
98  IF (cdpref(1:len_trim(cdpref)).EQ.fa%YGR1TAB(j)%CIPREF(1:len_trim(fa%YGR1TAB(j)%CIPREF)) .AND. &
99 & cdsuff(1:ilenmin).EQ.fa%YGR1TAB(j)%CISUFF(1:ilenmin)) THEN
100  jmem = j
101  EXIT
102  ELSEIF (cdpref(1:len_trim(cdpref))//cdsuff(1:len_trim(cdsuff)).EQ. &
103 & fa%YGR1TAB(j)%CIPREF(1:len_trim(fa%YGR1TAB(j)%CIPREF))// &
104 & fa%YGR1TAB(j)%CISUFF(1:len_trim(fa%YGR1TAB(j)%CISUFF))) THEN
105  jmem = j
106  EXIT
107  ENDIF
108  ENDDO
109  IF (fa%LFAMOP.AND.jmem.EQ.0) THEN
110  WRITE (unit=fa%NULOUT,fmt=*) &
111 & 'FAIPAG: WARNING, pas de reference GRIB pour ', &
112 & cdpref(1:len_trim(cdpref))//cdsuff(1:len_trim(cdsuff))
113  WRITE (unit=fa%NULOUT,fmt=*)' Les defauts seront utilises'
114  GOTO 1001
115  ENDIF
116  IF (jmem /= 0) THEN
117  ydgr1tab = fa%YGR1TAB(jmem)
118  ELSE
119  ydgr1tab = ydgr1dum
120  ENDIF
121 ENDIF
122 
123 IF (all(ydgr1tab%NCODPA /= ydgr1dum%NCODPA)) THEN
124  knipar = ydgr1tab%NCODPA(1:8)
125  llniva = ydgr1tab%LFNIVA
126 ELSE
127  llniva=.false.
128 ENDIF
129 
130 !**
131 ! 2. - INITIALISATION DU NIVEAU (AUTRE QUE 0)
132 !--------------------------------------------------
133 !
134 ! 2.1 - Champs sur un niveau isobare
135 !
136 IF (cdpref(1:len_trim(cdpref)).EQ.'P') THEN
137 ! La pression est sur 5 chiffres: on la ramene a l'hPa
138 ! et on recree le niveau 1000 hPa
139 !
140 ! Si KNIVAU < 100, la pression fait moins d'un hPa et
141 ! on utilise une extension du GRIB introduite par le CEP:
142 ! KSEC1(7) = 210 (au lieu de 100)
143 ! et KSEC1(8) = pression en Pa
144 !
145  IF (knivau .GE. 100) THEN
146  IF (knipar(2) == 255) knipar(3)=100
147  IF (.NOT. llniva) knipar(4)=knivau/100
148  ELSEIF (knivau==0) THEN
149  IF (knipar(2) == 255) knipar(3)=100
150  IF (.NOT. llniva) knipar(4)=1000
151  ELSE
152  IF (knipar(2) == 255) knipar(3)=210
153  IF (.NOT. llniva) knipar(4)=knivau
154  ENDIF
155 !
156 ! 2.2 - Champs sur un niveau hauteur
157 !
158 ELSEIF (cdpref(1:len_trim(cdpref)).EQ.'H') THEN
159  IF (knipar(2) == 255) knipar(3)=105
160  IF (.NOT. llniva) knipar(4)=knivau
161 !
162 ! 2.3 - Champs sur un niveau iso-tourbillon-potentiel
163 !
164 ! ( unite SI = K m2 s-1 kg-1 = 10+6 PVU
165 ! mais l'unite retenu est le milliPVU: 10-9 SI)
166 ELSEIF (cdpref(1:len_trim(cdpref)).EQ.'V') THEN
167  IF (knipar(2) == 255) knipar(3)=117
168 ! KNIVAU est exprime en 1/10 PVU
169  IF (.NOT. llniva) THEN
170  knipar(4)=knivau*100
171  IF (knivau==0) knipar(4)=1000
172  ENDIF
173 !
174 ! 2.4 - Champs sur un niveau isentrope
175 !
176 ELSEIF (cdpref(1:len_trim(cdpref)).EQ.'T') THEN
177  IF (knipar(2) == 255) knipar(3)=107
178  IF (.NOT. llniva) knipar(4)=knivau
179 !
180 ! 2.5 - Champs sur un niveau modele
181 !
182 ELSEIF (cdpref(1:len_trim(cdpref)).EQ.'S') THEN
183  IF (knipar(2) == 255) knipar(3)=109
184  IF (.NOT. llniva) knipar(4)=knivau
185 ELSEIF (cdpref(1:len_trim(cdpref)).EQ.'KT') THEN
186  IF (knipar(2) == 255) knipar(3)=115
187  IF (.NOT. llniva) THEN
188  SELECT CASE (knivau)
189  CASE (273)
190  knipar(4)=27315
191  CASE (263)
192  knipar(4)=26315
193  CASE DEFAULT
194  knipar(4)=knivau*100
195  END SELECT
196  ENDIF
197 ENDIF
198 !
199 !**
200 ! 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
201 ! VIA LE SOUS-PROGRAMME "FAIPAR" .
202 !-----------------------------------------------------------------------
203 !
204 1001 CONTINUE
205 llfata=llmoer(krep,irang)
206 !
207 IF (fa%LFAMOP.OR.llfata) THEN
208  inimes=2
209  clnspr='FAIPAG'
210 !
211  WRITE (unit=fa%NULOUT,fmt=*)'FAIPAG: KNIPAR(1:7) = ',knipar(1:7)
212  WRITE (unit=fa%NULOUT,fmt=*)
213  WRITE (unit=clmess,fmt='(''KREP='',I4,'', IRANG='',I4, &
214 & '', CDPREF='''''',A,'''''', KNIVAU='',I6, &
215 & '', CDSUFF='''''',A,'''''''')') &
216 & krep, irang, cdpref(1:len_trim(cdpref)), knivau, &
217 & cdsuff(1:len_trim(cdsuff))
218  CALL faipar_fort &
219 & (fa, knumer,inimes,krep,.false.,clmess, &
220 & clnspr,cdpref,.false.)
221 ENDIF
222 !
223 IF (lhook) CALL dr_hook('FAIPAG_MT',1,zhook_handle)
224 
225 CONTAINS
226 
227 #include "facom2.llmoer.h"
228 
229 END SUBROUTINE faipag_fort
230 
231 ! Oct-2012 P. Marguinaud 64b LFI
232 SUBROUTINE faipag64 &
233 & (krep, knumer, cdpref, knivau, cdsuff, knipar, &
234 & ydgr1tab)
235 USE fa_mod, ONLY : fa => fa_com_default, &
236 & fa_com_default_init, &
237 & new_fa_default, &
238 & fagr1tab
239 USE lfi_precision
240 IMPLICIT NONE
241 ! Arguments
242 INTEGER (KIND=JPLIKB) KREP ! OUT
243 INTEGER (KIND=JPLIKB) KNUMER ! IN
244 CHARACTER (LEN=*) CDPREF ! IN
245 INTEGER (KIND=JPLIKB) KNIVAU ! IN
246 CHARACTER (LEN=*) CDSUFF ! IN
247 INTEGER (KIND=JPLIKB) KNIPAR (8) ! OUT
248 type(fagr1tab) ydgr1tab ! INOUT
249 
250 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
251 
252 CALL faipag_fort &
253 & (fa, krep, knumer, cdpref, knivau, cdsuff, knipar, &
254 & ydgr1tab)
255 
256 END SUBROUTINE faipag64
257 
258 SUBROUTINE faipag &
259 & (krep, knumer, cdpref, knivau, cdsuff, knipar, &
260 & ydgr1tab)
261 USE fa_mod, ONLY : fa => fa_com_default, &
262 & fa_com_default_init, &
263 & new_fa_default, &
264 & fagr1tab
265 USE lfi_precision
266 IMPLICIT NONE
267 ! Arguments
268 INTEGER (KIND=JPLIKM) KREP ! OUT
269 INTEGER (KIND=JPLIKM) KNUMER ! IN
270 CHARACTER (LEN=*) CDPREF ! IN
271 INTEGER (KIND=JPLIKM) KNIVAU ! IN
272 CHARACTER (LEN=*) CDSUFF ! IN
273 INTEGER (KIND=JPLIKM) KNIPAR (8) ! OUT
274 type(fagr1tab) ydgr1tab ! INOUT
275 
276 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
277 
278 CALL faipag_mt &
279 & (fa, krep, knumer, cdpref, knivau, cdsuff, knipar, ydgr1tab)
280 
281 END SUBROUTINE faipag
282 
283 SUBROUTINE faipag_mt &
284 & (fa, krep, knumer, cdpref, knivau, cdsuff, knipar, &
285 & ydgr1tab)
286 USE fa_mod, ONLY : fa_com, fagr1tab
287 USE lfi_precision
288 IMPLICIT NONE
289 ! Arguments
290 type(fa_com) fa ! INOUT
291 INTEGER (KIND=JPLIKM) KREP ! OUT
292 INTEGER (KIND=JPLIKM) KNUMER ! IN
293 CHARACTER (LEN=*) CDPREF ! IN
294 INTEGER (KIND=JPLIKM) KNIVAU ! IN
295 CHARACTER (LEN=*) CDSUFF ! IN
296 INTEGER (KIND=JPLIKM) KNIPAR (8) ! OUT
297 type(fagr1tab) ydgr1tab ! INOUT
298 ! Local integers
299 INTEGER (KIND=JPLIKB) IREP ! OUT
300 INTEGER (KIND=JPLIKB) INUMER ! IN
301 INTEGER (KIND=JPLIKB) INIVAU ! IN
302 INTEGER (KIND=JPLIKB) INIPAR (8) ! OUT
303 ! Convert arguments
304 
305 inumer = int( knumer, jplikb)
306 inivau = int( knivau, jplikb)
307 
308 CALL faipag_fort &
309 & (fa, irep, inumer, cdpref, inivau, cdsuff, inipar, ydgr1tab)
310 
311 krep = int( irep, jplikm)
312 knipar = int( inipar, jplikm)
313 
314 END SUBROUTINE faipag_mt
315 
316 !INTF KREP OUT
317 !INTF KNUMER IN
318 !INTF CDPREF IN
319 !INTF KNIVAU IN
320 !INTF CDSUFF IN
321 !INTF KNIPAR OUT DIMS=8
322 !INTF YDGR1TAB INOUT
lfi_precision::jplikb
integer, parameter jplikb
Definition: lfi_precision.F90:25
faipag64
subroutine faipag64(KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, KNIPAR, YDGR1TAB)
Definition: faipag.F90:235
yomhook::dr_hook
Definition: yomhook.F90:20
fa_mod::nundef
integer(kind=jplikb), parameter nundef
Definition: fa_mod.F90:36
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::fagr1tab
Definition: fa_mod.F90:241
fa_mod
Definition: fa_mod.F90:1
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
faipag
subroutine faipag(KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, KNIPAR, YDGR1TAB)
Definition: faipag.F90:261
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
faipar_fort
subroutine faipar_fort(FA, KNUMER, KNIMES, KCODE, LDFATA, CDMESS, CDNSPR, CDACTI, LDRLFI)
Definition: faipar.F90:6
faipag_fort
subroutine faipag_fort(FA, KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, KNIPAR, YDGR1TAB)
Definition: faipag.F90:6
fa_mod::fa_com
Definition: fa_mod.F90:252
fanumu_fort
subroutine fanumu_fort(FA, KNUMER, KRANG)
Definition: fanumu.F90:5
faipag_mt
subroutine faipag_mt(FA, KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, KNIPAR, YDGR1TAB)
Definition: faipag.F90:286
lfi_precision
Definition: lfi_precision.F90:1
fa_mod::jpniil
integer(kind=jplikb), parameter jpniil
Definition: fa_mod.F90:31
Generated on Tue Jan 16 2018 16:23:21 for SURFEX v8.1 by   doxygen 1.8.13