|
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 FACOCH_MT (FA, KREP, KNUME1, KNUME2, 00003 S CDPREF, KNIVAU, CDSUFF ) 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 de reCOpie d'un Champ Horizontal d'un fichier 00009 C ARPEGE sur un autre. 00010 C** 00011 C Arguments : KREP (Sortie) ==> Code-reponse du sous-programme; 00012 C KNUME1 (Entree) ==> Numero d'unite logique en entree; 00013 C KNUME2 (Entree) ==> Numero d'unite logique en sortie; 00014 C CDPREF (Entree) ==> Prefixe eventuel du nom d'article; 00015 C KNIVAU (Entree) ==> Niveau vertical eventuel; 00016 C CDSUFF (Entree) ==> Suffixe eventuel du nom d'article. 00017 C 00018 C Modifications 00019 C ------------- 00020 C 00021 C Avril 2004, D. Paradis, DSI/DEV: 00022 C -Declaration IVALCO en ALLOCATABLE (gain memoire) 00023 C Juin 2004, D. Paradis, DSI/DEV: 00024 C -Prise en compte des codages type -1 et 3 00025 C 00026 #include "precision.h" 00027 C 00028 C 00029 TYPE(FA_COM) :: FA 00030 INTEGER KREP, KNUME1, KNUME2, KNIVAU 00031 C 00032 INTEGER IREP, ILPRFU, ILSUFU, ILNOMU, ILONGA, IRANC1, IRANC2 00033 INTEGER INIMES, J, INUMFI, IPOSEX, INPAHE, INPAHEL, JLAT, IZPAHEL 00034 INTEGER ISPAHEL, JNIV, ILPREF, ILSUFF, INUMRO, IRANG2, IGRIB 00035 C 00036 INTEGER (KIND=JPDBLE), ALLOCATABLE :: IVALCO(:) 00037 INTEGER IRANG (2), INUMER (2), IB1PAR (3) 00038 C 00039 LOGICAL LLVERF (2), LLRLFI, LLCOSP, LLMESS, LLNOMU 00040 LOGICAL LLMLAM1, LLMLAM2 00041 C 00042 CHARACTER CDPREF*(*), CDSUFF*(*) 00043 CHARACTER CLAUXI*(FA%JPXNOM), CLPREF*(FA%JPXNOM), 00044 S CLSUFF*(FA%JPXSUF) 00045 C 00046 #include "facom2.h" 00047 #include "facom_mt.h" 00048 C** 00049 C 1. - CONTROLES ET INITIALISATIONS. 00050 C----------------------------------------------------------------------- 00051 C 00052 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00053 IF (LHOOK) CALL DR_HOOK('FACOCH_MT',0,ZHOOK_HANDLE) 00054 LLRLFI=.FALSE. 00055 LLMESS=.FALSE. 00056 LLNOMU=.FALSE. 00057 ILPRFU=LEN (CDPREF) 00058 ILSUFU=LEN (CDSUFF) 00059 IRANC1=0 00060 IRANC2=0 00061 INUMER(1)=KNUME1 00062 INUMER(2)=KNUME2 00063 LLVERF(1)=.FALSE. 00064 LLVERF(2)=.FALSE. 00065 IRANG(2)=0 00066 C 00067 DO 101 J=1,2 00068 INUMFI=J 00069 CALL FANUMU_MT (FA, INUMER(J),IRANG(J)) 00070 C 00071 IF (IRANG(J).EQ.0) THEN 00072 IREP=-51 00073 GOTO 1001 00074 ENDIF 00075 C 00076 C Verrouillage eventuel du fichier. 00077 C 00078 IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG(J)),'ON') 00079 LLVERF(J)=FA%LFAMUL 00080 C 00081 IF (FA%LCREAF(IRANG(J))) THEN 00082 IREP=-85 00083 GOTO 1001 00084 ENDIF 00085 C* 00086 C FABRICATION DU NOM D'ARTICLE VIA LE SOUS-PROGRAMME "FANFAR" 00087 C ( controles de CDPREF, KNIVAU, CDSUFF inclus ) 00088 C 00089 CALL FANFAR_MT (FA, IREP,IRANG(J),CDPREF,KNIVAU, 00090 S CDSUFF,CLNOMA,IB1PAR, 00091 S ILPRFU,ILSUFU,ILNOMU) 00092 IF (IREP.NE.0) GOTO 1001 00093 101 CONTINUE 00094 C 00095 LLNOMU=.TRUE. 00096 C** 00097 C 2. - LECTURE DE L'ARTICLE SUR LE FICHIER, CONTROLES. 00098 C----------------------------------------------------------------------- 00099 C 00100 CALL LFINFO_MT (FA%LFI, IREP,KNUME1,CLNOMA(1:ILNOMU), 00101 S ILONGA,IPOSEX) 00102 C 00103 IF (IREP.NE.0) THEN 00104 LLRLFI=.TRUE. 00105 GOTO 1001 00106 ELSEIF (ILONGA.EQ.0) THEN 00107 IREP=-89 00108 GOTO 1001 00109 ELSEIF (ILONGA.GT.FA%JPXCHA+2) THEN 00110 IREP=-90 00111 GOTO 1001 00112 ENDIF 00113 C 00114 ALLOCATE (IVALCO (ILONGA)) 00115 CALL LFILEC_MT (FA%LFI, IREP,KNUME1, 00116 S CLNOMA(1:ILNOMU),IVALCO,ILONGA) 00117 LLRLFI=IREP.NE.0 00118 IF (LLRLFI) GOTO 1001 00119 C 00120 IF (IVALCO(1).LT.-1.OR.IVALCO(1).GT.3.OR. 00121 S IVALCO(2).LT.0 .OR.IVALCO(2).GT.1.OR. 00122 S (IVALCO(1).GT.0.AND.IVALCO(2).EQ.1.AND.IVALCO(4).LT.0)) THEN 00123 IREP=-91 00124 GOTO 1001 00125 ELSE 00126 LLCOSP=IVALCO(2).EQ.1 00127 ENDIF 00128 C** 00129 C 3. - CONTROLE DE COHERENCE ENTRE LES FICHIERS, VIS-A-VIS DU TYPE 00130 C DE DONNEES LUES (points de grille/coefficients spectraux). 00131 C----------------------------------------------------------------------- 00132 C 00133 IRANC1=FA%NUCADR(IRANG(1)) 00134 IRANC2=FA%NUCADR(IRANG(2)) 00135 INPAHE=(1+FA%NLATIT(IRANC1))/2 00136 LLMLAM1=FA%NTYPTR(IRANC1).LE. -1 00137 LLMLAM2=FA%NTYPTR(IRANC2).LE. -1 00138 C 00139 IF (IRANC1.NE.IRANC2) THEN 00140 C 00141 C On a pris ici une optique souple: n'est fatale qu'une erreur 00142 C vraiment grossiere. Toute autre discordance est signalee par un 00143 C message global de niveau 1. 00144 C 00145 IF ( (LLMLAM1.AND..NOT.LLMLAM2).OR. 00146 S (LLMLAM2.AND..NOT.LLMLAM1).OR. 00147 S (LLCOSP.AND.((.NOT.LLMLAM1.AND..NOT.LLMLAM2.AND. 00148 S FA%MTRONC(IRANC1).NE.FA%MTRONC(IRANC2)) .OR. 00149 S (LLMLAM1.AND.LLMLAM2.AND. 00150 S FA%MTRONC(IRANC1).NE.FA%MTRONC(IRANC2).AND. 00151 S FA%NTYPTR(IRANC1).NE.FA%NTYPTR(IRANC2) )) 00152 S ).OR. 00153 S (.NOT.LLCOSP.AND.(FA%NLATIT(IRANC1).NE. 00154 S FA%NLATIT(IRANC2).OR. 00155 S FA%NVAPDG(IRANC1).NE.FA%NVAPDG(IRANC2))) 00156 S ) THEN 00157 IREP=-112 00158 GOTO 1001 00159 C 00160 ELSEIF (.NOT.LLCOSP) THEN 00161 C 00162 IF (.NOT.LLMLAM1.AND..NOT.LLMLAM2) THEN 00163 INPAHEL=INPAHE 00164 ELSE 00165 INPAHEL=8 00166 ENDIF 00167 DO 301 JLAT=1,INPAHEL 00168 LLMESS=LLMESS.OR.FA%NLOPAR(JLAT,IRANC1).NE. 00169 S FA%NLOPAR(JLAT,IRANC2) 00170 301 CONTINUE 00171 C 00172 IF (LLMESS) THEN 00173 IREP=-112 00174 GOTO 1001 00175 ENDIF 00176 C 00177 ENDIF 00178 C 00179 LLMESS=FA%MTRONC(IRANC1).NE.FA%MTRONC(IRANC2).OR. 00180 S FA%NTYPTR(IRANC1).NE.FA%NTYPTR(IRANC2).OR. 00181 S (KNIVAU.GT.0.AND.(FA%NNIVER(IRANC1).NE. 00182 S FA%NNIVER(IRANC2)).OR. 00183 S (FA%SPREFE(IRANC1).NE. 00184 S FA%SPREFE(IRANC2))).OR. 00185 S FA%NLATIT(IRANC1).NE.FA%NLATIT(IRANC2).OR. 00186 S FA%SSLAPO(IRANC1).NE.FA%SSLAPO(IRANC2).OR. 00187 S FA%SCLOPO(IRANC1).NE.FA%SCLOPO(IRANC2).OR. 00188 S FA%SSLOPO(IRANC1).NE.FA%SSLOPO(IRANC2).OR. 00189 S FA%SCODIL(IRANC1).NE.FA%SCODIL(IRANC2) 00190 C 00191 IF (.NOT.LLMESS) THEN 00192 C 00193 IF (.NOT.LLMLAM1.AND..NOT.LLMLAM2) THEN 00194 INPAHEL=INPAHE 00195 IZPAHEL=INPAHE 00196 ISPAHEL=INPAHE 00197 ELSE 00198 INPAHEL=8 00199 IZPAHEL=0 00200 ISPAHEL=18 00201 ENDIF 00202 DO 302 JLAT=1,INPAHEL 00203 LLMESS=FA%NLOPAR(JLAT,IRANC1).NE.FA%NLOPAR(JLAT,IRANC2) 00204 S .OR.LLMESS 00205 302 CONTINUE 00206 DO 312 JLAT=1,IZPAHEL 00207 LLMESS=FA%NOZPAR(JLAT,IRANC1).NE.FA%NOZPAR(JLAT,IRANC2) 00208 S .OR.LLMESS 00209 312 CONTINUE 00210 DO 322 JLAT=1,ISPAHEL 00211 LLMESS=FA%SINLAT(JLAT,IRANC1).NE.FA%SINLAT(JLAT,IRANC2) 00212 S .OR.LLMESS 00213 322 CONTINUE 00214 C 00215 IF (.NOT.LLMESS.AND.KNIVAU.GT.0) THEN 00216 C 00217 DO 303 JNIV=0,FA%NNIVER(IRANC1) 00218 LLMESS=FA%SFOHYB(1,JNIV,IRANC1).NE. 00219 S FA%SFOHYB(1,JNIV,IRANC2).OR. 00220 S LLMESS.OR.FA%SFOHYB(2,JNIV,IRANC1).NE. 00221 S FA%SFOHYB(2,JNIV,IRANC2) 00222 303 CONTINUE 00223 C 00224 ENDIF 00225 C 00226 ENDIF 00227 C 00228 ENDIF 00229 C** 00230 C 4. - ECRITURE DE L'ARTICLE "CHAMP" SUR LE FICHIER. 00231 C----------------------------------------------------------------------- 00232 C 00233 C Deverrouillage eventuel de l'unite logique d'entree. 00234 C 00235 IF (LLVERF(1)) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG(1)),'OFF') 00236 LLVERF(1)=.FALSE. 00237 C 00238 CALL LFIECR_MT (FA%LFI, IREP,KNUME2,CLNOMA(1:ILNOMU), 00239 S IVALCO,ILONGA) 00240 INUMFI=2 00241 LLRLFI=IREP.NE.0 00242 IF (LLRLFI) GOTO 1001 00243 C 00244 C Controle de l'homogeneite du type de rangement de coeff. spectraux 00245 C parmi les champs lus/ecrits: ces champs compactes avec 00246 C IGRIB=-1 ou 3 doivent etre ranges comme dans le modele ("verticalement" 00247 C soit selon des colonnes JM=cst consecutives) et contrairement si compactes 00248 C avec IGRIB= 0,1 ou 2. 00249 C 00250 IRANG2 = IRANG(2) 00251 IGRIB = IVALCO(1) 00252 IF (LLCOSP) THEN 00253 IF (IGRIB.EQ.-1 .OR. IGRIB.EQ.3) THEN 00254 FA%NRASVE(IRANG2)=FA%NRASVE(IRANG2)+1 00255 IF (FA%NRASVE(IRANG2).EQ.1 .AND. FA%NRASHO(IRANG2).GT.0) THEN 00256 WRITE(FA%NULOUT,*) 00257 S '------------------------------------------------' 00258 WRITE(FA%NULOUT,*)' FACOCH : WARNING !!!!! ' 00259 WRITE(FA%NULOUT,*) 00260 S ' Un champ de coef. spect. avec rangt type modele' 00261 WRITE(FA%NULOUT,*)' va etre ecrit sur l''unite ',KNUME2, 00262 S ' alors que' 00263 WRITE(FA%NULOUT,*) 00264 S ' d''autres champs y ont un rangement different.' 00265 WRITE(FA%NULOUT,*) 00266 S '------------------------------------------------' 00267 ENDIF 00268 ELSEIF (IGRIB.GE.0 .AND. IGRIB.LE.2) THEN 00269 FA%NRASHO(IRANG2)=FA%NRASHO(IRANG2)+1 00270 IF (FA%NRASHO(IRANG2).EQ.1 .AND. FA%NRASVE(IRANG2).GT.0) THEN 00271 WRITE(FA%NULOUT,*) 00272 S '------------------------------------------------' 00273 WRITE(FA%NULOUT,*)' FACOCH : WARNING !!!!! ' 00274 WRITE(FA%NULOUT,*) 00275 S ' Un champ de coef. spect. avec rangt autre que' 00276 WRITE(FA%NULOUT,*) 00277 S ' celui du modele va etre ecrit sur l''unite ', KNUME2 00278 WRITE(FA%NULOUT,*) 00279 S ' alors que d''autres champs y ont le rangt modele' 00280 WRITE(FA%NULOUT,*) 00281 S '------------------------------------------------' 00282 ENDIF 00283 ENDIF 00284 ENDIF 00285 C 00286 C** 00287 C 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL, 00288 C VIA LE SOUS-PROGRAMME "FAIPAR" . 00289 C----------------------------------------------------------------------- 00290 C 00291 1001 CONTINUE 00292 IF (ALLOCATED( IVALCO )) DEALLOCATE ( IVALCO ) 00293 KREP=IREP 00294 LLFATA=LLMOER (IREP,IRANG(INUMFI)) 00295 C 00296 C Deverrouillage eventuel des fichiers. 00297 C 00298 IF (LLVERF(1)) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG(1)),'OFF') 00299 IF (LLVERF(2)) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG(2)),'OFF') 00300 C 00301 CLNSPR='FACOCH' 00302 C 00303 C Messages d'avertissement eventuels. 00304 C 00305 IF (FA%NIMSGA.NE.0.AND.IREP.EQ.0) THEN 00306 C 00307 IF (LLMESS) THEN 00308 INIMES=1 00309 WRITE (UNIT=CLMESS,FMT='(''*ATTENTION* - LES UNITES' 00310 ',I3, S '' ET'',I3,'' ONT DES CARACTERISTIQUES "CADRE" DIFFERENTES'')') 00311 S KNUME1,KNUME2 00312 CALL FAIPAR_MT (FA, FA%JPNIIL,INIMES,IREP,.FALSE.,CLMESS, 00313 S CLNSPR,CLACTI,.FALSE.) 00314 ELSEIF (IRANC1.NE.IRANC2) THEN 00315 INIMES=1 00316 WRITE (UNIT=CLMESS,FMT='(''REMARQUE: CADRES ''''' 00317 ',A, S '''''' ET ''''' 00318 ',A, S '''''' DISTINCTS MAIS DE CONTENU IDENTIQUE (UNITES' 00319 ', S I3,'' ET'',I3,'' )'')') 00320 S FA%CNOMCA(IRANC1)(1:FA%NLCCAD(IRANC1)), 00321 S FA%CNOMCA(IRANC2)(1:FA%NLCCAD(IRANC2)),KNUME1,KNUME2 00322 CALL FAIPAR_MT (FA, FA%JPNIIL,INIMES,IREP,.FALSE.,CLMESS, 00323 S CLNSPR,CLACTI,.FALSE.) 00324 ENDIF 00325 C 00326 ENDIF 00327 C 00328 IF (LLFATA) THEN 00329 INIMES=2 00330 ELSE 00331 INIMES=IXNVMS(IRANG(INUMFI)) 00332 ENDIF 00333 C 00334 IF (.NOT.LLFATA.AND.INIMES.NE.2) THEN 00335 IF (LHOOK) CALL DR_HOOK('FACOCH_MT',1,ZHOOK_HANDLE) 00336 RETURN 00337 ENDIF 00338 C 00339 IF (ILPRFU.GE.1) THEN 00340 ILPREF=MIN (ILPRFU,LEN (CLPREF)) 00341 CLPREF(1:ILPREF)=CDPREF(1:ILPREF) 00342 ELSE 00343 ILPREF=8 00344 CLPREF(1:ILPREF)=FA%CHAINC(:ILPREF) 00345 ENDIF 00346 C 00347 IF (ILSUFU.GE.1) THEN 00348 ILSUFF=MIN (ILSUFU,LEN (CLSUFF)) 00349 CLSUFF(1:ILSUFF)=CDSUFF(1:ILSUFF) 00350 ELSE 00351 ILSUFF=8 00352 CLSUFF(1:ILSUFF)=FA%CHAINC(:ILSUFF) 00353 ENDIF 00354 C 00355 IF (.NOT.LLNOMU) THEN 00356 ILNOMU=MIN (ILPREF,FA%NCPCAD) 00357 CLNOMA(1:ILNOMU)=CLPREF(1:ILPREF) 00358 ENDIF 00359 C 00360 WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUME1=' 00361 ',I3, S '', KNUME2='',I3,'', CDPREF='''''',A,'''''', KNIVAU=' 00362 ',I6, S '', CDSUFF='''''',A,'''''''')') KREP,KNUME1,KNUME2, 00363 S CLPREF(1:ILPREF),KNIVAU,CLSUFF(1:ILSUFF) 00364 C 00365 IF (IREP.EQ.-112) THEN 00366 INUMRO=1000*KNUME1+KNUME2 00367 ELSE 00368 INUMRO=INUMER(INUMFI) 00369 ENDIF 00370 C 00371 CALL FAIPAR_MT (FA, INUMRO,INIMES,IREP,LLFATA,CLMESS, 00372 S CLNSPR, CLNOMA(1:ILNOMU),LLRLFI) 00373 C 00374 IF (LHOOK) CALL DR_HOOK('FACOCH_MT',1,ZHOOK_HANDLE) 00375 END 00376
1.8.0
