SURFEX v8.1
General documentation of Surfex
fadeci.F90
Go to the documentation of this file.
1 ! Oct-2012 P. Marguinaud 64b LFI
2 ! Jan-2011 P. Marguinaud Thread-safe FA
3 ! Sep-2012 P. Marguinaud Fix unitialized variables
4 SUBROUTINE fadeci_fort &
5 & (fa, krep, krang, cdnoma, kvalco, klonga, &
6 & pchamp, ldcosp)
7 USE fa_mod, ONLY : fa_com, jpniil
8 USE parkind1, ONLY : jprb
9 USE yomhook , ONLY : lhook, dr_hook
10 USE lfi_precision
11 IMPLICIT NONE
12 !****
13 ! Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
14 ! Controle de coherence et decodage d'un CHAMP HORIZONTAL
15 ! venant d'etre lu sur un fichier ARPEGE/ALADIN.
16 ! ( DECodage Interne d'un champ lu )
17 !**
18 ! Arguments : KREP (Sortie) ==> Code-reponse du sous-programme;
19 ! KRANG (Entree) ==> Rang de l'unite logique;
20 ! CDNOMA (Entree) ==> Nom d'article (prefabrique);
21 ! ( Tableau ) KVALCO (Entree) ==> Donnees issues de la lecture;
22 ! KLONGA (Entree) ==> Nombre de mots lus;
23 ! ( Tableau ) PCHAMP (Sortie) ==> Valeurs REELLES du champ lu;
24 ! LDCOSP (Entree) ==> Vrai si le champ est represente
25 ! par des coefficients spectraux;
26 !*
27 ! En mode multi-taches, il doit y avoir verrouillage du fichier
28 ! concerne avant l'appel au sous-programme.
29 !
30 ! Modifications
31 ! -------------
32 !
33 ! Avril 2004, D. Paradis, DSI/DEV:
34 !
35 ! -Declaration ICHAUX en ALLOCATABLE, PCHAMP en profil implicite (gain mem.)
36 !
37 !
38 !
39 TYPE(fa_com) :: FA
40 INTEGER (KIND=JPLIKB) KREP, KRANG, KLONGA
41 !
42 INTEGER (KIND=JPLIKB) KVALCO(*)
43 REAL (KIND=JPDBLR) PCHAMP(*)
44 !
45 LOGICAL LDCOSP
46 !
47 CHARACTER CDNOMA*(*)
48 !
49 REAL (KIND=JPDBLR) ZFOHYB (2)
50 !
51 INTEGER (KIND=JPLIKB) ILCHAM, ISTRIA, J, IDECAL, ICPACK
52 INTEGER (KIND=JPLIKB) IPUILA, IPOFIN
53 INTEGER (KIND=JPLIKB) ITRONC, IIND, ILOW, IHIGH, JTRON
54 INTEGER (KIND=JPLIKB) IDIMNC, INBITS
55 INTEGER (KIND=JPLIKB) IL, IADD, IRANGC, IILCHAM, INDECO
56 INTEGER (KIND=JPLIKB) IERR, INIMES
57 INTEGER (KIND=JPLIKB) IVALC3, IVALC4, IVALC5, IJLENV
58 INTEGER (KIND=JPLIKB) IJLENF, IDIZAI, IUNITE
59 INTEGER (KIND=JPLIKB) INUMER
60 !
61 REAL (KIND=JPDBLD) ZCHAMP
62 REAL (KIND=JPDBLM) ZTEMP (2)
63 !
64 REAL (KIND=JPDBLR), ALLOCATABLE :: ZCHAUX(:)
65 INTEGER (KIND=JPLIKB) IB1PAR (fa%jplb1p), IB2PAR (fa%jplb2p)
66 !
67 LOGICAL LLARPE, LLMLAM, LLCOSP
68 !
69 CHARACTER(LEN=FA%JPLMES) CLMESS
70 CHARACTER(LEN=FA%JPLSPX) CLNSPR
71 LOGICAL LLFATA
72 
73 !**
74 ! 1. - CONTROLES ET INITIALISATIONS.
75 !-----------------------------------------------------------------------
76 !
77 REAL(KIND=JPRB) :: ZHOOK_HANDLE
78 IF (lhook) CALL dr_hook('FADECI_MT',0,zhook_handle)
79 krep=0
80 IF (krang.LE.0.OR.krang.GT.fa%JPNXFA) THEN
81  krep=-66
82  GOTO 1001
83 ENDIF
84 !
85 istria=0
86 inbits=0
87 icpack=0
88 ipuila=0
89 ivalc3=0
90 ivalc4=0
91 ivalc5=0
92 !**
93 ! 2. - CONTROLE DES DONNEES DE L'ARTICLE
94 !-----------------------------------------------------------------------
95 !
96 IF (kvalco(1).LT.-2.OR.kvalco(1).GT.2.OR. &
97 & kvalco(2).LT. 0.OR.kvalco(2).GT.1.OR. &
98 & (kvalco(1).GT. 0.AND.kvalco(2).EQ.1.AND.kvalco(4).LT.0)) THEN
99  krep=-91
100  GOTO 1001
101 ENDIF
102 !
103 llarpe=kvalco(1).EQ.2
104 llcosp=kvalco(2).EQ.1
105 !
106 IF ((llcosp.AND..NOT.ldcosp).OR.(.NOT.llcosp.AND.ldcosp)) THEN
107  krep=-92
108  GOTO 1001
109 ENDIF
110 !
111 irangc=fa%FICHIER(krang)%NUCADR
112 llmlam=fa%CADRE(irangc)%LIMLAM
113 !
114 IF (ldcosp) THEN
115  IF (llmlam) THEN
116  ilcham=fa%CADRE(irangc)%NSFLAM
117  ELSE
118  IF (kvalco(1).EQ.-1) THEN
119  ilcham=(1+fa%CADRE(irangc)%MTRONC)*(2+fa%CADRE(irangc)%MTRONC)
120  ELSE
121  ilcham=(1+fa%CADRE(irangc)%MTRONC)**2
122  ENDIF
123  ENDIF
124 ELSE
125  ilcham=fa%CADRE(irangc)%NVAPDG
126 ENDIF
127 !
128 !**
129 ! 3. - DECODAGE DES DONNEES DE L'ARTICLE
130 !-----------------------------------------------------------------------
131 !
132 IF (kvalco(1) == -2) THEN
133 !
134 ! Cas ou les donnees sont codees en IEEE 32 bits; controle longueur d'article
135 !
136  IF (klonga.LT.((ilcham+1)/2+2)) THEN
137  krep=-93
138  GOTO 1001
139  ELSEIF (klonga.GT.((ilcham+1)/2+2)) THEN
140  krep=-94
141  IF (llmoer(krep,krang)) GOTO 1001
142  ENDIF
143 !
144 ! Transfert du tableau d'entree a la suite des 2 valeurs
145 ! documentaires stockees en debut d'article.
146 !
147  DO j = 1, ilcham, 2
148  ztemp(1:2) = transfer(kvalco(2+1+(j-1)/2), ztemp(1:2))
149  pchamp(j+0) = ztemp(1)
150  IF (j+1 <= ilcham) THEN
151  pchamp(j+1) = REAL (ZTEMP (2), JPDBLR)
152  ENDIF
153  ENDDO
154 !
155 ELSEIF (kvalco(1) == -1 .OR. kvalco(1) == 0) THEN
156 !
157 ! Cas ou les donnes sont codees en IEEE 64 bits; controle longueur d'article
158 !
159  IF (klonga.LT.(ilcham+2)) THEN
160  krep=-93
161  GOTO 1001
162  ELSEIF (klonga.GT.(ilcham+2)) THEN
163  krep=-94
164  IF (llmoer(krep,krang)) GOTO 1001
165  ENDIF
166 !
167 ! Transfert du tableau d'entree a la suite des 2 valeurs
168 ! documentaires stockees en debut d'article.
169 !
170  DO j = 1, ilcham
171  zchamp = transfer(kvalco(2+j), zchamp)
172  pchamp(j) = real(zchamp, jpdblr)
173  ENDDO
174 !
175 ELSE
176 !*
177 ! 3.1 - DECODAGE GRIB PROPREMENT DIT (STANDARD OU NON).
178 !-----------------------------------------------------------------------
179 !
180  idecal=1+2*kvalco(1)
181  IF (ldcosp) idecal=idecal+2
182  ivalc3=kvalco(3)
183  ivalc4=kvalco(4)
184  ivalc5=kvalco(5)
185  IF (ldcosp.AND.llmlam) THEN
186 !
187  ALLOCATE (zchaux(ilcham))
188 !
189  itronc=fa%CADRE(irangc)%MTRONC
190  istria=fa%CADRE(irangc)%NOZPAR(4)-fa%CADRE(irangc)%NOZPAR(3)+1
191  DO jtron=1,itronc
192  iadd=4*(ivalc4+1-jtron)
193  IF (iadd.LE.0) iadd=4
194  istria=istria+iadd
195  ENDDO
196  iilcham=ilcham-istria
197  CALL fadecoga(zchaux,iilcham,inbits,fa%NBIMAC,ib1par,ib2par, &
198 & zfohyb(1),2_jplikb ,kvalco(idecal+1), &
199 & klonga-idecal,indeco,ijlenv,ijlenf,icpack, &
200 & ipuila,ierr,kvalco(idecal-1),kvalco(idecal), &
201 & llarpe)
202 
203 !
204 ! Controle de l'adequation entre nb de valeurs attendues/lues
205 !
206  IF (ijlenf.LT.iilcham) THEN
207  krep=-93
208  IF (fa%LFAMOP) THEN
209  WRITE (unit=fa%NULOUT,fmt=*) &
210 & 'FADECI: erreur !!! Nbre de valeurs decodees = ', &
211 & ijlenf,' et nbre de valeurs attendues = ',iilcham
212  ENDIF
213  GOTO 1001
214  ELSEIF (ijlenf.GT.iilcham) THEN
215  krep=-94
216  IF (fa%LFAMOP) THEN
217  WRITE (unit=fa%NULOUT,fmt=*) &
218 & 'FADECI: erreur !!! Nbre de valeurs decodees = ', &
219 & ijlenf,' et nbre de valeurs attendues = ',iilcham
220  ENDIF
221  IF (llmoer(krep,krang)) GOTO 1001
222  ENDIF
223  iind=0
224  DO jtron=1,itronc
225  ilow=2+2*jtron+1
226  iadd=4*(ivalc4+1-jtron)
227  IF (iadd.LE.0) iadd=4
228  DO j=fa%CADRE(irangc)%NOZPAR(ilow)+iadd,fa%CADRE(irangc)%NOZPAR(ilow+1)
229  iind=iind+1
230  pchamp(j)=zchaux(iind)
231  ENDDO
232  ENDDO
233 !
234  IF (ALLOCATED( zchaux )) DEALLOCATE ( zchaux )
235 !
236  ELSE
237  CALL fadecoga (pchamp,ilcham,inbits,fa%NBIMAC,ib1par,ib2par, &
238 & zfohyb(1),2_jplikb ,kvalco(idecal+1), &
239 & klonga-idecal,indeco,ijlenv,ijlenf,icpack, &
240 & ipuila,ierr,kvalco(idecal-1),kvalco(idecal), &
241 & llarpe)
242 !
243 ! Controle de l'adequation entre nb de valeurs attendues/lues
244 !
245  IF (ijlenf.LT.ilcham) THEN
246  krep=-93
247  IF (fa%LFAMOP) THEN
248  WRITE (unit=fa%NULOUT,fmt=*) &
249 & 'FADECI: erreur !!! Nbre de valeurs decodees = ', &
250 & ijlenf,' et nbre de valeurs attendues = ',ilcham
251  ENDIF
252  GOTO 1001
253  ELSEIF (ijlenf.GT.ilcham) THEN
254  krep=-94
255  IF (fa%LFAMOP) THEN
256  WRITE (unit=fa%NULOUT,fmt=*) &
257 & 'FADECI: erreur !!! Nbre de valeurs decodees = ', &
258 & ijlenf,' et nbre de valeurs attendues = ',ilcham
259  ENDIF
260  IF (llmoer(krep,krang)) GOTO 1001
261  ENDIF
262  ENDIF
263 !
264  IF (ierr.EQ.-2) THEN
265  krep=-93
266  GOTO 1001
267  ELSEIF (ierr.NE.0) THEN
268  krep=-200+ierr
269  GOTO 1001
270  ELSEIF (ivalc3.NE.inbits.OR.(ldcosp.AND. &
271 & ((icpack.NE.ivalc4.AND..NOT.llmlam) &
272 & .OR.(.NOT.llmlam.AND.ipuila.NE.ivalc5)))) THEN
273  krep=-95
274  GOTO 1001
275  ELSEIF (ib1par(4).GT.64) THEN
276 !
277 ! Controle effectue s'il y a un bloc 2 en retour du decodage.
278 !
279  idizai=ib2par(1)/10
280  iunite=ib2par(1)-idizai*10
281 !
282  IF ((ldcosp.AND..NOT.llmlam.AND. &
283 & (iunite.NE.0.OR.idizai.LT.5.OR.idizai.GT.8)) &
284 & .OR.(.NOT.ldcosp.AND. &
285 & (iunite.NE.4.OR.idizai.LT.0.OR.idizai.GT.3))) THEN
286  krep=-95
287  GOTO 1001
288  ENDIF
289 !
290  ENDIF
291  IF (ldcosp.AND.llmlam) THEN
292  icpack=ivalc4
293  ipuila=ivalc5
294  ENDIF
295 !
296  IF (ldcosp) THEN
297 !
298  IF (llarpe) THEN
299  IF (llmlam) THEN
300  ipofin=idecal+indeco+istria
301  ELSE
302  idimnc=(1+icpack)**2
303  ipofin=idecal+indeco+idimnc
304  ENDIF
305 !
306  IF (klonga.LT.ipofin) THEN
307  krep=-93
308  GOTO 1001
309  ELSEIF (klonga.GT.ipofin) THEN
310  krep=-94
311  IF (llmoer(krep,krang)) GOTO 1001
312  ENDIF
313 !*
314 ! 3.2 - TRANSFERT DES COEFFICIENTS SPECTRAUX NON COMPACTES.
315 !-----------------------------------------------------------------------
316 ! (et non fournis par DECOGA) stockes en fin d'article.
317 !
318  IF (llmlam) THEN
319  iind=0
320  DO jtron=0,itronc
321  il=2+2*jtron+1
322  ilow=fa%CADRE(irangc)%NOZPAR(il)
323  IF (jtron.EQ.0) THEN
324  ihigh=fa%CADRE(irangc)%NOZPAR(il+1)
325  ELSE
326  ihigh=ilow+4*(icpack+1-jtron)-1
327  IF (ihigh.LE.ilow) ihigh=ilow+3
328  ENDIF
329  DO j=ilow,ihigh
330  iind=iind+1
331  zchamp=transfer(kvalco(idecal+indeco+iind), zchamp)
332  pchamp(j)=zchamp
333  ENDDO
334  ENDDO
335  ELSE
336  DO j=1,idimnc
337  zchamp=transfer(kvalco(idecal+indeco+j), zchamp)
338  pchamp(j)=zchamp
339  ENDDO
340  ENDIF
341 !
342  ENDIF
343 !*
344 ! 3.3 - SI NECESSAIRE, RECONSTITUTION DU SPECTRE.
345 !-----------------------------------------------------------------------
346 !
347  IF (ipuila.NE.0) THEN
348  CALL farcis_fort &
349 & (fa, krep,krang,pchamp,icpack,ipuila)
350  IF (krep.NE.0) GOTO 1001
351  ENDIF
352 !
353  ENDIF
354 !
355 ENDIF
356 !**
357 ! 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
358 ! VIA LE SOUS-PROGRAMME "FAIPAR" .
359 !-----------------------------------------------------------------------
360 !
361 1001 CONTINUE
362 llfata=llmoer(krep,krang)
363 !
364 IF (fa%LFAMOP.OR.llfata) THEN
365  inimes=2
366  clnspr='FADECI'
367  inumer=jpniil
368 !
369  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KRANG='',I4, &
370 & '', CDNOMA='''''',A,'''''', LDCOSP= '',L1, &
371 & '', KLONGA='',I8)') &
372 & krep, krang, cdnoma, ldcosp, klonga
373  CALL faipar_fort &
374 & (fa, inumer,inimes,krep,.false.,clmess, &
375 & clnspr,cdnoma,.false.)
376 ENDIF
377 !
378 IF (lhook) CALL dr_hook('FADECI_MT',1,zhook_handle)
379 
380 CONTAINS
381 
382 #include "facom2.llmoer.h"
383 
384 END SUBROUTINE fadeci_fort
385 
yomhook::dr_hook
Definition: yomhook.F90:20
fa_mod
Definition: fa_mod.F90:1
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
farcis_fort
subroutine farcis_fort(FA, KREP, KRANG, PCHAMP, KSTRON, KPUILA)
Definition: farcis.F90:5
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
fadeci_fort
subroutine fadeci_fort(FA, KREP, KRANG, CDNOMA, KVALCO, KLONGA, PCHAMP, LDCOSP)
Definition: fadeci.F90:7
faipar_fort
subroutine faipar_fort(FA, KNUMER, KNIMES, KCODE, LDFATA, CDMESS, CDNSPR, CDACTI, LDRLFI)
Definition: faipar.F90:6
fadecoga
subroutine fadecoga(PFDATA, KLENF, KBITS, KNBIT, KB1PAR, KB2PAR, PVERT, KLENV, KGRIB, KLENG, KWORD, KJLENV, KJLENF, KCPACK, KSCALP, KERR, PMIN, PMAX, LDARPE)
Definition: fadecoga.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
real
real8 real
Definition: privpub.h:396
Generated on Tue Jan 16 2018 16:23:21 for SURFEX v8.1 by   doxygen 1.8.13