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