|
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 FACINE_MT (FA, KREP, KRANG, CDNOMA, KCHAMP, LDCOSP, 00003 S KVALCO, KLONGD, KB1PAR ) 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 GRIB ou non) d'un CHAMP HORIZONTAL 00010 C destine a etre ecrit sur un fichier ARPEGE/ALADIN. 00011 C ( Codage Interne d'un (Nouveau ?) champ a Ecrire ) 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 ) KCHAMP (Entree) ==> Valeurs REELLES du champ a ecrire; 00017 C LDCOSP (Entree) ==> Vrai si le champ est represente 00018 C par des coefficients spectraux; 00019 C ( Tableau ) KVALCO (Sortie) ==> Donnees destinees a l'ecriture; 00020 C KLONGD (Sortie) ==> Nombre de mots a ecrire; 00021 C ( Tableau ) KB1PAR (Entree+ ==> Image des parametres de la section 00022 C Sortie) 1 de GRIB. 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 Juin 2001, D. Paradis, DT/DSI/DEV: 00030 C 00031 C -retrait du compactage lorsqu'il conduit a un article de longueur 00032 C superieure a celle obtenue sans le compactage (permet aussi de 00033 C dimensionner KVALCO a ILCHAM+2 sans risquer un debordement) 00034 C 00035 C Avril 2004, D. Paradis, DT/DSI/DEV: 00036 C 00037 C -declaration de FA%ICHAMP et FA%ICHAUX en ALLOCATABLE (gain memoire) 00038 C 00039 C January 2010 Trygve Aspelien & Ryad El Khatib : 00040 C - workaround against memory leak on IBM 00041 C 00042 #include "precision.h" 00043 C 00044 C 00045 TYPE(FA_COM) :: FA 00046 INTEGER KREP, KRANG, KLONGD 00047 C 00048 INTEGER (KIND=JPDBLE) KCHAMP(*), KVALCO(*) 00049 INTEGER KB1PAR (FA%JPLB1P) 00050 C 00051 LOGICAL LDCOSP 00052 C 00053 CHARACTER CDNOMA*(*) 00054 C 00055 INTEGER ILCHAM, ISTRIA, IVALC1, IVALC2, J, IDECAL, ICPACK, IPUILA 00056 INTEGER ITRONC, IIND, ILOW, IHIGH, JTRON, IDIMNC, ILDISP, INBITS 00057 INTEGER IL, IADD, IRANGC, IARR, IILCHAM, INMOCC, IERR, INIMES 00058 INTEGER INUMER, IAUXIL, ITRONC2, ILONGFA, ILONGSEC, ILONGDATA 00059 INTEGER ILONGD 00060 C 00061 INTEGER IB2PAR (FA%JPLB2P) 00062 C 00063 LOGICAL LLARPE, LLMLAM 00064 C 00065 #include "facom2.h" 00066 #include "facom_mt.h" 00067 C** 00068 C 1. - CONTROLES ET INITIALISATIONS. 00069 C----------------------------------------------------------------------- 00070 C 00071 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00072 IF (LHOOK) CALL DR_HOOK('FACINE_MT',0,ZHOOK_HANDLE) 00073 IF (KRANG.LE.0.OR.KRANG.GT.FA%JPNXFA) THEN 00074 KREP=-66 00075 GOTO 1001 00076 ENDIF 00077 C** 00078 C 2. - FABRICATION DE L'ARTICLE A ECRIRE SUR LE FICHIER. 00079 C----------------------------------------------------------------------- 00080 C 00081 IVALC1=FA%NFGRIB(KRANG) 00082 LLARPE=IVALC1.EQ.2 00083 IRANGC=FA%NUCADR(KRANG) 00084 LLMLAM=FA%LIMLAM(IRANGC) 00085 C 00086 C Initialisation du nombre de valeurs du champ (ILCHAM) 00087 C du type de champ (IVALC2): spectral/pdg 00088 C du type de representation de donnees (IB2PAR(1)) 00089 C du nombre de bits utilises pour le compactage 00090 C de la longueur (en mots de 64 bits) de l'enrobage de l'article 00091 C FA (ILONGFA) + les donnees non compactees (en spectral) 00092 C de la longueur (en octets) des sections 0, 1 et 5 du GRIB 00093 C devant apparaitre dans l'article FA (ILONGSEC) 00094 C de la longueur (en bits) de la section 4 du GRIB (ILONGDATA), 00095 C devant etre un multiple de 16 bits. 00096 C 00097 C ILONGSEC= 4 (S0) + 24 (S1) + 4 (S5) pour le GRIB version 0 00098 ILONGSEC=32 00099 IF (LDCOSP) THEN 00100 C 00101 IVALC2=1 00102 INBITS=FA%NBFCSP(KRANG) 00103 C 00104 IF (LLMLAM) THEN 00105 IB2PAR(1)=34 00106 ILCHAM=FA%NSFLAM(IRANGC) 00107 IF (IVALC1.GT.0) THEN 00108 C calcul du nombre de coefficients non compactes ISTRIA 00109 ICPACK=FA%NSTROF(KRANG) 00110 ITRONC=FA%MTRONC(IRANGC) 00111 ITRONC2=-FA%NTYPTR(IRANGC) 00112 ISTRIA=4*(1+ITRONC+ITRONC2+(ICPACK*(ICPACK-1)/2)) 00113 C 00114 ILONGFA=3+2*IVALC1+ISTRIA 00115 C Les 88 bits correspondent aux 11 octets d'enrobage GRIB V0 de la section 4 00116 ILONGDATA=(ILCHAM-ISTRIA)*INBITS + 88 00117 ENDIF 00118 ELSE 00119 IF (IVALC1.EQ.-1) THEN 00120 ILCHAM=(1+FA%MTRONC(IRANGC))*(2+FA%MTRONC(IRANGC)) 00121 ELSE 00122 ILCHAM=(1+FA%MTRONC(IRANGC))**2 00123 ENDIF 00124 IB2PAR(1)=80 00125 IF (IVALC1.GT.0) THEN 00126 ICPACK=FA%NSTROF(KRANG) 00127 C calcul du nombre de coefficients non compactes IDIMNC 00128 IDIMNC=(1+ICPACK)**2 00129 ILONGFA=3+2*IVALC1+IDIMNC 00130 C Les 144 bits correspondent aux 18 octets d'enrobage GRIB V0 de la section 4 00131 ILONGDATA=ILCHAM*INBITS + IDIMNC*(32-INBITS) + 144 00132 ENDIF 00133 ENDIF 00134 C 00135 ELSE 00136 C 00137 ILCHAM=FA%NVAPDG(IRANGC) 00138 IVALC2=0 00139 IB2PAR(1)=34 00140 INBITS=FA%NBFPDG(KRANG) 00141 IF (IVALC1.GT.0) THEN 00142 ILONGFA=1+2*IVALC1 00143 C Les 88 bits correspondent aux 11 octets d'enrobage GRIB V0 de la section 4 00144 ILONGDATA=ILCHAM*INBITS + 88 00145 ENDIF 00146 C 00147 ENDIF 00148 C 00149 C Retrait du compactage si celui-ci s'avere conduire 00150 C a un article plus long qu'en l'absence de compactage: 00151 C 00152 IF (IVALC1.GT.0) THEN 00153 C Arrondi de ILONGDATA au premier multiple de 16 superieur ou egal 00154 ILONGDATA=16*(1+(ILONGDATA-1)/16) 00155 C Calcul du nombre de mots (64 bits) de la partie GRIB 00156 ILONGD=1+(ILONGDATA+8*ILONGSEC-1)/64 00157 C On ajoute l'enrobage FA et les eventuelles donnees non compactees 00158 ILONGD=ILONGD+ILONGFA 00159 IF (ILONGD.GT.ILCHAM+2) THEN 00160 WRITE (FA%NULOUT,*) 00161 S '///// FACINE: the packing of article ',CDNOMA, 00162 S ' is not done because it will generate' 00163 WRITE (FA%NULOUT,*) 00164 S ' a size ( ',ILONGD,' words ) bigger than', 00165 S ' the one ( ',ILCHAM+2,' words ) obtained without packing.' 00166 IVALC1=0 00167 WRITE (FA%NULOUT,*) 00168 ENDIF 00169 ENDIF 00170 C 00171 ISTRIA = 0 00172 C 00173 IF (IVALC1.EQ.-1.OR.IVALC1.EQ.0) THEN 00174 C 00175 C Cas ou il n'y a aucun codage... 00176 C transfert du tableau d'entree a la suite des 2 valeurs 00177 C documentaires stockees ci-dessus dans KVALCO. 00178 C 00179 DO 301 J=1,ILCHAM 00180 KVALCO(2+J)=KCHAMP(J) 00181 301 CONTINUE 00182 C 00183 KLONGD=2+ILCHAM 00184 C 00185 ELSE 00186 C 00187 C Cas avec codage GRIB (standard ou non). 00188 C 00189 #ifndef RS6K 00190 IF ( ASSOCIATED(FA%ICHAMP) ) DEALLOCATE(FA%ICHAMP) 00191 ALLOCATE (FA%ICHAMP (ILCHAM)) 00192 #else 00193 IF (.NOT. ASSOCIATED(FA%ICHAMP)) THEN 00194 ALLOCATE (FA%ICHAMP (ILCHAM)) 00195 ELSEIF ( ILCHAM .GT. SIZE(FA%ICHAMP) ) THEN 00196 DEALLOCATE(FA%ICHAMP) 00197 ALLOCATE (FA%ICHAMP (ILCHAM)) 00198 ENDIF 00199 #endif 00200 C 00201 IDECAL=1+2*IVALC1 00202 KB1PAR(1)=98 00203 KB1PAR(2)=1 00204 KB1PAR(3)=254 00205 KB1PAR(4)=0 00206 KB1PAR(5)=255 00207 KB1PAR(9)=MOD (FA%MADATE(1,KRANG),100) 00208 C 00209 DO 302 J=2,FA%JPLDAT 00210 KB1PAR(8+J)=FA%MADATE(J,KRANG) 00211 302 CONTINUE 00212 C 00213 IB2PAR(6)=2 00214 IPUILA=FA%NPUFLA(KRANG) 00215 ITRONC=FA%MTRONC(IRANGC) 00216 C 00217 IF (LDCOSP) THEN 00218 C 00219 C Champ en coefficients spectraux... traitement particulier, 00220 C lie a la possibilite de compacter une (pseudo-)puissance de 00221 C laplacien du champ a la place du champ, de maniere a augmenter 00222 C la precision du champ en "aplanissant" le spectre. 00223 C 00224 CALL FACSIM_MT (FA, KREP,KRANG,KCHAMP,FA%ICHAMP,IPUILA,ICPACK) 00225 IF (FA%LFAMOP) THEN 00226 print *,'FACINE: puissance Dolby selectionnee ',IPUILA 00227 ENDIF 00228 IF (KREP.NE.0) GOTO 1001 00229 IF (LLMLAM) THEN 00230 C Copy the elements to be compacted from FA%ICHAMP to a work array 00231 C This is that part of the quarter-ellipse which is out of the triangle of no compacting. 00232 C In addition, the axes of ellipse are also excluded because of zero-coefficients 00233 #ifndef RS6K 00234 ALLOCATE (FA%ICHAUX (ILCHAM)) 00235 #else 00236 IF (.NOT. ASSOCIATED(FA%ICHAUX)) THEN 00237 ALLOCATE (FA%ICHAUX (ILCHAM)) 00238 ELSEIF ( ILCHAM .GT. SIZE(FA%ICHAUX) ) THEN 00239 DEALLOCATE(FA%ICHAUX) 00240 ALLOCATE (FA%ICHAUX (ILCHAM)) 00241 ENDIF 00242 #endif 00243 IIND=0 00244 C 00245 DO 3021 JTRON=1,ITRONC 00246 ILOW=2+2*JTRON+1 00247 IADD=4* MAX(ICPACK+1-JTRON,1) 00248 C 00249 DO 3021 J=FA%NOZPAR(ILOW,IRANGC)+IADD, 00250 S FA%NOZPAR(ILOW+1,IRANGC) 00251 IIND=IIND+1 00252 FA%ICHAUX(IIND)=FA%ICHAMP(J) 00253 3021 CONTINUE 00254 C Number of elements in sub-triangle+axes:ISTRIA 00255 ISTRIA=ILCHAM-IIND 00256 IDIMNC=0 00257 ELSE 00258 ISTRIA=IDIMNC 00259 ENDIF 00260 C 00261 IDECAL=IDECAL+2 00262 ILDISP=ILCHAM+2-IDECAL-(IVALC1-1)*ISTRIA 00263 C 00264 IF (.NOT.LLARPE) THEN 00265 C 00266 C Recopie des coefficients spectraux "non compactes", 00267 C qui sont codes en fait sur 32 bits dans le cas standard de GRIB. 00268 C 00269 DO 303 J=1,IDIMNC 00270 FA%ICHAMP(J)=KCHAMP(J) 00271 303 CONTINUE 00272 C 00273 ENDIF 00274 C 00275 ELSE 00276 C 00277 C Transfert du tableau d'entree dans un tableau local 00278 C de maniere a eviter l'ecrasement du tableau d'entree par "CODEGA". 00279 C 00280 DO 305 J=1,ILCHAM 00281 FA%ICHAMP(J)=KCHAMP(J) 00282 305 CONTINUE 00283 C 00284 IDIMNC=0 00285 ILDISP=ILCHAM+2-IDECAL 00286 ENDIF 00287 C* 00288 C 3.1 - CODAGE GRIB PROPREMENT DIT. 00289 C----------------------------------------------------------------------- 00290 C 00291 IARR=0 00292 C 00293 IF (LDCOSP.AND.LLMLAM) THEN 00294 IILCHAM=ILCHAM-ISTRIA 00295 CALL CODEGA(FA%ICHAUX,IILCHAM,INBITS,FA%NBIMAC,KB1PAR,IB2PAR, 00296 S FA%SFOHYB(1,0,IRANGC),2,KVALCO(IDECAL+1),ILDISP, 00297 S INMOCC,IARR, 0,IPUILA,IERR, 00298 S KVALCO(IDECAL-1),KVALCO(IDECAL),LLARPE) 00299 ELSE 00300 CALL CODEGA(FA%ICHAMP,ILCHAM,INBITS,FA%NBIMAC,KB1PAR,IB2PAR, 00301 S FA%SFOHYB(1,0,IRANGC),2,KVALCO(IDECAL+1),ILDISP, 00302 S INMOCC,IARR,ICPACK,IPUILA,IERR, 00303 S KVALCO(IDECAL-1),KVALCO(IDECAL),LLARPE) 00304 ENDIF 00305 #ifndef RS6K 00306 IF (ASSOCIATED( FA%ICHAMP )) DEALLOCATE ( FA%ICHAMP ) 00307 #endif 00308 C 00309 IF (IERR.NE.0) THEN 00310 KREP=-200+IERR 00311 GOTO 1001 00312 ELSEIF (LDCOSP) THEN 00313 KVALCO(4)=ICPACK 00314 KVALCO(5)=IPUILA 00315 C 00316 IF (LLARPE) THEN 00317 C* 00318 C 3.2 - TRANSFERT DES COEFFICIENTS SPECTRAUX NON COMPACTES. 00319 C----------------------------------------------------------------------- 00320 C (et non traites par CODEGA) en fin d'article. 00321 C 00322 IF (LLMLAM) THEN 00323 C Copy nonpacked part of kchamp (sub-triangle+axes) into ichaux 00324 IIND=0 00325 C 00326 DO 3201 JTRON=0,ITRONC 00327 IL=2+2*JTRON+1 00328 ILOW=FA%NOZPAR(IL,IRANGC) 00329 C 00330 IF (JTRON.EQ.0) THEN 00331 IHIGH=FA%NOZPAR(IL+1,IRANGC) 00332 ELSE 00333 IHIGH=ILOW+4*(ICPACK+1-JTRON)-1 00334 IF (IHIGH.LE.ILOW) IHIGH=ILOW+3 00335 ENDIF 00336 C 00337 DO 3201 J=ILOW,IHIGH 00338 IIND=IIND+1 00339 FA%ICHAUX(IIND)=KCHAMP(J) 00340 3201 CONTINUE 00341 C 00342 DO 3202 J=1,ISTRIA 00343 KVALCO(IDECAL+INMOCC+J)=FA%ICHAUX(J) 00344 3202 CONTINUE 00345 C 00346 #ifndef RS6K 00347 IF (ASSOCIATED( FA%ICHAUX )) DEALLOCATE ( FA%ICHAUX ) 00348 #endif 00349 C 00350 ELSE 00351 C 00352 DO 321 J=1,IDIMNC 00353 KVALCO(IDECAL+INMOCC+J)=KCHAMP(J) 00354 321 CONTINUE 00355 C 00356 ENDIF 00357 C 00358 ENDIF 00359 C 00360 ENDIF 00361 C 00362 KVALCO(3)=INBITS 00363 C 00364 IF (LLMLAM) THEN 00365 KLONGD=IDECAL+INMOCC+ISTRIA 00366 ELSE 00367 KLONGD=IDECAL+INMOCC+IDIMNC 00368 ENDIF 00369 C 00370 ENDIF 00371 C 00372 KVALCO(1)=IVALC1 00373 KVALCO(2)=IVALC2 00374 C** 00375 C 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL, 00376 C VIA LE SOUS-PROGRAMME "FAIPAR" . 00377 C----------------------------------------------------------------------- 00378 C 00379 1001 CONTINUE 00380 LLFATA=LLMOER (KREP,KRANG) 00381 C 00382 IF (FA%LFAMOP.OR.LLFATA) THEN 00383 INIMES=2 00384 CLNSPR='FACINE' 00385 INUMER=FA%JPNIIL 00386 C 00387 WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KRANG=' 00388 ',I4, S '', CDNOMA='''''',A,'''''', LDCOSP= ' 00389 ',L1, S '', KLONGD='',I8)') 00390 S KREP, KRANG, CDNOMA, LDCOSP, KLONGD 00391 CALL FAIPAR_MT (FA, INUMER,INIMES,KREP,.FALSE.,CLMESS, 00392 S CLNSPR, CDNOMA,.FALSE.) 00393 ENDIF 00394 C 00395 #ifndef RS6K 00396 IF (ASSOCIATED( FA%ICHAUX )) DEALLOCATE ( FA%ICHAUX ) 00397 IF (ASSOCIATED( FA%ICHAMP )) DEALLOCATE ( FA%ICHAMP ) 00398 #endif 00399 IF (LHOOK) CALL DR_HOOK('FACINE_MT',1,ZHOOK_HANDLE) 00400 END 00401
1.8.0
