|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 C Jan-2011 P. Marguinaud Thread-safe FA 00002 SUBROUTINE FADECX_MT (FA, KREP, KRANG, CDNOMA, KVALCO, KLONGA, 00003 S KCHAMP, LDCOSP ) 00004 USE FA_MOD, ONLY : FA_COM 00005 USE PARKIND1, ONLY : JPRB 00006 USE YOMHOOK , ONLY : LHOOK, DR_HOOK 00007 C**** 00008 C Sous-programme INTERNE du logiciel de Fichiers ARPEGE: 00009 C Controle de coherence et decodage (GRIBEX) d'un CHAMP 00010 C HORIZONTAL venant d'etre lu sur un fichier ARPEGE/ALADIN. 00011 C ( DECodage d'un champ gribeX ) 00012 C** 00013 C Arguments : KREP (Sortie) ==> Code-reponse du sous-programme; 00014 C KRANG (Entree) ==> Rang de l'unite logique; 00015 C CDNOMA (Entree) ==> Nom d'article (prefabrique); 00016 C ( Tableau ) KVALCO (Entree) ==> Donnees issues de la lecture; 00017 C KLONGA (Entree) ==> Nombre de mots lus; 00018 C ( Tableau ) KCHAMP (Sortie) ==> Valeurs REELLES du champ lu; 00019 C LDCOSP (Entree) ==> Vrai si le champ est represente 00020 C par des coefficients spectraux; 00021 C* 00022 C MODIFICATION : 00023 C JM AUDOIN 15/05/2007 Partie 3.1 Blindage controle changement unite 00024 C 00025 #include "precision.h" 00026 C 00027 C 00028 TYPE(FA_COM) :: FA 00029 INTEGER KREP, KRANG, KLONGA 00030 C 00031 INTEGER (KIND=JPDBLE) KVALCO(*), KCHAMP(*) 00032 C 00033 LOGICAL LDCOSP 00034 C 00035 CHARACTER CDNOMA*(*) 00036 C 00037 REAL (KIND=JPDBLR) ZSEC2(10+2*(FA%JPXNIV+1)), ZSEC3(2) 00038 REAL (KIND=JPDBLR), ALLOCATABLE :: ZSEC4(:), ZCHAMP(:) 00039 REAL ZPULAP 00040 C 00041 INTEGER (KIND=JPDBLE), ALLOCATABLE :: ICHAMP(:) 00042 C 00043 INTEGER ISEC0(2), ISEC1(FA%JPSEC1), ISEC2(FA%JPSEC2), ISEC3(2) 00044 INTEGER ISEC4(FA%JPSEC4) 00045 INTEGER ILCHAM, ISTRIA, J, IDECAL, IPOFIN, ILONSEC2 00046 INTEGER ITRONC, IIND, ILOW, IHIGH 00047 INTEGER IL, IADD, IRANGC, IILCHAM, IERR, INIMES 00048 INTEGER IVALC3, IVALC4, IVALC5, IWORD 00049 INTEGER INUMER, ILENG, IRET, INDEX, JN, JM, JLAT, JLON 00050 INTEGER IFAORI, IFAMOD, INBIMO 00051 INTEGER I7,I10,I16 00052 C 00053 LOGICAL LLMLAM, LLCOSP 00054 C 00055 CHARACTER*1 CLOPER 00056 C 00057 INTEGER DECF10 00058 EXTERNAL DECF10 00059 C 00060 #include "facom2.h" 00061 #include "facom_mt.h" 00062 C** 00063 C 1. - CONTROLES ET INITIALISATIONS. 00064 C----------------------------------------------------------------------- 00065 C 00066 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00067 IF (LHOOK) CALL DR_HOOK('FADECX_MT',0,ZHOOK_HANDLE) 00068 KREP=0 00069 IF (KRANG.LE.0.OR.KRANG.GT.FA%JPNXFA) THEN 00070 KREP=-66 00071 GOTO 1001 00072 ENDIF 00073 C 00074 CLOPER='D' 00075 ISTRIA=0 00076 C** 00077 C 2. - CONTROLE DES DONNEES DE L'ARTICLE 00078 C----------------------------------------------------------------------- 00079 C 00080 IF (KVALCO(1).NE.3.OR. 00081 S KVALCO(2).LT.0.OR.KVALCO(2).GT.1.OR. 00082 S (KVALCO(2).EQ.1.AND.KVALCO(4).LT.0)) THEN 00083 KREP=-91 00084 GOTO 1001 00085 ELSE 00086 LLCOSP=KVALCO(2).EQ.1 00087 ENDIF 00088 C 00089 IF ((LLCOSP.AND..NOT.LDCOSP).OR.(.NOT.LLCOSP.AND.LDCOSP)) THEN 00090 KREP=-92 00091 GOTO 1001 00092 ENDIF 00093 C 00094 IRANGC=FA%NUCADR(KRANG) 00095 LLMLAM=FA%LIMLAM(IRANGC) 00096 ITRONC=FA%MTRONC(IRANGC) 00097 C 00098 IF (LDCOSP) THEN 00099 IF (LLMLAM) THEN 00100 ILCHAM=FA%NSFLAM(IRANGC) 00101 ILONSEC2=21+ITRONC 00102 ELSE 00103 ILCHAM=(1+ITRONC)*(2+ITRONC) 00104 ILONSEC2=22 00105 ENDIF 00106 ELSE 00107 ILCHAM=FA%NVAPDG(IRANGC) 00108 IF (LLMLAM) THEN 00109 ILONSEC2=22 00110 ELSE 00111 ILONSEC2=22+FA%NLATIT(IRANGC) 00112 ENDIF 00113 ENDIF 00114 C 00115 ALLOCATE (ICHAMP(ILCHAM), ZCHAMP(ILCHAM), ZSEC4(ILCHAM)) 00116 C 00117 C** 00118 C 3. - DECODAGE GRIBEX DES DONNEES DE L'ARTICLE 00119 C----------------------------------------------------------------------- 00120 C 00121 IDECAL=3 00122 IVALC3=KVALCO(3) 00123 IF (LDCOSP) THEN 00124 IDECAL=IDECAL+2 00125 C IVALC4=ss-tronc non compactee 00126 C IVALC5=puissance de laplacien 00127 IVALC4=KVALCO(4) 00128 IVALC5=KVALCO(5) 00129 ENDIF 00130 IILCHAM=ILCHAM 00131 C 00132 C Pour Aladin, le calcul du nb de coeff spectraux qui ont 00133 C ete compactes est plus complexe (certains ont ete retires 00134 C pour ne pas etre compactes: ss-tronc triangulaire). 00135 C 00136 IF (LDCOSP.AND.LLMLAM) THEN 00137 ISTRIA=4*(1+FA%NOZPAR(1,IRANGC)+FA%NOZPAR(2,IRANGC)+ 00138 S IVALC4*(IVALC4-1)/2) 00139 IILCHAM=ILCHAM-ISTRIA 00140 ENDIF 00141 C ILENG=longueur disponible en entiers declares INTEGER dans KVALCO. 00142 ILENG=(KIND(KVALCO)/KIND(ILENG))*(KLONGA-IDECAL) 00143 C 00144 C 3.1 - CHANGEMENT D'UNITE DE CERTAINS CHAMPS. 00145 C Il s'agit de champs dont les valeurs sont comprises 00146 C entre 0 et 1 dans le modele mais dont l'unite 00147 C conventionnelle dans le GRIB est le %. 00148 C Avant l'appel a GRIBEX, il faut leur redonner leurs 00149 C valeurs d'origine (comprises entre 0 et 1) en ajoutant 00150 C 2 au facteur d'echelle decimal KSEC1(23) via DECF10. 00151 C 00152 I7 =MIN(7,LEN(TRIM(CDNOMA))) 00153 I10=MIN(10,LEN(TRIM(CDNOMA))) 00154 I16=MIN(16,LEN(TRIM(CDNOMA))) 00155 IF ( 00156 S CDNOMA(1:I10)=='SURFNEBUL.' .OR. 00157 S CDNOMA(1:I10)=='SURFALBEDO' .OR. 00158 S CDNOMA=='SURFPROP.VEGETAT' .OR. 00159 S CDNOMA=='CLSHUMI.RELATIVE' .OR. CDNOMA=='CLSMAXI.HUMI.REL' .OR. 00160 S CDNOMA=='CLSMINI.HUMI.REL' .OR. 00161 S (CDNOMA(1:1)=='P'.AND.CDNOMA(I7:I16)=='HUMI_RELAT').OR. 00162 S (CDNOMA(1:1)=='H'.AND.CDNOMA(I7:I16)=='HUMI_RELAT') ) THEN 00163 IADD = 2 00164 INBIMO = 32 ! Nombre de BIts par mot (un mot=INTEGER) 00165 INDEX = DECF10 ( KVALCO(IDECAL+1), ILENG, IADD, 00166 S IFAORI, IFAMOD, INBIMO ) 00167 IF (INDEX==-1) THEN 00168 WRITE (UNIT=FA%NULOUT,FMT=*) 00169 S 'FADECX: pas d''entete GRIB au debut !' 00170 KREP=-128 00171 GOTO 1001 00172 ELSEIF (INDEX==-2) THEN 00173 WRITE (UNIT=FA%NULOUT,FMT=*) 00174 S 'FADECX: edition du GRIB invalid pour DECF10 !' 00175 KREP=-128 00176 GOTO 1001 00177 ELSEIF (INDEX > 0) THEN 00178 WRITE (UNIT=FA%NULOUT,FMT=*) 00179 S 'FADECX: ERREUR dans appel a INXBIT par DECF10 !' 00180 WRITE (UNIT=FA%NULOUT,FMT=*) 00181 S 'FADECX: avec code retour de INXBIT = ',INDEX 00182 KREP=-128 00183 GOTO 1001 00184 ELSEIF (INDEX < -2) THEN 00185 WRITE (UNIT=FA%NULOUT,FMT=*) 00186 S 'FADECX: code retour inconnu de DECF10 : ',INDEX 00187 KREP=-126 00188 GOTO 1001 00189 ENDIF 00190 ENDIF 00191 C 00192 C 3.2 - APPEL A GRIBEX 00193 C 00194 IWORD=0 00195 IRET=-1 00196 C CALL GRIBEX(ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4, 00197 C S KCHAMP,IILCHAM,KVALCO(IDECAL+1),ILENG,IWORD, 00198 C S CLOPER,IRET) 00199 IF (FA%LFAMOP) THEN 00200 WRITE (UNIT=FA%NULOUT,FMT=*) 00201 S ' FADECX: KLONGA, IDECAL, ILENG, IILCHAM = ', 00202 S KLONGA, IDECAL, ILENG, IILCHAM 00203 WRITE (UNIT=FA%NULOUT,FMT=*) ' * ISEC0 = ',ISEC0 00204 WRITE (UNIT=FA%NULOUT,FMT=*) ' * ISEC1 = ',ISEC1 00205 WRITE (UNIT=FA%NULOUT,FMT=*) 00206 S ' * ILONSEC2 ! ISEC2(1:ILONSEC2) = ', 00207 S ILONSEC2, ' ! ', ISEC2(1:ILONSEC2) 00208 WRITE (UNIT=FA%NULOUT,FMT=*) ' * ZSEC2(1:2) = ',ZSEC2(1:2) 00209 IF (ISEC2(12).GT.0) WRITE (UNIT=FA%NULOUT,FMT=*) 00210 S ' * ISEC2(12) ! ZSEC2(11:10+ISEC2(12)) = ', 00211 S ISEC2(12), ' ! ', ZSEC2(11:10+ISEC2(12)) 00212 WRITE (UNIT=FA%NULOUT,FMT=*) ' * FA%JPSEC4 ! ISEC4 = ', 00213 S FA%JPSEC4,' ! ',ISEC4 00214 ENDIF 00215 C* 00216 C 3.1 - CONTROLES DE COHERENCE 00217 C----------------------------------------------------------------------- 00218 C 00219 IF (IRET.GT.0) THEN 00220 C Erreur rapportee par GRIBEX 00221 KREP=-1000-IRET 00222 WRITE (UNIT=FA%NULOUT,FMT=*) ' FADECX: IRET, KREP = ',IRET, KREP 00223 GOTO 1001 00224 ELSEIF (IRET.LT.0) THEN 00225 C Warning rapporte par GRIBEX 00226 WRITE (UNIT=FA%NULOUT,FMT=*) 00227 WRITE (UNIT=FA%NULOUT,FMT=*) 00228 S '!------------------------------------------' 00229 WRITE (UNIT=FA%NULOUT,FMT=*) 00230 S '! FADECX: WARNING !!! !' 00231 WRITE (UNIT=FA%NULOUT,FMT=*) 00232 S '!------------------------------------------' 00233 WRITE (UNIT=FA%NULOUT,FMT=*) ' Code retour de GRIBEX = ', 00234 S IRET,' pour le champ: ',CDNOMA 00235 WRITE (UNIT=FA%NULOUT,FMT=*) 00236 ENDIF 00237 IF (ISEC4(1).LT.IILCHAM) THEN 00238 KREP=-93 00239 IF (FA%LFAMOP) THEN 00240 WRITE (UNIT=FA%NULOUT,FMT=*) 00241 S 'FADECX: ERREUR !!! Nbre de valeurs decodees = ', 00242 S ISEC4(1),' et nbre de valeurs attendues = ',IILCHAM 00243 ENDIF 00244 GOTO 1001 00245 ELSEIF (ISEC4(1).GT.IILCHAM) THEN 00246 KREP=-94 00247 IF (FA%LFAMOP) THEN 00248 WRITE (UNIT=FA%NULOUT,FMT=*) 00249 S 'FADECX: ERREUR !!! Nbre de valeurs decodees = ', 00250 S ISEC4(1),' et nbre de valeurs attendues = ',IILCHAM 00251 ENDIF 00252 IF (LLMOER(KREP,KRANG)) GOTO 1001 00253 ENDIF 00254 C 00255 IF (IVALC3.NE.ISEC4(2).AND.FA%LFAMOP) THEN 00256 WRITE (UNIT=FA%NULOUT,FMT=*) 00257 S ' FADECX: WARNING, le nb de bits de codage qui avait', 00258 S ' ete demande ( ',IVALC3,' ) est different de celui qui a', 00259 S ' ete finalement retenu ( ',ISEC4(2),' ) par GRIBEX.' 00260 WRITE (UNIT=FA%NULOUT,FMT=*) 00261 S ' => Gain de place sans perte de precision' 00262 ENDIF 00263 C 00264 C Dans le cas d'un champ spectral ARPEGE 00265 C 00266 IF (LDCOSP.AND..NOT.LLMLAM.AND.(ISEC4(18).NE.IVALC4 00267 S .OR.ISEC4(17).NE.IVALC5)) THEN 00268 IF (FA%LFAMOP) THEN 00269 WRITE (UNIT=FA%NULOUT,FMT=*) 00270 S 'Ss-tronc non compactee dans GRIB = ',ISEC4(18), 00271 S ' et on attend: ',IVALC4 00272 WRITE (UNIT=FA%NULOUT,FMT=*) 00273 S 'Puissance de laplacien dans GRIB = ',ISEC4(17), 00274 S ' et on attend: ',IVALC5 00275 ENDIF 00276 KREP=-95 00277 GOTO 1001 00278 ENDIF 00279 C 00280 C Controle de l'adequation entre le nb de mots lus par LFI et le detail: 00281 C ( enrobage FA + message GRIBEX + eventuelles valeurs non-compactees ). 00282 C 00283 IWORD=1+(ISEC0(1)-1)/JPDBLE 00284 IF (FA%LFAMOP) THEN 00285 WRITE (UNIT=FA%NULOUT,FMT=*) ' FADECX: IWORD = ',IWORD 00286 ENDIF 00287 IPOFIN=IDECAL+IWORD 00288 IF (LDCOSP) THEN 00289 IF (LLMLAM) THEN 00290 IPOFIN=IPOFIN+ISTRIA 00291 ELSE 00292 IPOFIN=IPOFIN+(1+IVALC4)*(2+IVALC4) 00293 ENDIF 00294 ENDIF 00295 C 00296 IF (KLONGA.LT.IPOFIN) THEN 00297 KREP=-93 00298 GOTO 1001 00299 ELSEIF (KLONGA.GT.IPOFIN) THEN 00300 KREP=-94 00301 IF (LLMOER(KREP,KRANG)) GOTO 1001 00302 ENDIF 00303 C* 00304 C 3.2 - DEMODULATION DES COEFF. SPEC. ALADIN QUI ONT ETE COMPACTES 00305 C----------------------------------------------------------------------- 00306 C 00307 IF (LDCOSP.AND.LLMLAM) THEN 00308 C Transfert des donnees decodees et modulees entieres en nombres reels 00309 C pour les demoduler. Comme KCHAMP est a profil implicite, on ne peut 00310 C s'en servir pour la fonction TRANSFER => il faut passer par ICHAMP! 00311 ICHAMP(1:IILCHAM) = KCHAMP(1:IILCHAM) 00312 ZSEC4 (1:IILCHAM) = TRANSFER(ICHAMP,ZSEC4,IILCHAM) 00313 ZCHAMP=0. 00314 ZPULAP=REAL(IVALC5,JPDBLR) * (-0.001) 00315 IIND=0 00316 DO JM=1,FA%NOMPAR(2,IRANGC) 00317 ILOW=2+2*JM+1 00318 IADD=4*MAX(IVALC4+1-JM,1) 00319 C 00320 DO INDEX=FA%NOMPAR(ILOW,IRANGC)+IADD,FA%NOMPAR(ILOW+1,IRANGC) 00321 IIND=IIND+1 00322 JN=(INDEX-FA%NOMPAR(ILOW,IRANGC))/4 00323 ZCHAMP(INDEX)=ZSEC4(IIND) * ((REAL(JN**2+JM**2))**ZPULAP) 00324 ENDDO 00325 ENDDO 00326 C Transfert des donnees decodees et demodulees reelles en nombres entiers 00327 C disposes aux bons endroits du tableau definitif. 00328 ICHAMP(1:ILCHAM) = TRANSFER(ZCHAMP,ICHAMP,ILCHAM) 00329 KCHAMP(1:ILCHAM) = ICHAMP(1:ILCHAM) 00330 ENDIF 00331 C* 00332 C 3.3 - TRANSFERT DES COEFFICIENTS SPECTRAUX NON COMPACTES. 00333 C----------------------------------------------------------------------- 00334 C (et non fournis par GRIBEX) stockes en fin d'article. 00335 C 00336 IF (LDCOSP) THEN 00337 IF (LLMLAM) THEN 00338 IIND=0 00339 DO JM=0,FA%NOMPAR(2,IRANGC) 00340 IL=2+2*JM+1 00341 ILOW=FA%NOMPAR(IL,IRANGC) 00342 C 00343 IF (JM.EQ.0) THEN 00344 IHIGH=FA%NOMPAR(IL+1,IRANGC) 00345 ELSE 00346 IHIGH=ILOW+4*(IVALC4+1-JM)-1 00347 IF (IHIGH.LE.ILOW) IHIGH=ILOW+3 00348 ENDIF 00349 C 00350 DO INDEX=ILOW,IHIGH 00351 IIND=IIND+1 00352 KCHAMP(INDEX)=KVALCO(IDECAL+IWORD+IIND) 00353 ENDDO 00354 ENDDO 00355 ELSE 00356 C 00357 C Cas ARPEGE 00358 C 00359 KCHAMP(1:2*(IVALC4+1))= 00360 S KVALCO(IDECAL+IWORD+1:IDECAL+IWORD+2*(IVALC4+1)) 00361 IIND=2*(IVALC4+1)-1 00362 INDEX=2*(ITRONC+1)-1 00363 DO JM=1,IVALC4 00364 DO JN=JM,ITRONC 00365 INDEX=INDEX+2 00366 IF (JN.LE.IVALC4) THEN 00367 IIND=IIND+2 00368 KCHAMP(INDEX) = KVALCO(IDECAL+IWORD+IIND) 00369 KCHAMP(INDEX+1) = KVALCO(IDECAL+IWORD+IIND+1) 00370 ENDIF 00371 ENDDO 00372 ENDDO 00373 C 00374 ENDIF 00375 ENDIF 00376 C* 00377 C 3.4 - Renversement des valeurs en pts de grille des champs 00378 C lat-lon afin de les ranger Sud-Nord plutot que Nord-Sud 00379 C (on conserve le rangt W-E consecutif) a l'image du rangt 00380 C initial effectue par FullPos. 00381 C----------------------------------------------------------------------- 00382 C 00383 IF ((ISEC2(1)==0.OR.ISEC2(1)==10.OR.ISEC2(1)==20.OR. 00384 S ISEC2(1)==30) .AND. .NOT.LDCOSP) THEN 00385 IF (FA%LFAMOP) THEN 00386 WRITE (UNIT=FA%NULOUT,FMT=*) 00387 S ' FADECX: Grille LAT-LON issue BDAP -> ', 00388 S ' renversement des valeurs pour etre rangees SN' 00389 ENDIF 00390 DO JLAT=1,FA%NLATIT(IRANGC) 00391 DO JLON=1,FA%NXLOPA(IRANGC) 00392 JN=JLON+FA%NXLOPA(IRANGC)*(JLAT-1) 00393 INDEX=JLON+FA%NXLOPA(IRANGC)*(FA%NLATIT(IRANGC)-JLAT) 00394 ICHAMP(INDEX) = KCHAMP(JN) 00395 ENDDO 00396 ENDDO 00397 KCHAMP(1:ILCHAM) = ICHAMP(1:ILCHAM) 00398 ENDIF 00399 C** 00400 C 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL, 00401 C VIA LE SOUS-PROGRAMME "FAIPAR" . 00402 C----------------------------------------------------------------------- 00403 C 00404 1001 CONTINUE 00405 IF (ALLOCATED(ICHAMP)) DEALLOCATE ( ICHAMP, ZCHAMP, ZSEC4 ) 00406 LLFATA=LLMOER (KREP,KRANG) 00407 C 00408 IF (FA%LFAMOP.OR.LLFATA) THEN 00409 INIMES=2 00410 CLNSPR='FADECX' 00411 INUMER=FA%JPNIIL 00412 C 00413 WRITE (UNIT=CLMESS,FMT='(''KREP='',I5,'', KRANG=' 00414 ',I4, S '', CDNOMA='''''',A,'''''', KLONGA= ' 00415 ',I8, S '', LDCOSP='',L1)') 00416 S KREP, KRANG, CDNOMA, KLONGA, LDCOSP 00417 CALL FAIPAR_MT (FA, INUMER,INIMES,KREP,.FALSE.,CLMESS, 00418 S CLNSPR,CDNOMA,.FALSE.) 00419 ENDIF 00420 C 00421 IF (LHOOK) CALL DR_HOOK('FADECX_MT',1,ZHOOK_HANDLE) 00422 END 00423
1.8.0
