SURFEX v8.1
General documentation of Surfex
fanfar.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 fanfar_fort &
4 & (fa, krep, krang, cdpref, knivau, cdsuff, &
5 & cdnoma, kb1par, klprfu, klsufu, klnomu )
6 USE fa_mod, ONLY : fa_com, jpniil
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 ARPEGE:
13 ! fabrication d'un nom article devant contenir un champ horizontal.
14 ! (Nom a Fabriquer pour un ARticle)
15 !**
16 ! Arguments : KREP (Sortie) ==> Code-reponse du sous-programme;
17 ! KRANG (Entree) ==> Rang 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 ! CDNOMA (Sortie) ==> Nom d'article;
22 ! ( Tableau ) KB1PAR (Sortie) ==> 3 elements du "Bloc 1" des
23 ! interfaces GRIB concernes par la
24 ! coordonnee et le niveau verticaux;
25 ! KLPRFU (Sortie) ==> Longueur utile du prefixe;
26 ! KLSUFU (Sortie) ==> Longueur utile du suffixe;
27 ! KLNOMU (Sortie) ==> Longueur utile du nom d'article.
28 !*
29 ! En mode multi-taches, il doit y avoir verrouillage du fichier
30 ! concerne avant l'appel au sous-programme.
31 !
32 !
33 !
34 TYPE(fa_com) :: FA
35 INTEGER (KIND=JPLIKB) KREP, KRANG, KNIVAU
36 INTEGER (KIND=JPLIKB) KLPRFU, KLSUFU, KLNOMU
37 INTEGER (KIND=JPLIKB) KB1PAR (3)
38 !
39 CHARACTER CDPREF*(*), CDSUFF*(*), CDNOMA*(*), CLAUXI*(fa%jpxnom)
40 !
41 INTEGER (KIND=JPLIKB) ILPREF, ILSUFF, ILCDNO, ILPRFU
42 INTEGER (KIND=JPLIKB) ILSUFU, J, INCHIF, INIMES
43 INTEGER (KIND=JPLIKB) INUMER, ILACTI, ILNOMA, ILAUXI
44 INTEGER (KIND=JPLIKB) ITYNIV, INIVAU
45 !
46 CHARACTER(LEN=FA%JPXNOM) CLACTI
47 CHARACTER(LEN=FA%JPXNOM) CLNOMA
48 CHARACTER(LEN=FA%JPLMES) CLMESS
49 CHARACTER(LEN=FA%JPLSPX) CLNSPR
50 LOGICAL LLFATA
51 
52 !**
53 ! 1. - CONTROLES DES PARAMETRES D'APPEL, INITIALISATIONS.
54 !-----------------------------------------------------------------------
55 !
56 REAL(KIND=JPRB) :: ZHOOK_HANDLE
57 IF (lhook) CALL dr_hook('FANFAR_MT',0,zhook_handle)
58 clacti=''
59 ilpref=int(len(cdpref), jplikb)
60 ilsuff=int(len(cdsuff), jplikb)
61 ilcdno=int(len(cdnoma), jplikb)
62 ilprfu=max(0_jplikb , ilpref)
63 ilsufu=max(0_jplikb , ilsuff)
64 klnomu=max(0_jplikb , ilcdno)
65 !
66 IF (krang.LE.0.OR.krang.GT.fa%JPNXFA) THEN
67  krep=-66
68  GOTO 1001
69 ENDIF
70 !
71 IF (ilcdno.LE.0.OR.ilcdno.GT.fa%NCPCAD) THEN
72  krep=-66
73  GOTO 1001
74 ELSEIF (min(ilpref,ilsuff).LE.0) THEN
75  krep=-65
76  GOTO 1001
77 ELSEIF (cdpref.EQ.' '.OR.cdsuff.EQ.' ') THEN
78  krep=-86
79  GOTO 1001
80 ENDIF
81 !
82 ! Decompte du nombre de caracteres utiles dans prefixe et suffixe.
83 !
84 DO j=ilpref,1,-1
85 !
86 IF (cdpref(j:j).NE.' ') THEN
87  ilprfu=j
88  GOTO 104
89 ENDIF
90 !
91 ENDDO
92 !
93 krep=-66
94 GOTO 1001
95 !
96 104 CONTINUE
97 !
98 IF (ilprfu.GT.fa%JPXPRF) THEN
99  krep=-87
100  GOTO 1001
101 ENDIF
102 !
103 DO j=ilsuff,1,-1
104 !
105 IF (cdsuff(j:j).NE.' ') THEN
106  ilsufu=j
107  GOTO 106
108 ENDIF
109 !
110 ENDDO
111 !
112 krep=-66
113 GOTO 1001
114 !
115 106 CONTINUE
116 !**
117 ! 2. - DIFFERENTS CAS, SELON LE PREFIXE.
118 !-----------------------------------------------------------------------
119 !
120 DO j=1,fa%JPTNIV
121 !
122 IF (cdpref.EQ.fa%CTNPRF(j)) THEN
123  ityniv=j
124  GOTO 202
125 ENDIF
126 !
127 ENDDO
128 !
129 ityniv=0
130 !
131 202 CONTINUE
132 !
133 inchif=fa%NIVDSC(0,ityniv)
134 !
135 IF (inchif.EQ.0) THEN
136 !
137  inivau=0
138 !
139 ELSEIF (knivau.LT.fa%NIVDSC(1,ityniv).OR. &
140 & knivau.GT.fa%NIVDSC(2,ityniv)) THEN
141 !
142  krep=-64
143  GOTO 1001
144 !
145 ELSEIF (cdpref.EQ.'S'.AND.knivau.GT. &
146 & fa%CADRE(fa%FICHIER(krang)%NUCADR)%NNIVER) THEN
147 !
148  krep=-64
149  GOTO 1001
150 !
151 ELSEIF (cdpref.EQ.'L'.AND.knivau.GT. &
152 & fa%CADRE(fa%FICHIER(krang)%NUCADR)%NNIVER) THEN
153 !
154  krep=-64
155  GOTO 1001
156 !
157 ELSE
158 !
159  inivau=knivau
160 !
161 ENDIF
162 !
163 kb1par(1)=fa%NIVDSC(3,ityniv)
164 kb1par(2)=fa%NIVDSC(4,ityniv)
165 kb1par(3)=inivau
166 !
167 ilsufu=min(ilcdno-ilprfu-inchif,ilsufu)
168 klnomu=ilprfu+inchif+ilsufu
169 !
170 IF (inchif.NE.0) THEN
171  WRITE (unit=clnoma,fmt='(I8.8)') knivau
172  cdnoma=cdpref(1:ilprfu)//clnoma(9-inchif:8)//cdsuff(1:ilsufu)
173 ELSE
174  cdnoma=cdpref(1:ilprfu)//cdsuff(1:ilsufu)
175 ENDIF
176 !
177 IF (cdnoma.EQ.fa%CPCACH.OR.cdnoma.EQ.fa%CPCADI.OR.cdnoma.EQ. &
178 & fa%CPCAFS.OR. &
179 & cdnoma.EQ.fa%CPCARP.OR.cdnoma.EQ.fa%CPDATE.OR. &
180 & cdnoma.EQ.fa%CPDATX.OR. &
181 & cdnoma.EQ.fa%FICHIER(krang)%CIDENT) THEN
182  krep=-111
183  GOTO 1001
184 ENDIF
185 !
186 krep=0
187 !**
188 ! 10. - PHASE TERMINALE : MESSAGERIE EVENTUELLE,
189 ! VIA LE SOUS-PROGRAMME "FAIPAR" .
190 !-----------------------------------------------------------------------
191 !
192 1001 CONTINUE
193 klprfu=ilprfu
194 klsufu=ilsufu
195 llfata=llmoer(krep,krang)
196 !
197 IF (fa%LFAMOP.OR.llfata) THEN
198  inimes=2
199  clnspr='FANFAR'
200  inumer=jpniil
201 !
202  IF (ilprfu.GE.1) THEN
203  ilacti=min(ilprfu,fa%NCPCAD)
204  clacti(1:ilacti)=cdpref(1:ilacti)
205  ELSE
206  ilacti=8
207  clacti(1:ilacti)=fa%CHAINC(:ilacti)
208  ENDIF
209 !
210  IF (ilsufu.GE.1) THEN
211  ilnoma=min(ilsufu,fa%NCPCAD)
212  clnoma(1:ilnoma)=cdsuff(1:ilnoma)
213  ELSE
214  ilnoma=8
215  clnoma(1:ilnoma)=fa%CHAINC(:ilnoma)
216  ENDIF
217 !
218  IF (klnomu.GE.1) THEN
219  ilauxi=min(klnomu,int(len(clauxi), jplikb))
220  clauxi(1:ilauxi)=cdnoma(1:ilauxi)
221  ELSE
222  ilauxi=8
223  clauxi(1:ilauxi)=fa%CHAINC(:ilauxi)
224  ENDIF
225 !
226  WRITE (unit=clmess, &
227 & fmt='(''ARGUMENTS='',2(I4,'', ''),'''''''',A, &
228 & '''''','',I6,'', '''''',A,'''''', '''''',A,'''''''', &
229 & 2('','',I4),'','',I6,3('','',I3))') &
230 & krep,krang,clacti(1:ilacti),knivau,clnoma(1:ilnoma), &
231 & clauxi(1:ilauxi),kb1par,klprfu,klsufu,klnomu
232  CALL faipar_fort &
233 & (fa, inumer,inimes,krep,.false.,clmess, &
234 & clnspr, clacti(1:ilacti),.false.)
235 ENDIF
236 !
237 IF (lhook) CALL dr_hook('FANFAR_MT',1,zhook_handle)
238 
239 CONTAINS
240 
241 #include "facom2.llmoer.h"
242 
243 END SUBROUTINE fanfar_fort
244 
245 
246 
247 
248 
249 
250 
251 
252 ! Oct-2012 P. Marguinaud 64b LFI
253 SUBROUTINE fanfar64 &
254 & (krep, krang, cdpref, knivau, cdsuff, cdnoma, &
255 & kb1par, klprfu, klsufu, klnomu)
256 USE fa_mod, ONLY : fa => fa_com_default, &
257 & fa_com_default_init, &
258 & new_fa_default
259 USE lfi_precision
260 IMPLICIT NONE
261 ! Arguments
262 INTEGER (KIND=JPLIKB) KREP ! OUT
263 INTEGER (KIND=JPLIKB) KRANG ! IN
264 CHARACTER (LEN=*) CDPREF ! IN
265 INTEGER (KIND=JPLIKB) KNIVAU ! IN
266 CHARACTER (LEN=*) CDSUFF ! IN
267 CHARACTER (LEN=*) CDNOMA ! OUT
268 INTEGER (KIND=JPLIKB) KB1PAR (3) ! OUT
269 INTEGER (KIND=JPLIKB) KLPRFU ! OUT
270 INTEGER (KIND=JPLIKB) KLSUFU ! OUT
271 INTEGER (KIND=JPLIKB) KLNOMU ! OUT
272 
273 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
274 
275 CALL fanfar_fort &
276 & (fa, krep, krang, cdpref, knivau, cdsuff, cdnoma, &
277 & kb1par, klprfu, klsufu, klnomu)
278 
279 END SUBROUTINE fanfar64
280 
281 SUBROUTINE fanfar &
282 & (krep, krang, cdpref, knivau, cdsuff, cdnoma, &
283 & kb1par, klprfu, klsufu, klnomu)
284 USE fa_mod, ONLY : fa => fa_com_default, &
285 & fa_com_default_init, &
286 & new_fa_default
287 USE lfi_precision
288 IMPLICIT NONE
289 ! Arguments
290 INTEGER (KIND=JPLIKM) KREP ! OUT
291 INTEGER (KIND=JPLIKM) KRANG ! IN
292 CHARACTER (LEN=*) CDPREF ! IN
293 INTEGER (KIND=JPLIKM) KNIVAU ! IN
294 CHARACTER (LEN=*) CDSUFF ! IN
295 CHARACTER (LEN=*) CDNOMA ! OUT
296 INTEGER (KIND=JPLIKM) KB1PAR (3) ! OUT
297 INTEGER (KIND=JPLIKM) KLPRFU ! OUT
298 INTEGER (KIND=JPLIKM) KLSUFU ! OUT
299 INTEGER (KIND=JPLIKM) KLNOMU ! OUT
300 
301 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
302 
303 CALL fanfar_mt &
304 & (fa, krep, krang, cdpref, knivau, cdsuff, cdnoma, &
305 & kb1par, klprfu, klsufu, klnomu)
306 
307 END SUBROUTINE fanfar
308 
309 SUBROUTINE fanfar_mt &
310 & (fa, krep, krang, cdpref, knivau, cdsuff, cdnoma, &
311 & kb1par, klprfu, klsufu, klnomu)
312 USE fa_mod, ONLY : fa_com
313 USE lfi_precision
314 IMPLICIT NONE
315 ! Arguments
316 type(fa_com) fa ! INOUT
317 INTEGER (KIND=JPLIKM) KREP ! OUT
318 INTEGER (KIND=JPLIKM) KRANG ! IN
319 CHARACTER (LEN=*) CDPREF ! IN
320 INTEGER (KIND=JPLIKM) KNIVAU ! IN
321 CHARACTER (LEN=*) CDSUFF ! IN
322 CHARACTER (LEN=*) CDNOMA ! OUT
323 INTEGER (KIND=JPLIKM) KB1PAR (3) ! OUT
324 INTEGER (KIND=JPLIKM) KLPRFU ! OUT
325 INTEGER (KIND=JPLIKM) KLSUFU ! OUT
326 INTEGER (KIND=JPLIKM) KLNOMU ! OUT
327 ! Local integers
328 INTEGER (KIND=JPLIKB) IREP ! OUT
329 INTEGER (KIND=JPLIKB) IRANG ! IN
330 INTEGER (KIND=JPLIKB) INIVAU ! IN
331 INTEGER (KIND=JPLIKB) IB1PAR (3) ! OUT
332 INTEGER (KIND=JPLIKB) ILPRFU ! OUT
333 INTEGER (KIND=JPLIKB) ILSUFU ! OUT
334 INTEGER (KIND=JPLIKB) ILNOMU ! OUT
335 ! Convert arguments
336 
337 irang = int( krang, jplikb)
338 inivau = int( knivau, jplikb)
339 
340 CALL fanfar_fort &
341 & (fa, irep, irang, cdpref, inivau, cdsuff, cdnoma, &
342 & ib1par, ilprfu, ilsufu, ilnomu)
343 
344 krep = int( irep, jplikm)
345 kb1par = int( ib1par, jplikm)
346 klprfu = int( ilprfu, jplikm)
347 klsufu = int( ilsufu, jplikm)
348 klnomu = int( ilnomu, jplikm)
349 
350 END SUBROUTINE fanfar_mt
351 
352 !INTF KREP OUT
353 !INTF KRANG IN
354 !INTF CDPREF IN
355 !INTF KNIVAU IN
356 !INTF CDSUFF IN
357 !INTF CDNOMA OUT
358 !INTF KB1PAR OUT DIMS=3
359 !INTF KLPRFU OUT
360 !INTF KLSUFU OUT
361 !INTF KLNOMU OUT
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
fanfar_mt
subroutine fanfar_mt(FA, KREP, KRANG, CDPREF, KNIVAU, CDSUFF, CDNOMA, KB1PAR, KLPRFU, KLSUFU, KLNOMU)
Definition: fanfar.F90:312
fa_mod
Definition: fa_mod.F90:1
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
fanfar64
subroutine fanfar64(KREP, KRANG, CDPREF, KNIVAU, CDSUFF, CDNOMA, KB1PAR, KLPRFU, KLSUFU, KLNOMU)
Definition: fanfar.F90:256
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
lfi_precision::jplikm
integer, parameter jplikm
Definition: lfi_precision.F90:25
fanfar
subroutine fanfar(KREP, KRANG, CDPREF, KNIVAU, CDSUFF, CDNOMA, KB1PAR, KLPRFU, KLSUFU, KLNOMU)
Definition: fanfar.F90:284
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
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