|
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 FACODX_MT (FA, KREP, KRANG, CDPREF, KNIVAU, CDSUFF, 00003 S PSEC4, LDCOSP, KVALCO, KLONGD ) 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 PREPARATION (codage GRIBEX) d'un CHAMP HORIZONTAL 00010 C destine a etre ecrit sur un fichier ARPEGE/ALADIN. 00011 C ( CODage d'un champ a l'aide de gribeX ) 00012 C** 00013 C Arguments : KREP (Sortie) ==> Code-reponse du sous-programme; 00014 C KRANG (Entree) ==> Rang de l'unite logique; 00015 C CDPREF (Entree) ==> Prefixe eventuel du nom d'article; 00016 C KNIVAU (Entree) ==> Niveau vertical eventuel; 00017 C CDSUFF (Entree) ==> Suffixe eventuel du nom d'article; 00018 C ( Tableau ) PSEC4 (Entree) ==> Valeurs REELLES du champ a ecrire; 00019 C LDCOSP (Entree) ==> Vrai si le champ est represente 00020 C par des coefficients spectraux; 00021 C ( Tableau ) KVALCO (Sortie) ==> Donnees destinees a l'ecriture; 00022 C KLONGD (Sortie) ==> Nombre de mots a ecrire; 00023 C* 00024 C En mode multi-taches, il doit y avoir verrouillage du fichier 00025 C concerne avant l'appel au sous-programme. 00026 C 00027 C Modifications 00028 C ------------- 00029 C R. El Ouaraini : 03-Oct-06, introduire la nouvelle geometrie pour tester ERPK 00030 C 00031 C JM AUDOIN : 15 mai 2007 partie 5 changement unite 00032 C 00033 #include "precision.h" 00034 C 00035 C 00036 TYPE(FA_COM) :: FA 00037 INTEGER KREP, KRANG, KNIVAU, KLONGD 00038 C 00039 INTEGER (KIND=JPDBLE) KVALCO(*) 00040 REAL (KIND=JPDBLR) PSEC4(*) 00041 C 00042 LOGICAL LDCOSP 00043 C 00044 CHARACTER CDPREF*(*), CDSUFF*(*) 00045 C 00046 REAL (KIND=JPDBLR), ALLOCATABLE :: ZSEC4(:) 00047 INTEGER (KIND=JPDBLE), ALLOCATABLE :: IVALCO(:) 00048 REAL (KIND=JPDBLR) :: ZMIN, ZA 00049 REAL ZSEC2(10+2*(FA%JPXNIV+1)), ZSEC3(2), ZPULAP 00050 C 00051 INTEGER ISEC0(2), ISEC1(FA%JPSEC1), ISEC2(FA%JPSEC2), ISEC3(2) 00052 INTEGER ISEC4(FA%JPSEC4), ILONSEC2 00053 INTEGER ILENG, IWORD, IRET, JM, IPULAP 00054 INTEGER ILCHAM, JN, IDECAL, ICPACK 00055 INTEGER ITRONC, ILOW, IHIGH, IDIMNC, INBITS 00056 INTEGER IL, IADD, IRANGC, IILCHAM, INIMES 00057 INTEGER INUMER, INDEX, JLAT, JLON, IDECOPT 00058 INTEGER IFAORI, IFAMOD, INBIMO 00059 C 00060 LOGICAL LLMLAM 00061 C 00062 CHARACTER*1 CLOPER 00063 C 00064 INTEGER DECF10 00065 EXTERNAL DECF10 00066 INTRINSIC LEN_TRIM 00067 C 00068 #include "facom2.h" 00069 #include "facom_mt.h" 00070 C** 00071 C 1. - CONTROLES ET INITIALISATIONS. 00072 C----------------------------------------------------------------------- 00073 C 00074 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00075 IF (LHOOK) CALL DR_HOOK('FACODX_MT',0,ZHOOK_HANDLE) 00076 IF (KRANG.LE.0.OR.KRANG.GT.FA%JPNXFA) THEN 00077 KREP=-66 00078 GOTO 1001 00079 ENDIF 00080 ICPACK=FA%NSTROF(KRANG) 00081 IRANGC=FA%NUCADR(KRANG) 00082 LLMLAM=FA%LIMLAM(IRANGC) 00083 ITRONC=FA%MTRONC(IRANGC) 00084 C 00085 IF (LLMLAM) THEN 00086 IF (LDCOSP) THEN 00087 ILONSEC2=21+FA%NOMPAR(2,IRANGC) 00088 ELSE 00089 ILONSEC2=22 00090 ENDIF 00091 ELSE 00092 IF (LDCOSP) THEN 00093 ILONSEC2=22 00094 ELSE 00095 ILONSEC2=22+FA%NLATIT(IRANGC) 00096 ENDIF 00097 ENDIF 00098 C 00099 KVALCO(1)=FA%NFGRIB(KRANG) 00100 IDECAL=3 00101 IF (LDCOSP) THEN 00102 IF (LLMLAM) THEN 00103 ILCHAM=FA%NSFLAM(IRANGC) 00104 ELSE 00105 ILCHAM=(1+ITRONC)*(2+ITRONC) 00106 ENDIF 00107 KVALCO(2)=1 00108 INBITS=FA%NBFCSP(KRANG) 00109 IDECAL=IDECAL+2 00110 ELSE 00111 ILCHAM=FA%NVAPDG(IRANGC) 00112 KVALCO(2)=0 00113 INBITS=FA%NBFPDG(KRANG) 00114 ENDIF 00115 KVALCO(3)=INBITS 00116 IILCHAM = ILCHAM 00117 IDECOPT = 0 00118 C** 00119 C 2. - PREPARATION DU TABLEAU DE DONNEES A ECRIRE SUR LE FICHIER. 00120 C----------------------------------------------------------------------- 00121 C 00122 ALLOCATE (ZSEC4 (ILCHAM)) 00123 C 00124 IF (LDCOSP .AND. LLMLAM) THEN 00125 C 00126 C Champ ALADIN en coefficients spectraux... traitement particulier, 00127 C car non prevu dans GRIBEX (il y sera considere comme un champ lat-lon) 00128 C mais on a la possibilite de compacter une (pseudo-)puissance de 00129 C laplacien du champ a la place du champ, de maniere a augmenter 00130 C la precision du champ en "aplanissant" le spectre. 00131 C 00132 C Determination de la puissance de Laplacien (en 1/1000 ieme) 00133 C 00134 CALL FAPULA_MT (FA, KREP, KRANG, PSEC4, IPULAP ) 00135 ZPULAP=REAL(IPULAP,JPDBLR)/1000. 00136 C ZPULAP=0. 00137 C IPULAP=0 00138 IF (FA%LFAMOP) THEN 00139 print *,'FACODX: puissance de laplacien selectionee ',ZPULAP, 00140 S ' pour une sous-tronc de ',ICPACK 00141 ENDIF 00142 IF (KREP.NE.0) GOTO 1001 00143 C 00144 C Transfert des coeff spectraux devant etre compactes de PSEC4 a ZSEC4 00145 C avec prise en compte du coefficient (n**2+m**2)**zpulap. Les coefficients 00146 C concernes sont ceux inclus dans le quart de l'ellipse, hors axes (coeff 00147 C nuls), et hors du triangle non-compacte (sous-troncature). 00148 IILCHAM=0 00149 C 00150 DO JM=1,FA%NOMPAR(2,IRANGC) 00151 ILOW=2+2*JM+1 00152 IADD=4* MAX(ICPACK+1-JM,1) 00153 C 00154 DO INDEX=FA%NOMPAR(ILOW,IRANGC)+IADD,FA%NOMPAR(ILOW+1,IRANGC) 00155 IILCHAM=IILCHAM+1 00156 JN=(INDEX-FA%NOMPAR(ILOW,IRANGC))/4 00157 ZSEC4(IILCHAM)=PSEC4(INDEX) * ((REAL(JN**2+JM**2))**ZPULAP) 00158 ENDDO 00159 ENDDO 00160 C Number of elements in sub-triangle+axes:IDIMNC 00161 IDIMNC=ILCHAM-IILCHAM 00162 C Recherche de l'amplitude et du min du champ 00163 ZMIN=ZSEC4(1) 00164 ZA=0. 00165 ZMIN = MINVAL(ZSEC4(1:IILCHAM)) 00166 ZA = MAXVAL(ZSEC4(1:IILCHAM)) - ZMIN 00167 C Recherche du facteur decimal optimal pour utiliser 00168 C au mieux les INBITS dans le codage de ce champ 00169 IF (FA%LFAMOP) THEN 00170 WRITE (UNIT=FA%NULOUT,FMT=*)'FACODX: traitement du champ: ', 00171 S CDPREF,KNIVAU,CDSUFF 00172 ENDIF 00173 CALL FACDEC_MT (FA, KREP, ZA, ZMIN, INBITS, IDECOPT) 00174 IF (KREP.NE.0) THEN 00175 IDECOPT = 0 00176 KREP = 0 00177 ENDIF 00178 ELSEIF(LDCOSP .AND. .NOT.LLMLAM) THEN 00179 C 00180 C Transfert du tableau d'entree dans un tableau local 00181 C de maniere a eviter l'ecrasement du tableau d'entree par "GRIBEX". 00182 C 00183 ZSEC4(1:IILCHAM) = PSEC4(1:IILCHAM) 00184 IDIMNC=(1+ICPACK)*(2+ICPACK) 00185 ELSE 00186 C 00187 C CHAMPS NON SPECTRAUX: transfert du tableau d'entree dans un 00188 C tableau local de maniere a eviter son ecrasement par "GRIBEX". 00189 C 00190 C 00191 IDIMNC=0 00192 C Tester si Nouvelle ou ancienne geometrie Aladin 00193 IF (FA%SINLAT(1,IRANGC) .GE. 0) THEN 00194 IF (LLMLAM .AND. FA%SINLAT(10,IRANGC).LT.0) THEN 00195 C Parametre de projection negatif, donc pas de projection: 00196 C Il s'agit d'une grille lat-lon reguliere du type Full-Pos 00197 C (pour champ ARPEGE ou Aladin). Il faut donc renverser 00198 C le champ afin de ranger Nord-Sud les valeurs plutot que Sud-Nord 00199 C (on conserve le rangt W-E consecutif). 00200 C Le but est de satisfaire la BDAP qui attend un rangt NW-->SE. 00201 C 00202 IF (FA%LFAMOP) THEN 00203 WRITE (UNIT=FA%NULOUT,FMT=*) 00204 S ' FACODX: Grille LAT-LON pour BDAP -> ', 00205 S ' renversement des valeurs pour etre rangees NS' 00206 ENDIF 00207 DO JLAT=1,FA%NLATIT(IRANGC) 00208 DO JLON=1,FA%NXLOPA(IRANGC) 00209 JN=JLON+FA%NXLOPA(IRANGC)*(JLAT-1) 00210 INDEX=JLON+FA%NXLOPA(IRANGC)*(FA%NLATIT(IRANGC)-JLAT) 00211 ZSEC4(INDEX) = PSEC4(JN) 00212 ENDDO 00213 ENDDO 00214 ELSE 00215 ZSEC4(1:IILCHAM) = PSEC4(1:IILCHAM) 00216 ENDIF 00217 ELSE 00218 IF (LLMLAM .AND. FA%SINLAT(2,IRANGC).LT.0) THEN 00219 IF (FA%LFAMOP) THEN 00220 WRITE (UNIT=FA%NULOUT,FMT=*) 00221 S ' FACODX: Grille LAT-LON pour BDAP -> ', 00222 S ' renversement des valeurs pour etre rangees NS' 00223 ENDIF 00224 DO JLAT=1,FA%NLATIT(IRANGC) 00225 DO JLON=1,FA%NXLOPA(IRANGC) 00226 JN=JLON+FA%NXLOPA(IRANGC)*(JLAT-1) 00227 INDEX=JLON+FA%NXLOPA(IRANGC)*(FA%NLATIT(IRANGC)-JLAT) 00228 ZSEC4(INDEX) = PSEC4(JN) 00229 ENDDO 00230 ENDDO 00231 ELSE 00232 ZSEC4(1:IILCHAM) = PSEC4(1:IILCHAM) 00233 ENDIF 00234 ENDIF 00235 C Recherche de l'amplitude et du min du champ 00236 ZMIN=ZSEC4(1) 00237 ZA=0. 00238 ZMIN = MINVAL(ZSEC4(1:IILCHAM)) 00239 ZA = MAXVAL(ZSEC4(1:IILCHAM)) - ZMIN 00240 C Recherche du facteur decimal optimal pour utiliser 00241 C au mieux les INBITS dans le codage de ce champ 00242 IF (FA%LFAMOP) THEN 00243 WRITE (UNIT=FA%NULOUT,FMT=*)'FACODX: traitement du champ: ', 00244 S CDPREF,KNIVAU,CDSUFF 00245 ENDIF 00246 CALL FACDEC_MT (FA, KREP, ZA, ZMIN, INBITS, IDECOPT) 00247 IF (KREP.NE.0) THEN 00248 IDECOPT = 0 00249 KREP = 0 00250 ENDIF 00251 ENDIF 00252 C* 00253 C 3. - INITIALISATION DE L'ENROBAGE GRIB 00254 C----------------------------------------------------------------------- 00255 C 00256 C 3.1 - Sections 1, 2, 3 et 4 (sf la partie reelle pour 4) 00257 C 00258 CALL FAINIG_MT (FA, KREP, KRANG, CDPREF, KNIVAU, CDSUFF, LDCOSP, 00259 S IILCHAM, ISEC1, ISEC2, ZSEC2, ISEC3, ZSEC3, ISEC4 ) 00260 IF (KREP.NE.0) THEN 00261 GOTO 1001 00262 ENDIF 00263 C Prise en compte du facteur decimal 00264 ISEC1(23) = IDECOPT 00265 C 00266 C 3.2 - Definition du type de codage 00267 C 00268 CLOPER='C' 00269 IF (FA%NCOGRIF(1,KRANG)==1) CLOPER='K' 00270 C* 00271 C 4. - CODAGE GRIB PROPREMENT DIT 00272 C----------------------------------------------------------------------- 00273 C 00274 IRET=-1 00275 C ILENG=longueur disponible en nb d'"entiers declares INTEGER" dans KVALCO. 00276 C On part de l'hypothese ou le dimensionnement de KVALCO se fait 00277 C dans la routine appelante a ILCHAM+2 (cas de l'absence de compactage). 00278 ILENG=(KIND(KVALCO)/KIND(ILENG))*(ILCHAM+2-IDECAL) 00279 IWORD=0 00280 CDP 00281 CDP TEST AVEC UNE PUISSANCE DE LAPLACIEN IMPOSEE 00282 CDP 00283 CDP CALL GRSMKP(0) 00284 CDP ISEC4(17) = 2000 00285 CDP 00286 IF (FA%LFAMOP) THEN 00287 WRITE (UNIT=FA%NULOUT,FMT=*)' FACODX: CLOPER = ',CLOPER 00288 WRITE (UNIT=FA%NULOUT,FMT=*) 00289 S ' FACODX: IILCHAM, ILCHAM, IDECAL, ILENG = ', 00290 S IILCHAM, ILCHAM, IDECAL, ILENG 00291 WRITE (UNIT=FA%NULOUT,FMT=*)' * ISEC1 = ',ISEC1 00292 WRITE (UNIT=FA%NULOUT,FMT=*) 00293 S ' * ILONSEC2 ! ISEC2(1:ILONSEC2) = ', 00294 S ILONSEC2,' ! ', ISEC2(1:ILONSEC2) 00295 WRITE (UNIT=FA%NULOUT,FMT=*) ' * ZSEC2(1:2) = ',ZSEC2(1:2) 00296 IF (ISEC2(12).GT.0) WRITE (UNIT=FA%NULOUT,FMT=*) 00297 S ' * ISEC2(12) ! ZSEC2(11:10+ISEC2(12)) = ', 00298 S ISEC2(12), ' ! ', ZSEC2(11:10+ISEC2(12)) 00299 WRITE (UNIT=FA%NULOUT,FMT=*)' * FA%JPSEC4 ! ISEC4 = ', 00300 S FA%JPSEC4,' ! ',ISEC4 00301 WRITE (UNIT=FA%NULOUT,FMT=*)' * ZSEC4(1:20) = ', 00302 S ZSEC4(1:20) 00303 ENDIF 00304 C WARNING GRIBEX ENLEVE 00305 C CALL GRSDBG(0) 00306 C CALL GRSVCK(0) 00307 00308 C CALL GRIBEX(ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4, 00309 C S ZSEC4,IILCHAM,KVALCO(IDECAL+1),ILENG,IWORD, 00310 C S CLOPER,IRET) 00311 C 00312 IF (IRET.GT.0) THEN 00313 C Erreur rapportee par GRIBEX 00314 KREP=-1000-IRET 00315 GOTO 1001 00316 ELSEIF (IRET.LT.0) THEN 00317 C Warning rapporte par GRIBEX 00318 WRITE (UNIT=FA%NULOUT,FMT=*) 00319 WRITE (UNIT=FA%NULOUT,FMT=*) 00320 S '!------------------------------------------' 00321 WRITE (UNIT=FA%NULOUT,FMT=*) 00322 S '! FACODX: WARNING !!! !' 00323 WRITE (UNIT=FA%NULOUT,FMT=*) 00324 S '!------------------------------------------' 00325 WRITE (UNIT=FA%NULOUT,FMT=*) ' Code retour de GRIBEX = ', 00326 S IRET,' pour le champ: ',CDPREF,KNIVAU,CDSUFF 00327 WRITE (UNIT=FA%NULOUT,FMT=*) 00328 ENDIF 00329 C 00330 C ISEC0(1) = nb d'octets dans le message GRIB 00331 C IWORD = nb de mots de JBDBLE octets (64 bits) du message GRIB 00332 IWORD=1+(ISEC0(1)-1)/JPDBLE 00333 KLONGD=IDECAL+IWORD+IDIMNC 00334 IF (FA%LFAMOP) THEN 00335 WRITE (UNIT=FA%NULOUT,FMT=*) 00336 S ' FACODX: longueur du GRIB en nb octets et en mots = ', 00337 S ISEC0(1), IWORD 00338 WRITE (UNIT=FA%NULOUT,FMT=*) 00339 S ' FACODX: longueur de l''article FA en mots = ', 00340 S KLONGD 00341 IF (ISEC4(4).EQ.64 .AND. ISEC4(3).EQ.128) THEN 00342 WRITE (UNIT=FA%NULOUT,FMT=*) 00343 S ' FACODX: complex packing with P=',ISEC4(17), 00344 S ' and sub trunc = ',ISEC4(18) 00345 ENDIF 00346 ENDIF 00347 C 00348 C CAS D'UN DEPASSEMENT DE LA TAILLE MAX DE L'ARTICLE FINAL 00349 C On ramene ce cas a celui d'un tableau trop petit dans GRIBEX. 00350 C 00351 IF (KLONGD.GT.ILCHAM+2) THEN 00352 IF (FA%LFAMOP) THEN 00353 WRITE (UNIT=FA%NULOUT,FMT=*) 00354 S ' FACODX: article FA + long avec compactage', 00355 S ' que sans => on le supprime' 00356 ENDIF 00357 IRET=710 00358 KREP=-1000-IRET 00359 GOTO 1001 00360 ENDIF 00361 C 00362 C 00363 C* 00364 C 5. - CHANGEMENT D'UNITE DE CERTAINS CHAMPS. 00365 C Il s'agit de champs dont les valeurs sont comprises 00366 C entre 0 et 1 dans le modele mais dont l'unite 00367 C conventionnelle dans le GRIB est le %. 00368 C--------------------------------------------------------------- 00369 C 00370 INDEX = 0 00371 IF (CDPREF=='SURF') THEN 00372 IF (CDSUFF(1:6)=='NEBUL.' .OR. CDSUFF(1:6)=='ALBEDO' .OR. 00373 S CDSUFF=='PROP.VEGETAT' ) THEN 00374 INDEX = 1 00375 ENDIF 00376 ELSEIF (CDPREF(1:LEN(TRIM(CDPREF)))=='CLS') THEN 00377 IF (CDSUFF=='HUMI.RELATIVE' .OR. CDSUFF=='MAXI.HUMI.REL' .OR. 00378 S CDSUFF=='MINI.HUMI.REL' ) THEN 00379 INDEX = 1 00380 ENDIF 00381 ELSEIF (CDPREF(1:1)=='P'.OR.CDPREF(1:1)=='H') THEN 00382 C blindage 00383 IF (CDSUFF(1:10)=='HUMI_RELAT') THEN 00384 INDEX = 1 00385 ENDIF 00386 ENDIF 00387 IF (INDEX==1) THEN 00388 IADD = -2 00389 INBIMO = 32 ! Nombre de BIts par mot (un mot=INTEGER) 00390 INDEX = DECF10 ( KVALCO(IDECAL+1), ILENG, IADD, 00391 S IFAORI, IFAMOD, INBIMO ) 00392 IF (INDEX==-1) THEN 00393 WRITE (UNIT=FA%NULOUT,FMT=*) 00394 S 'FACODX: pas d''entete GRIB au debut !' 00395 KREP=-128 00396 GOTO 1001 00397 ELSEIF (INDEX==-2) THEN 00398 WRITE (UNIT=FA%NULOUT,FMT=*) 00399 S 'FACODX: edition du GRIB invalid pour DECF10 !' 00400 KREP=-128 00401 GOTO 1001 00402 ELSEIF (INDEX > 0) THEN 00403 WRITE (UNIT=FA%NULOUT,FMT=*) 00404 S 'FACODX: ERREUR dans appel a INXBIT par DECF10 !' 00405 WRITE (UNIT=FA%NULOUT,FMT=*) 00406 S ' avec code retour de INXBIT = ',INDEX 00407 KREP=-128 00408 GOTO 1001 00409 ELSEIF (INDEX < -2) THEN 00410 WRITE (UNIT=FA%NULOUT,FMT=*) 00411 S 'FACODX: code retour inconnu de DECF10 : ',INDEX 00412 KREP=-126 00413 GOTO 1001 00414 ENDIF 00415 ENDIF 00416 C 00417 C* 00418 C 6. - TRANSFERT DES COEFFICIENTS SPECTRAUX NON COMPACTES. 00419 C----------------------------------------------------------------------- 00420 C (et non traites par GRIBEX) en fin d'article. 00421 C 00422 IF (LDCOSP) THEN 00423 KVALCO(4)=ICPACK 00424 IF (LLMLAM) THEN 00425 KVALCO(5)=IPULAP 00426 C Copy nonpacked part of PSEC4 (sub-triangle+axes) into KVALCO 00427 IILCHAM=0 00428 DO JM=0,FA%NOMPAR(2,IRANGC) 00429 IL=2+2*JM+1 00430 ILOW=FA%NOMPAR(IL,IRANGC) 00431 C 00432 IF (JM.EQ.0) THEN 00433 IHIGH=FA%NOMPAR(IL+1,IRANGC) 00434 ELSE 00435 IHIGH=ILOW+4*(ICPACK+1-JM)-1 00436 IF (IHIGH.LE.ILOW) IHIGH=ILOW+3 00437 ENDIF 00438 C 00439 DO INDEX=ILOW,IHIGH 00440 IILCHAM=IILCHAM+1 00441 ZSEC4(IILCHAM)=PSEC4(INDEX) 00442 ENDDO 00443 ENDDO 00444 IF (IILCHAM.NE.IDIMNC) THEN 00445 WRITE (UNIT=FA%NULOUT,FMT='(A35,I10,A11,I10)') 00446 S 'FACODX: incoherence entre IILCHAM= ',IILCHAM, 00447 S 'et IDIMNC= ',IDIMNC 00448 KREP=-126 00449 GOTO 1001 00450 ENDIF 00451 ELSE 00452 KVALCO(5)=ISEC4(17) 00453 C Recuperation des coeff spectraux non compactes sachant que le 00454 C rangement est fait par colonnes de JM=cst juxtaposees 00455 ZSEC4(1:2*(ICPACK+1))=PSEC4(1:2*(ICPACK+1)) 00456 IILCHAM=2*(ICPACK+1)-1 00457 INDEX=2*(ITRONC+1)-1 00458 DO JM=1,ICPACK 00459 DO JN=JM,ITRONC 00460 INDEX=INDEX+2 00461 IF (JN.LE.ICPACK) THEN 00462 IILCHAM=IILCHAM+2 00463 ZSEC4(IILCHAM) = PSEC4(INDEX) 00464 ZSEC4(IILCHAM+1) = PSEC4(INDEX+1) 00465 ENDIF 00466 ENDDO 00467 ENDDO 00468 IF (IILCHAM+1.NE.IDIMNC) THEN 00469 WRITE (UNIT=FA%NULOUT,FMT='(A35,I10,A11,I10)') 00470 S 'FACODX: incoherence entre IILCHAM+1= ',IILCHAM+1, 00471 S 'et IDIMNC= ',IDIMNC 00472 KREP=-126 00473 GOTO 1001 00474 ENDIF 00475 ENDIF 00476 C Les IDIMNC coeff spectraux non compactes doivent etre transferes 00477 C sur le tableau d'entiers KVALCO apres le IDECAL+IWORD ieme elt. 00478 C 00479 C KVALCO(IDECAL+IWORD+1:KLONGD)=TRANSFER(ZSEC4,KVALCO,IDIMNC) 00480 ALLOCATE (IVALCO(IDIMNC)) 00481 IVALCO(1:IDIMNC)=TRANSFER(ZSEC4,IVALCO,IDIMNC) 00482 KVALCO(IDECAL+IWORD+1:KLONGD)=IVALCO(1:IDIMNC) 00483 DEALLOCATE (IVALCO) 00484 ENDIF 00485 C** 00486 C 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL, 00487 C VIA LE SOUS-PROGRAMME "FAIPAR" . 00488 C----------------------------------------------------------------------- 00489 C 00490 1001 CONTINUE 00491 IF (ALLOCATED(ZSEC4)) DEALLOCATE ( ZSEC4 ) 00492 C 00493 C Cas particulier de l'erreur GRIBEX num 710: OUTPUT ARRAY TOO SMALL 00494 C On s'en sert pour detecter un probleme de compactage lie a ce que 00495 C le champ compacte+les descripteurs prennent plus de place que le 00496 C champ non compacte... 00497 C On sort donc du compactage (FACODX) pour demander un codage sans 00498 C compactage (FACINE) avec rangement des valeurs selon le modele: 00499 C FA%NFGRIB=-1. 00500 C 00501 IF (IRET==710) THEN 00502 CLNSPR='FACODX' 00503 INIMES=2 00504 INUMER=FA%JPNIIL 00505 C 00506 WRITE (UNIT=CLMESS,FMT='(''KREP='',I5,'', KRANG=' 00507 ',I4, S '', CDPREF='''''',A,'''''', KNIVAU=' 00508 ',I6, S '', CDSUFF='''''',A,'''''', LDCOSP= ' 00509 ',L1, S '', KLONGD='',I6)') 00510 S KREP, KRANG, CDPREF(1:LEN_TRIM(CDPREF)), KNIVAU, 00511 S CDSUFF(1:LEN_TRIM(CDSUFF)), LDCOSP, KLONGD 00512 CALL FAIPAR_MT (FA, INUMER,INIMES,KREP,.FALSE.,CLMESS, 00513 S CLNSPR,CLACTI,.FALSE.) 00514 CLMESS= 00515 S ' CAUTION: this field is not packed or it will occupy more space' 00516 CALL FAIPAR_MT (FA, INUMER,INIMES,KREP,.FALSE.,CLMESS, 00517 S CLNSPR,CLACTI,.FALSE.) 00518 IF (LHOOK) CALL DR_HOOK('FACODX_MT',1,ZHOOK_HANDLE) 00519 RETURN 00520 ENDIF 00521 C 00522 C 00523 C 00524 LLFATA=LLMOER (KREP,KRANG) 00525 C 00526 IF (FA%LFAMOP.OR.LLFATA) THEN 00527 INIMES=2 00528 CLNSPR='FACODX' 00529 INUMER=FA%JPNIIL 00530 C 00531 WRITE (UNIT=CLMESS,FMT='(''KREP='',I5,'', KRANG=' 00532 ',I4, S '', CDPREF='''''',A,'''''', KNIVAU=' 00533 ',I6, S '', CDSUFF='''''',A,'''''', LDCOSP= ' 00534 ',L1, S '', KLONGD='',I6)') 00535 S KREP, KRANG, CDPREF(1:LEN_TRIM(CDPREF)), KNIVAU, 00536 S CDSUFF(1:LEN_TRIM(CDSUFF)), LDCOSP, KLONGD 00537 CALL FAIPAR_MT (FA, INUMER,INIMES,KREP,.FALSE.,CLMESS, 00538 S CLNSPR,CLACTI,.FALSE.) 00539 ENDIF 00540 C 00541 IF (LHOOK) CALL DR_HOOK('FACODX_MT',1,ZHOOK_HANDLE) 00542 END 00543
1.8.0
