SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/FA/mt/fanfar

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FANFAR_MT (FA,  KREP, KRANG, CDPREF, KNIVAU, CDSUFF, 
00003      S                      CDNOMA, KB1PAR, KLPRFU, KLSUFU, KLNOMU )
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     fabrication d'un nom article devant contenir un champ horizontal.
00010 C              (Nom a Fabriquer pour un ARticle)
00011 C**
00012 C    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
00013 C                KRANG  (Entree) ==> Rang de l'unite logique;
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                CDNOMA (Sortie) ==> Nom d'article;
00018 C    ( Tableau ) KB1PAR (Sortie) ==> 3 elements du "Bloc 1" des
00019 C                                    interfaces GRIB concernes par la
00020 C                                    coordonnee et le niveau verticaux;
00021 C                KLPRFU (Sortie) ==> Longueur utile du prefixe;
00022 C                KLSUFU (Sortie) ==> Longueur utile du suffixe;
00023 C                KLNOMU (Sortie) ==> Longueur utile du nom d'article.
00024 C*
00025 C       En mode multi-taches, il doit y avoir verrouillage du fichier
00026 C     concerne avant l'appel au sous-programme.
00027 C
00028 #include "precision.h"
00029 C
00030 C
00031       TYPE(FA_COM) :: FA
00032       INTEGER KREP, KRANG, KNIVAU, KLPRFU, KLSUFU, KLNOMU
00033       INTEGER KB1PAR (3)
00034 C
00035       CHARACTER CDPREF*(*), CDSUFF*(*), CDNOMA*(*), CLAUXI*(FA%JPXNOM)
00036 C
00037       INTEGER ILPREF, ILSUFF, ILCDNO, ILPRFU, ILSUFU, J, INCHIF, INIMES
00038       INTEGER INUMER, ILACTI, ILNOMA, ILAUXI, ITYNIV, INIVAU
00039 C
00040 #include "facom2.h"
00041 #include "facom_mt.h"
00042 C**
00043 C     1.  -  CONTROLES DES PARAMETRES D'APPEL, INITIALISATIONS.
00044 C-----------------------------------------------------------------------
00045 C
00046       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00047       IF (LHOOK) CALL DR_HOOK('FANFAR_MT',0,ZHOOK_HANDLE)
00048       ILPREF=LEN (CDPREF)
00049       ILSUFF=LEN (CDSUFF)
00050       ILCDNO=LEN (CDNOMA)
00051       ILPRFU=MAX (0,ILPREF)
00052       ILSUFU=MAX (0,ILSUFF)
00053       KLNOMU=MAX (0,ILCDNO)
00054 C
00055       IF (KRANG.LE.0.OR.KRANG.GT.FA%JPNXFA) THEN
00056         KREP=-66
00057         GOTO 1001
00058       ENDIF
00059 C
00060       IF (ILCDNO.LE.0.OR.ILCDNO.GT.FA%NCPCAD) THEN
00061         KREP=-66
00062         GOTO 1001
00063       ELSEIF (MIN (ILPREF,ILSUFF).LE.0) THEN
00064         KREP=-65
00065         GOTO 1001
00066       ELSEIF (CDPREF.EQ.' '.OR.CDSUFF.EQ.' ') THEN
00067         KREP=-86
00068         GOTO 1001
00069       ENDIF
00070 C
00071 C       Decompte du nombre de caracteres utiles dans prefixe et suffixe.
00072 C
00073       DO 103 J=ILPREF,1,-1
00074 C
00075       IF (CDPREF(J:J).NE.' ') THEN
00076         ILPRFU=J
00077         GOTO 104
00078       ENDIF
00079 C
00080   103 CONTINUE
00081 C
00082       KREP=-66
00083       GOTO 1001
00084 C
00085   104 CONTINUE
00086 C
00087       IF (ILPRFU.GT.FA%JPXPRF) THEN
00088         KREP=-87
00089         GOTO 1001
00090       ENDIF
00091 C
00092       DO 105 J=ILSUFF,1,-1
00093 C
00094       IF (CDSUFF(J:J).NE.' ') THEN
00095         ILSUFU=J
00096         GOTO 106
00097       ENDIF
00098 C
00099   105 CONTINUE
00100 C
00101       KREP=-66
00102       GOTO 1001
00103 C
00104   106 CONTINUE
00105 C**
00106 C     2.  -  DIFFERENTS CAS, SELON LE PREFIXE.
00107 C-----------------------------------------------------------------------
00108 C
00109       DO 201 J=1,FA%JPTNIV
00110 C
00111       IF (CDPREF.EQ.FA%CTNPRF(J)) THEN
00112         ITYNIV=J
00113         GOTO 202
00114       ENDIF
00115 C
00116   201 CONTINUE
00117 C
00118       ITYNIV=0
00119 C
00120   202 CONTINUE
00121 C
00122       INCHIF=FA%NIVDSC(0,ITYNIV)
00123 C
00124       IF (INCHIF.EQ.0) THEN
00125 C
00126         INIVAU=0
00127 C
00128       ELSEIF (KNIVAU.LT.FA%NIVDSC(1,ITYNIV).OR.
00129      S        KNIVAU.GT.FA%NIVDSC(2,ITYNIV)) THEN
00130 C
00131         KREP=-64
00132         GOTO 1001
00133 C
00134       ELSEIF (CDPREF.EQ.'S'.AND.KNIVAU.GT.
00135      S        FA%NNIVER(FA%NUCADR(KRANG))) THEN
00136 C
00137         KREP=-64
00138         GOTO 1001
00139 C
00140       ELSEIF (CDPREF.EQ.'L'.AND.KNIVAU.GT.
00141      S        FA%NNIVER(FA%NUCADR(KRANG))) THEN
00142 C
00143         KREP=-64
00144         GOTO 1001
00145 C
00146       ELSE
00147 C
00148         INIVAU=KNIVAU
00149 C
00150       ENDIF
00151 C
00152       KB1PAR(1)=FA%NIVDSC(3,ITYNIV)
00153       KB1PAR(2)=FA%NIVDSC(4,ITYNIV)
00154       KB1PAR(3)=INIVAU
00155 C
00156       ILSUFU=MIN (ILCDNO-ILPRFU-INCHIF,ILSUFU)
00157       KLNOMU=ILPRFU+INCHIF+ILSUFU
00158 C
00159       IF (INCHIF.NE.0) THEN
00160         WRITE (UNIT=CLNOMA,FMT='(I8.8)') KNIVAU
00161         CDNOMA=CDPREF(1:ILPRFU)//CLNOMA(9-INCHIF:8)//CDSUFF(1:ILSUFU)
00162       ELSE
00163         CDNOMA=CDPREF(1:ILPRFU)//CDSUFF(1:ILSUFU)
00164       ENDIF
00165 C
00166       IF (CDNOMA.EQ.FA%CPCACH.OR.CDNOMA.EQ.FA%CPCADI.OR.CDNOMA.EQ.
00167      S    FA%CPCAFS.OR.
00168      S    CDNOMA.EQ.FA%CPCARP.OR.CDNOMA.EQ.FA%CPDATE.OR.
00169      S    CDNOMA.EQ.FA%CIDENT(KRANG)) THEN
00170         KREP=-111
00171         GOTO 1001
00172       ENDIF
00173 C
00174       KREP=0
00175 C**
00176 C    10.  -  PHASE TERMINALE : MESSAGERIE EVENTUELLE,
00177 C            VIA LE SOUS-PROGRAMME "FAIPAR" .
00178 C-----------------------------------------------------------------------
00179 C
00180  1001 CONTINUE
00181       KLPRFU=ILPRFU
00182       KLSUFU=ILSUFU
00183       LLFATA=LLMOER (KREP,KRANG)
00184 C
00185       IF (FA%LFAMOP.OR.LLFATA) THEN
00186         INIMES=2
00187         CLNSPR='FANFAR'
00188         INUMER=FA%JPNIIL
00189 C
00190         IF (ILPRFU.GE.1) THEN
00191           ILACTI=MIN (ILPRFU,FA%NCPCAD)
00192           CLACTI(1:ILACTI)=CDPREF(1:ILACTI)
00193         ELSE
00194           ILACTI=8
00195           CLACTI(1:ILACTI)=FA%CHAINC(:ILACTI)
00196         ENDIF
00197 C
00198         IF (ILSUFU.GE.1) THEN
00199           ILNOMA=MIN (ILSUFU,FA%NCPCAD)
00200           CLNOMA(1:ILNOMA)=CDSUFF(1:ILNOMA)
00201         ELSE
00202           ILNOMA=8
00203           CLNOMA(1:ILNOMA)=FA%CHAINC(:ILNOMA)
00204         ENDIF
00205 C
00206         IF (KLNOMU.GE.1) THEN
00207           ILAUXI=MIN (KLNOMU,LEN(CLAUXI))
00208           CLAUXI(1:ILAUXI)=CDNOMA(1:ILAUXI)
00209         ELSE
00210           ILAUXI=8
00211           CLAUXI(1:ILAUXI)=FA%CHAINC(:ILAUXI)
00212         ENDIF
00213 C
00214         WRITE (UNIT=CLMESS,
00215      S         FMT='(''ARGUMENTS='',2(I4,'', ''),'''''''
00216 ',A,     S         '''''','',I6,'', '''''',A,'''''',  '''''',A,'''''''
00217 ',     S         2('','',I4),'','',I6,3('','',I3))')
00218      S     KREP,KRANG,CLACTI(1:ILACTI),KNIVAU,CLNOMA(1:ILNOMA),
00219      S     CLAUXI(1:ILAUXI),KB1PAR,KLPRFU,KLSUFU,KLNOMU
00220         CALL FAIPAR_MT (FA, INUMER,INIMES,KREP,.FALSE.,CLMESS,
00221      S                  CLNSPR, CLACTI(1:ILACTI),.FALSE.)
00222       ENDIF
00223 C
00224       IF (LHOOK) CALL DR_HOOK('FANFAR_MT',1,ZHOOK_HANDLE)
00225       END
00226 
00227 
00228 
00229 
00230 
00231