SURFEX v8.1
General documentation of Surfex
facono.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 facono_fort &
4 & (fa, krep, knumer, cdpref, knivau, cdsuff, &
5 & pchamp, ldcosp, cdnoma, klnoma, pvalco, &
6 & klongd, ldundf, pundf)
7 USE fa_mod, ONLY : fa_com, fagr1tab
8 USE parkind1, ONLY : jprb
9 USE yomhook , ONLY : lhook, dr_hook
10 USE lfi_precision
11 IMPLICIT NONE
12 !****
13 ! Sous-programme de CODAGE d'un CHAMP HORIZONTAL destine a etre
14 ! ecrit sur un fichier ARPEGE/ALADIN, avec reordonnement des
15 ! coefficients spectraux, le cas echeant (LDCOSP=.TRUE.)
16 ! ( COdage de (Nouvelles ?) Donnees )
17 !**
18 ! Arguments : KREP (Sortie) ==> Code-reponse du sous-programme;
19 ! KNUMER (Entree) ==> Numero de l'unite logique;
20 ! CDPREF (Entree) ==> Prefixe eventuel du nom d'article;
21 ! KNIVAU (Entree) ==> Niveau vertical eventuel;
22 ! CDSUFF (Entree) ==> Suffixe eventuel du nom d'article;
23 ! ( Tableau ) PCHAMP (Entree) ==> Valeurs REELLES du champ a ecrire;
24 ! rangement modele
25 ! LDCOSP (Entree) ==> Vrai si le champ est represente
26 ! par des coefficients spectraux;
27 ! CDNOMA (Sortie) ==> Nom de l'article-champ a ecrire;
28 ! KLNOMA (Sortie) ==> Nombre de caracteres utiles dans
29 ! CDNOMA;
30 ! ( Tableau ) PVALCO (Sortie) ==> Donnees destinees a l'ecriture;
31 ! KLONGD (Entree/Sortie)
32 ! ==> Nombre de valeurs (mots de 64 bits
33 ! en principe) a ecrire.
34 ! LDUNDF (Entree) ==> Vrai si ce champ a des valeurs
35 ! indefinies
36 ! PUNDF (Entree) ==> Dans le cas ou LDUNDF est vrai,
37 ! valeur non definie
38 !
39 TYPE(fa_com) FA
40 INTEGER (KIND=JPLIKB) KREP ! OUT
41 INTEGER (KIND=JPLIKB) KNUMER ! IN
42 CHARACTER (LEN=*) CDPREF ! IN
43 INTEGER (KIND=JPLIKB) KNIVAU ! IN
44 CHARACTER (LEN=*) CDSUFF ! IN
45 REAL (KIND=JPDBLR) PCHAMP (*) ! IN
46 LOGICAL LDCOSP ! IN
47 CHARACTER (LEN=*) CDNOMA ! OUT
48 INTEGER (KIND=JPLIKB) KLNOMA ! OUT
49 REAL (KIND=JPDBLR) PVALCO (*) ! OUT
50 INTEGER (KIND=JPLIKB) KLONGD ! OUT
51 LOGICAL, OPTIONAL :: LDUNDF ! IN
52 REAL (KIND=JPDBLR), OPTIONAL :: PUNDF ! IN
53 !
54 INTEGER (KIND=JPLIKB) IREP
55 INTEGER (KIND=JPLIKB) IRANG, INIMES
56 INTEGER (KIND=JPLIKB) IRANGC
57 INTEGER (KIND=JPLIKB) ISMAX, IMSMAX
58 INTEGER (KIND=JPLIKB) INGRIB
59 !
60 LOGICAL LLVERF, LLRLFI
61 !
62 REAL (KIND=JPDBLR), ALLOCATABLE :: ZCHAMP (:)
63 LOGICAL :: LLUNDF
64 REAL (KIND=JPDBLR) :: ZUNDF
65 !
66 CHARACTER(LEN=FA%JPLMES) CLMESS
67 CHARACTER(LEN=FA%JPLSPX) CLNSPR
68 LOGICAL LLFATA
69 LOGICAL LLREORD
70 type(fagr1tab) ylgr1tab
71 
72 !**
73 ! 1. - CONTROLES ET INITIALISATIONS.
74 !-----------------------------------------------------------------------
75 !
76 REAL(KIND=JPRB) :: ZHOOK_HANDLE
77 IF (lhook) CALL dr_hook('FACONO_MT',0,zhook_handle)
78 
79 llundf = .false.
80 IF (PRESENT (ldundf )) llundf = ldundf
81 zundf = 0._jpdblr
82 IF (PRESENT (pundf )) zundf = pundf
83 
84 irep=0
85 llrlfi=.false.
86 cdnoma=' '
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 irangc=fa%FICHIER(irang)%NUCADR
102 ingrib=fa%FICHIER(irang)%NFGRIB
103 
104 llreord = ldcosp .AND. (.NOT.(ingrib==-1 .OR. ingrib==3 .OR. falgra(ingrib)))
105 
106 IF (llreord) THEN
107  ismax = fa%CADRE(irangc)%NSMAX
108  imsmax = fa%CADRE(irangc)%NMSMAX
109  ALLOCATE (zchamp(4 * (imsmax+1) * (ismax+1))) ! Assez grand
110  CALL fareor_fort (fa, irep, knumer, pchamp, zchamp, .false.)
111  IF (irep /= 0) GOTO 1001
112  CALL facon1_fort (fa, irep, knumer, cdpref, knivau, cdsuff, zchamp, &
113  & ldcosp, cdnoma, klnoma, pvalco, klongd, &
114  & llundf, zundf, ylgr1tab)
115  IF (irep /= 0) GOTO 1001
116  DEALLOCATE (zchamp)
117 ELSE
118  CALL facon1_fort (fa, irep, knumer, cdpref, knivau, cdsuff, pchamp, &
119  & ldcosp, cdnoma, klnoma, pvalco, klongd, &
120  & llundf, zundf, ylgr1tab)
121 ENDIF
122 
123 
124 1001 CONTINUE
125 krep=irep
126 llfata=llmoer(irep,irang)
127 !
128 ! Deverrouillage eventuel du fichier.
129 !
130 IF (llverf) CALL lfiver_fort &
131 & (fa%LFI, fa%FICHIER(irang)%VRFICH,'OFF')
132 !
133 IF (llfata) THEN
134  inimes=2
135 ELSE
136  inimes=ixnvms(irang)
137 ENDIF
138 !
139 IF (.NOT.llfata.AND.inimes.NE.2) THEN
140  IF (lhook) CALL dr_hook('FACONO_MT',1,zhook_handle)
141  RETURN
142 ENDIF
143 !
144 clnspr='FACONO'
145 !
146 WRITE (unit=clmess,fmt='(''KREP='',I4,'', KNUMER='',I3, &
147 & '', CDPREF='''''',A,'''''', KNIVAU='',I6, &
148 & '', CDSUFF='''''',A,'''''', LDCOSP= '',L1)') &
149 & krep,knumer,trim(cdpref),knivau,trim(cdsuff),ldcosp
150 CALL faipar_fort &
151 & (fa, knumer,inimes,irep,llfata,clmess, &
152 & clnspr,trim(cdnoma),llrlfi)
153 !
154 IF (lhook) CALL dr_hook('FACONO_MT',1,zhook_handle)
155 
156 CONTAINS
157 
158 #include "facom2.llmoer.h"
159 #include "facom2.ixnvms.h"
160 #include "falgra.h"
161 
162 END SUBROUTINE facono_fort
163 
164 ! Oct-2012 P. Marguinaud 64b LFI
165 SUBROUTINE facono64 &
166 & (krep, knumer, cdpref, knivau, cdsuff, pchamp, &
167 & ldcosp, cdnoma, klnoma, pvalco, klongd, &
168 & ldundf, pundf)
169 USE fa_mod, ONLY : fa => fa_com_default, &
170 & fa_com_default_init, &
171 & new_fa_default
172 USE lfi_precision
173 IMPLICIT NONE
174 ! Arguments
175 INTEGER (KIND=JPLIKB) KREP ! OUT
176 INTEGER (KIND=JPLIKB) KNUMER ! IN
177 CHARACTER (LEN=*) CDPREF ! IN
178 INTEGER (KIND=JPLIKB) KNIVAU ! IN
179 CHARACTER (LEN=*) CDSUFF ! IN
180 REAL (KIND=JPDBLR) PCHAMP (*) ! IN
181 LOGICAL LDCOSP ! IN
182 CHARACTER (LEN=*) CDNOMA ! OUT
183 INTEGER (KIND=JPLIKB) KLNOMA ! OUT
184 REAL (KIND=JPDBLR) PVALCO (*) ! OUT
185 INTEGER (KIND=JPLIKB) KLONGD ! OUT
186 LOGICAL, OPTIONAL :: LDUNDF ! IN
187 REAL (KIND=JPDBLR), OPTIONAL :: PUNDF ! IN
188 
189 #include "facono_mt64.h"
190 
191 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
192 
193 CALL facono_fort &
194 & (fa, krep, knumer, cdpref, knivau, cdsuff, pchamp, &
195 & ldcosp, cdnoma, klnoma, pvalco, klongd, &
196 & ldundf, pundf)
197 
198 END SUBROUTINE facono64
199 
200 SUBROUTINE facono &
201 & (krep, knumer, cdpref, knivau, cdsuff, pchamp, &
202 & ldcosp, cdnoma, klnoma, pvalco, klongd, &
203 & ldundf, pundf)
204 USE fa_mod, ONLY : fa => fa_com_default, &
205 & fa_com_default_init, &
206 & new_fa_default
207 USE lfi_precision
208 IMPLICIT NONE
209 ! Arguments
210 INTEGER (KIND=JPLIKM) KREP ! OUT
211 INTEGER (KIND=JPLIKM) KNUMER ! IN
212 CHARACTER (LEN=*) CDPREF ! IN
213 INTEGER (KIND=JPLIKM) KNIVAU ! IN
214 CHARACTER (LEN=*) CDSUFF ! IN
215 REAL (KIND=JPDBLR) PCHAMP (*) ! IN
216 LOGICAL LDCOSP ! IN
217 CHARACTER (LEN=*) CDNOMA ! OUT
218 INTEGER (KIND=JPLIKM) KLNOMA ! OUT
219 REAL (KIND=JPDBLR) PVALCO (*) ! OUT
220 INTEGER (KIND=JPLIKM) KLONGD ! OUT
221 LOGICAL, OPTIONAL :: LDUNDF ! IN
222 REAL (KIND=JPDBLR), OPTIONAL :: PUNDF ! IN
223 
224 #include "facono_mt.h"
225 
226 IF (.NOT. fa_com_default_init) CALL new_fa_default ()
227 
228 CALL facono_mt &
229 & (fa, krep, knumer, cdpref, knivau, cdsuff, pchamp, &
230 & ldcosp, cdnoma, klnoma, pvalco, klongd, &
231 & ldundf, pundf)
232 
233 END SUBROUTINE facono
234 
235 SUBROUTINE facono_mt &
236 & (fa, krep, knumer, cdpref, knivau, cdsuff, pchamp, &
237 & ldcosp, cdnoma, klnoma, pvalco, klongd, &
238 & ldundf, pundf)
239 USE fa_mod, ONLY : fa_com
240 USE lfi_precision
241 IMPLICIT NONE
242 ! Arguments
243 type(fa_com) fa ! INOUT
244 INTEGER (KIND=JPLIKM) KREP ! OUT
245 INTEGER (KIND=JPLIKM) KNUMER ! IN
246 CHARACTER (LEN=*) CDPREF ! IN
247 INTEGER (KIND=JPLIKM) KNIVAU ! IN
248 CHARACTER (LEN=*) CDSUFF ! IN
249 REAL (KIND=JPDBLR) PCHAMP (*) ! IN
250 LOGICAL LDCOSP ! IN
251 CHARACTER (LEN=*) CDNOMA ! OUT
252 INTEGER (KIND=JPLIKM) KLNOMA ! OUT
253 REAL (KIND=JPDBLR) PVALCO (*) ! OUT
254 INTEGER (KIND=JPLIKM) KLONGD ! OUT
255 LOGICAL, OPTIONAL :: LDUNDF ! IN
256 REAL (KIND=JPDBLR), OPTIONAL :: PUNDF ! IN
257 
258 #include "facono_mt64.h"
259 
260 ! Local integers
261 INTEGER (KIND=JPLIKB) IREP ! OUT
262 INTEGER (KIND=JPLIKB) INUMER ! IN
263 INTEGER (KIND=JPLIKB) INIVAU ! IN
264 INTEGER (KIND=JPLIKB) ILNOMA ! OUT
265 INTEGER (KIND=JPLIKB) ILONGD ! OUT
266 ! Convert arguments
267 
268 inumer = int( knumer, jplikb)
269 inivau = int( knivau, jplikb)
270 ilongd = int( klongd, jplikb)
271 
272 CALL facono_fort &
273 & (fa, irep, inumer, cdpref, inivau, cdsuff, pchamp, &
274 & ldcosp, cdnoma, ilnoma, pvalco, ilongd, &
275 & ldundf, pundf)
276 
277 krep = int( irep, jplikm)
278 klnoma = int( ilnoma, jplikm)
279 klongd = int( ilongd, jplikm)
280 
281 END SUBROUTINE facono_mt
282 
283 !INTF KREP OUT
284 !INTF KNUMER IN
285 !INTF CDPREF IN
286 !INTF KNIVAU IN
287 !INTF CDSUFF IN
288 !INTF PCHAMP IN DIMS=*
289 !INTF LDCOSP IN
290 !INTF CDNOMA OUT
291 !INTF KLNOMA OUT
292 !INTF PVALCO OUT DIMS=*
293 !INTF KLONGD INOUT
294 !INTF LDUNDF IN
295 !INTF PUNDF IN
296 
trim
static const char * trim(const char *name, int *n)
Definition: drhook.c:2383
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
facono64
subroutine facono64(KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, PCHAMP, LDCOSP, CDNOMA, KLNOMA, PVALCO, KLONGD, LDUNDF, PUNDF)
Definition: facono.F90:169
facono_fort
subroutine facono_fort(FA, KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, PCHAMP, LDCOSP, CDNOMA, KLNOMA, PVALCO, KLONGD, LDUNDF, PUNDF)
Definition: facono.F90:7
fa_mod::fagr1tab
Definition: fa_mod.F90:241
fa_mod
Definition: fa_mod.F90:1
facono_mt
subroutine facono_mt(FA, KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, PCHAMP, LDCOSP, CDNOMA, KLNOMA, PVALCO, KLONGD, LDUNDF, PUNDF)
Definition: facono.F90:239
lfiver_fort
subroutine lfiver_fort(LFI, PVEROU, CDSENS)
Definition: lfiver.F90:6
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
fareor_fort
subroutine fareor_fort(FA, KREP, KNUMER, PCHAMM, PCHAMF, LDFTOM)
Definition: fareor.F90:5
lfi_precision::jplikm
integer, parameter jplikm
Definition: lfi_precision.F90:25
facon1_fort
subroutine facon1_fort(FA, KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, PCHAMP, LDCOSP, CDNOMA, KLNOMA, KVALCO, KLONGD, LDUNDF, PUNDF, YDGR1TAB)
Definition: facon1.F90:7
fa_mod::fa_com_default
type(fa_com), target, save fa_com_default
Definition: fa_mod.F90:476
facono
subroutine facono(KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, PCHAMP, LDCOSP, CDNOMA, KLNOMA, PVALCO, KLONGD, LDUNDF, PUNDF)
Definition: facono.F90:204
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