|
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 FADECI_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 d'un CHAMP HORIZONTAL 00010 C venant d'etre lu sur un fichier ARPEGE/ALADIN. 00011 C ( DECodage Interne d'un champ lu ) 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 En mode multi-taches, il doit y avoir verrouillage du fichier 00023 C concerne avant l'appel au sous-programme. 00024 C 00025 C Modifications 00026 C ------------- 00027 C 00028 C Avril 2004, D. Paradis, DSI/DEV: 00029 C 00030 C -Declaration ICHAUX en ALLOCATABLE, KCHAMP en profil implicite (gain mem.) 00031 C 00032 #include "precision.h" 00033 C 00034 C 00035 TYPE(FA_COM) :: FA 00036 INTEGER KREP, KRANG, KLONGA 00037 C 00038 INTEGER (KIND=JPDBLE) KVALCO(*), KCHAMP(*) 00039 C 00040 LOGICAL LDCOSP 00041 C 00042 CHARACTER CDNOMA*(*) 00043 C 00044 REAL (KIND=JPDBLR) ZFOHYB (2) 00045 C 00046 INTEGER ILCHAM, ISTRIA, J, IDECAL, ICPACK, IPUILA, IPOFIN 00047 INTEGER ITRONC, IIND, ILOW, IHIGH, JTRON, IDIMNC, INBITS 00048 INTEGER IL, IADD, IRANGC, IILCHAM, INDECO, IERR, INIMES 00049 INTEGER IVALC3, IVALC4, IVALC5, IJLENV, IJLENF, IDIZAI, IUNITE 00050 INTEGER INUMER 00051 C 00052 INTEGER (KIND=JPDBLE), ALLOCATABLE :: ICHAUX(:) 00053 INTEGER IB1PAR (FA%JPLB1P), IB2PAR (FA%JPLB2P) 00054 C 00055 LOGICAL LLARPE, LLMLAM, LLCOSP 00056 C 00057 #include "facom2.h" 00058 #include "facom_mt.h" 00059 C** 00060 C 1. - CONTROLES ET INITIALISATIONS. 00061 C----------------------------------------------------------------------- 00062 C 00063 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00064 IF (LHOOK) CALL DR_HOOK('FADECI_MT',0,ZHOOK_HANDLE) 00065 IF (KRANG.LE.0.OR.KRANG.GT.FA%JPNXFA) THEN 00066 KREP=-66 00067 GOTO 1001 00068 ENDIF 00069 C 00070 ISTRIA=0 00071 C** 00072 C 2. - CONTROLE DES DONNEES DE L'ARTICLE 00073 C----------------------------------------------------------------------- 00074 C 00075 IF (KVALCO(1).LT.-1.OR.KVALCO(1).GT.2.OR. 00076 S KVALCO(2).LT.0.OR.KVALCO(2).GT.1.OR. 00077 S (KVALCO(1).GT.0.AND.KVALCO(2).EQ.1.AND.KVALCO(4).LT.0)) THEN 00078 KREP=-91 00079 GOTO 1001 00080 ELSE 00081 LLARPE=KVALCO(1).EQ.2 00082 LLCOSP=KVALCO(2).EQ.1 00083 ENDIF 00084 C 00085 IF ((LLCOSP.AND..NOT.LDCOSP).OR.(.NOT.LLCOSP.AND.LDCOSP)) THEN 00086 KREP=-92 00087 GOTO 1001 00088 ENDIF 00089 C 00090 IRANGC=FA%NUCADR(KRANG) 00091 LLMLAM=FA%LIMLAM(IRANGC) 00092 C 00093 IF (LDCOSP) THEN 00094 IF (LLMLAM) THEN 00095 ILCHAM=FA%NSFLAM(IRANGC) 00096 ELSE 00097 IF (KVALCO(1).EQ.-1) THEN 00098 ILCHAM=(1+FA%MTRONC(IRANGC))*(2+FA%MTRONC(IRANGC)) 00099 ELSE 00100 ILCHAM=(1+FA%MTRONC(IRANGC))**2 00101 ENDIF 00102 ENDIF 00103 ELSE 00104 ILCHAM=FA%NVAPDG(IRANGC) 00105 ENDIF 00106 C 00107 C** 00108 C 3. - DECODAGE DES DONNEES DE L'ARTICLE 00109 C----------------------------------------------------------------------- 00110 C 00111 IF (KVALCO(1).EQ.-1 .OR. KVALCO(1).EQ.0) THEN 00112 C 00113 C Cas ou il n'y a aucun codage... controle longueur d'article 00114 C 00115 IF (KLONGA.LT.(ILCHAM+2)) THEN 00116 KREP=-93 00117 GOTO 1001 00118 ELSEIF (KLONGA.GT.(ILCHAM+2)) THEN 00119 KREP=-94 00120 IF (LLMOER(KREP,KRANG)) GOTO 1001 00121 ENDIF 00122 C 00123 C Transfert du tableau d'entree a la suite des 2 valeurs 00124 C documentaires stockees en debut d'article. 00125 C 00126 DO 301 J=1,ILCHAM 00127 KCHAMP(J)=KVALCO(2+J) 00128 301 CONTINUE 00129 C 00130 ELSE 00131 C* 00132 C 3.1 - DECODAGE GRIB PROPREMENT DIT (STANDARD OU NON). 00133 C----------------------------------------------------------------------- 00134 C 00135 IDECAL=1+2*KVALCO(1) 00136 IF (LDCOSP) IDECAL=IDECAL+2 00137 IVALC3=KVALCO(3) 00138 IVALC4=KVALCO(4) 00139 IVALC5=KVALCO(5) 00140 IF (LDCOSP.AND.LLMLAM) THEN 00141 C 00142 ALLOCATE (ICHAUX (ILCHAM)) 00143 C 00144 ITRONC=FA%MTRONC(IRANGC) 00145 ISTRIA=FA%NOZPAR(4,IRANGC)-FA%NOZPAR(3,IRANGC)+1 00146 DO 310 JTRON=1,ITRONC 00147 IADD=4*(IVALC4+1-JTRON) 00148 IF (IADD.LE.0) IADD=4 00149 ISTRIA=ISTRIA+IADD 00150 310 CONTINUE 00151 IILCHAM=ILCHAM-ISTRIA 00152 CALL DECOGA(ICHAUX,IILCHAM,INBITS,FA%NBIMAC,IB1PAR,IB2PAR, 00153 S ZFOHYB(1),2,KVALCO(IDECAL+1),KLONGA-IDECAL, 00154 S INDECO,IJLENV,IJLENF,ICPACK,IPUILA,IERR, 00155 S KVALCO(IDECAL-1),KVALCO(IDECAL),LLARPE) 00156 C 00157 C Controle de l'adequation entre nb de valeurs attendues/lues 00158 C 00159 IF (IJLENF.LT.IILCHAM) THEN 00160 KREP=-93 00161 IF (FA%LFAMOP) THEN 00162 WRITE (UNIT=FA%NULOUT,FMT=*) 00163 S 'FADECI: erreur !!! Nbre de valeurs decodees = ', 00164 S IJLENF,' et nbre de valeurs attendues = ',IILCHAM 00165 ENDIF 00166 GOTO 1001 00167 ELSEIF (IJLENF.GT.IILCHAM) THEN 00168 KREP=-94 00169 IF (FA%LFAMOP) THEN 00170 WRITE (UNIT=FA%NULOUT,FMT=*) 00171 S 'FADECI: erreur !!! Nbre de valeurs decodees = ', 00172 S IJLENF,' et nbre de valeurs attendues = ',IILCHAM 00173 ENDIF 00174 IF (LLMOER(KREP,KRANG)) GOTO 1001 00175 ENDIF 00176 IIND=0 00177 DO 320 JTRON=1,ITRONC 00178 ILOW=2+2*JTRON+1 00179 IADD=4*(IVALC4+1-JTRON) 00180 IF (IADD.LE.0) IADD=4 00181 DO 320 J=FA%NOZPAR(ILOW,IRANGC)+IADD,FA%NOZPAR(ILOW+1,IRANGC) 00182 IIND=IIND+1 00183 KCHAMP(J)=ICHAUX(IIND) 00184 320 CONTINUE 00185 C 00186 IF (ALLOCATED( ICHAUX )) DEALLOCATE ( ICHAUX ) 00187 C 00188 ELSE 00189 CALL DECOGA (KCHAMP,ILCHAM,INBITS,FA%NBIMAC,IB1PAR,IB2PAR, 00190 S ZFOHYB(1),2,KVALCO(IDECAL+1),KLONGA-IDECAL, 00191 S INDECO,IJLENV,IJLENF,ICPACK,IPUILA,IERR, 00192 S KVALCO(IDECAL-1),KVALCO(IDECAL),LLARPE) 00193 C 00194 C Controle de l'adequation entre nb de valeurs attendues/lues 00195 C 00196 IF (IJLENF.LT.ILCHAM) THEN 00197 KREP=-93 00198 IF (FA%LFAMOP) THEN 00199 WRITE (UNIT=FA%NULOUT,FMT=*) 00200 S 'FADECI: erreur !!! Nbre de valeurs decodees = ', 00201 S IJLENF,' et nbre de valeurs attendues = ',ILCHAM 00202 ENDIF 00203 GOTO 1001 00204 ELSEIF (IJLENF.GT.ILCHAM) THEN 00205 KREP=-94 00206 IF (FA%LFAMOP) THEN 00207 WRITE (UNIT=FA%NULOUT,FMT=*) 00208 S 'FADECI: erreur !!! Nbre de valeurs decodees = ', 00209 S IJLENF,' et nbre de valeurs attendues = ',ILCHAM 00210 ENDIF 00211 IF (LLMOER(KREP,KRANG)) GOTO 1001 00212 ENDIF 00213 ENDIF 00214 C 00215 IF (IERR.EQ.-2) THEN 00216 KREP=-93 00217 GOTO 1001 00218 ELSEIF (IERR.NE.0) THEN 00219 KREP=-200+IERR 00220 GOTO 1001 00221 ELSEIF (IVALC3.NE.INBITS.OR.(LDCOSP.AND. 00222 S ((ICPACK.NE.IVALC4.AND..NOT.LLMLAM) 00223 S .OR.(.NOT.LLMLAM.AND.IPUILA.NE.IVALC5)))) THEN 00224 KREP=-95 00225 GOTO 1001 00226 ELSEIF (IB1PAR(4).GT.64) THEN 00227 C 00228 C Controle effectue s'il y a un bloc 2 en retour du decodage. 00229 C 00230 IDIZAI=IB2PAR(1)/10 00231 IUNITE=IB2PAR(1)-IDIZAI*10 00232 C 00233 IF ((LDCOSP.AND..NOT.LLMLAM.AND. 00234 S (IUNITE.NE.0.OR.IDIZAI.LT.5.OR.IDIZAI.GT.8)) 00235 S .OR.(.NOT.LDCOSP.AND. 00236 S (IUNITE.NE.4.OR.IDIZAI.LT.0.OR.IDIZAI.GT.3))) THEN 00237 KREP=-95 00238 GOTO 1001 00239 ENDIF 00240 C 00241 ENDIF 00242 IF (LDCOSP.AND.LLMLAM) THEN 00243 ICPACK=IVALC4 00244 IPUILA=IVALC5 00245 ENDIF 00246 C 00247 IF (LDCOSP) THEN 00248 C 00249 IF (LLARPE) THEN 00250 IF (LLMLAM) THEN 00251 IPOFIN=IDECAL+INDECO+ISTRIA 00252 ELSE 00253 IDIMNC=(1+ICPACK)**2 00254 IPOFIN=IDECAL+INDECO+IDIMNC 00255 ENDIF 00256 C 00257 IF (KLONGA.LT.IPOFIN) THEN 00258 KREP=-93 00259 GOTO 1001 00260 ELSEIF (KLONGA.GT.IPOFIN) THEN 00261 KREP=-94 00262 IF (LLMOER(KREP,KRANG)) GOTO 1001 00263 ENDIF 00264 C* 00265 C 3.2 - TRANSFERT DES COEFFICIENTS SPECTRAUX NON COMPACTES. 00266 C----------------------------------------------------------------------- 00267 C (et non fournis par DECOGA) stockes en fin d'article. 00268 C 00269 IF (LLMLAM) THEN 00270 IIND=0 00271 DO 3201 JTRON=0,ITRONC 00272 IL=2+2*JTRON+1 00273 ILOW=FA%NOZPAR(IL,IRANGC) 00274 IF (JTRON.EQ.0) THEN 00275 IHIGH=FA%NOZPAR(IL+1,IRANGC) 00276 ELSE 00277 IHIGH=ILOW+4*(ICPACK+1-JTRON)-1 00278 IF (IHIGH.LE.ILOW) IHIGH=ILOW+3 00279 ENDIF 00280 DO 3201 J=ILOW,IHIGH 00281 IIND=IIND+1 00282 KCHAMP(J)=KVALCO(IDECAL+INDECO+IIND) 00283 3201 CONTINUE 00284 ELSE 00285 DO 321 J=1,IDIMNC 00286 KCHAMP(J)=KVALCO(IDECAL+INDECO+J) 00287 321 CONTINUE 00288 ENDIF 00289 C 00290 ENDIF 00291 C* 00292 C 3.3 - SI NECESSAIRE, RECONSTITUTION DU SPECTRE. 00293 C----------------------------------------------------------------------- 00294 C 00295 IF (IPUILA.NE.0) THEN 00296 CALL FARCIS_MT (FA, KREP,KRANG,KCHAMP,ICPACK,IPUILA) 00297 IF (KREP.NE.0) GOTO 1001 00298 ENDIF 00299 C 00300 ENDIF 00301 C 00302 ENDIF 00303 C** 00304 C 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL, 00305 C VIA LE SOUS-PROGRAMME "FAIPAR" . 00306 C----------------------------------------------------------------------- 00307 C 00308 1001 CONTINUE 00309 LLFATA=LLMOER (KREP,KRANG) 00310 C 00311 IF (FA%LFAMOP.OR.LLFATA) THEN 00312 INIMES=2 00313 CLNSPR='FADECI' 00314 INUMER=FA%JPNIIL 00315 C 00316 WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KRANG=' 00317 ',I4, S '', CDNOMA='''''',A,'''''', LDCOSP= ' 00318 ',L1, S '', KLONGA='',I8)') 00319 S KREP, KRANG, CDNOMA, LDCOSP, KLONGA 00320 CALL FAIPAR_MT (FA, INUMER,INIMES,KREP,.FALSE.,CLMESS, 00321 S CLNSPR,CDNOMA,.FALSE.) 00322 ENDIF 00323 C 00324 IF (LHOOK) CALL DR_HOOK('FADECI_MT',1,ZHOOK_HANDLE) 00325 END 00326
1.8.0
