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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FACADE_MT (FA,  CDNOMC, KTYPTR, PSLAPO, PCLOPO, PSLOPO,
00003      S                    PCODIL, KTRONC, KNLATI, KNXLON, KNLOPA,
00004      S                    KNOZPA, PSINLA, KNIVER, PREFER, PAHYBR,
00005      S                    PBHYBR, LDGARD )
00006       USE FA_MOD, ONLY : FA_COM
00007       USE PARKIND1, ONLY : JPRB
00008       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00009 C****
00010 C        Sous-programme servant a DEfinir un CADre, voire a le
00011 C     redefinir.
00012 C**
00013 C        Arguments : CDNOMC ==> Nom symbolique du cadre;
00014 C  (tous d'Entree)   KTYPTR ==> Type de transformation horizontale;
00015 C                    PSLAPO ==> Sinus de la latitude du pole d'interet;
00016 C                    PCLOPO ==> Cosinus " " longitude "   "       "   ;
00017 C                    PSLOPO ==> Sinus   " " longitude "   "       "   ;
00018 C                    PCODIL ==> Coefficient de dilatation;
00019 C                    KTRONC ==> Troncature;
00020 C                    KNLATI ==> Nombre de latitudes (de pole a pole);
00021 C                    KNXLON ==> Nombre maxi de longitudes par parallele;
00022 C         (Tableau)  KNLOPA ==> Nombre de longitudes par parallele;
00023 C                               (du pole nord vers l'equateur seulement)
00024 C         (Tableau)  KNOZPA ==> Nombre d'onde zonal maxi par parallele;
00025 C                               (du pole nord vers l'equateur seulement)
00026 C         (Tableau)  PSINLA ==> Sinus des latitudes de l'hemisphere nord
00027 C                               (du pole nord vers l'equateur seulement)
00028 C                    KNIVER ==> Nombre de niveaux verticaux;
00029 C                    PREFER ==> Pression de reference (facteur multipli-
00030 C                               catif de la premiere fonction de la
00031 C                               coordonnee hybride)
00032 C         (Tableau)  PAHYBR ==> Valeurs de la fonction "A" de la coordo-
00033 C                               nnee hybride AUX LIMITES DE COUCHES;
00034 C         (Tableau)  PBHYBR ==> Valeurs de la fonction "B" de la coordo-
00035 C                               nnee hybride AUX LIMITES DE COUCHES;
00036 C                    LDGARD ==> Vrai si le cadre doit etre conserve meme
00037 C                               apres la fermeture du dernier fichier
00038 C                               qui s'y rattache.
00039 C*
00040 C        La "redefinition" d'un cadre est possible a l'une de ces
00041 C     conditions:
00042 C
00043 C     - le cadre a ete defini, mais n'a aucun fichier qui s'y rattache;
00044 C     - le cadre defini a au moins un fichier qui s'y rattache, et les
00045 C       nouveaux parametres de definition sont identiques a ceux deja
00046 C       definis.
00047 C
00048 C        Toute "redefinition" de cadre donne lieu a une messagerie
00049 C     de niveau 1, donc non masquee par defaut.
00050 C
00051 #include "precision.h"
00052 C
00053 C
00054       TYPE(FA_COM) :: FA
00055       INTEGER KTYPTR, KTRONC, KNLATI, KNXLON, KNIVER
00056 C
00057       INTEGER KNLOPA ((1+KNLATI)/2), KNOZPA ((1+KNLATI)/2)
00058 C
00059       REAL (KIND=JPDBLR) PSLAPO, PCLOPO, PSLOPO, PCODIL, PREFER
00060 C
00061       REAL (KIND=JPDBLR) PSINLA ((1+KNLATI)/2), PAHYBR (0:KNIVER)
00062       REAL (KIND=JPDBLR) PBHYBR (0:KNIVER)
00063 C
00064       CHARACTER CDNOMC*(*)
00065 C
00066       LOGICAL LDGARD
00067 C
00068       INTEGER IPHASE, IGARDE, IREP, IRANGC, ILNOMC, INIMES, INUMER
00069 C
00070       LOGICAL LLREDF, LLMODC
00071 C
00072 C
00073 C
00074 #include "facom2.h"
00075 #include "facom_mt.h"
00076 C**
00077 C     1.  -  SI PREMIERE UTILISATION, APPEL AU SOUS-PROGRAMME "FARINE".
00078 C-----------------------------------------------------------------------
00079 C
00080       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00081       IF (LHOOK) CALL DR_HOOK('FACADE_MT',0,ZHOOK_HANDLE)
00082       IF (FA%FACADE_LLPREA) THEN
00083         CALL FARINE_MT (FA, 2)
00084         FA%FACADE_LLPREA=.FALSE.
00085       ENDIF
00086 C**
00087 C     2.  -  LE TRAVAIL EST SOUS-TRAITE AU SOUS-PROGRAMME "FACADI".
00088 C-----------------------------------------------------------------------
00089 C
00090       IPHASE=0
00091 C
00092       IF (LDGARD) THEN
00093         IGARDE=2
00094       ELSE
00095         IGARDE=0
00096       ENDIF
00097 C
00098 C             Verrouillage global prealable, si necessaire.
00099 C
00100       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'ON')
00101       CALL FACADI_MT (FA, IREP,CDNOMC,KTYPTR,PSLAPO,PCLOPO,
00102      S             PSLOPO,PCODIL,
00103      S             KTRONC,KNLATI,KNXLON,KNLOPA,KNOZPA,PSINLA,KNIVER,
00104      S             PREFER,PAHYBR,PBHYBR,LLMODC,LLREDF,IPHASE,IRANGC,
00105      S             ILNOMC,IGARDE)
00106       ILNOMC=MIN (ILNOMC,FA%NCPCAD)
00107 C**
00108 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00109 C            VIA LE sous-programme "FAIPAR" .
00110 C-----------------------------------------------------------------------
00111 C
00112  1001 CONTINUE
00113 C
00114 C          Deverrouillage global eventuel.
00115 C
00116       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'OFF')
00117 C
00118       LLFATA=LLMOER(IREP,0)
00119 C
00120       IF (LLFATA) THEN
00121         INIMES=2
00122       ELSEIF (FA%NIMSGA.EQ.0) THEN
00123         INIMES=0
00124       ELSEIF (LLMODC) THEN
00125         INIMES=1
00126         WRITE (UNIT=CLMESS,FMT=
00127      S  '(''PARAMETRES NUMERIQUES DU CADRE '''''',A,'''''' MODIFIES '
00128 ',     S    '' - CONSERVATION A LA FERMETURE DU DERNIER FICHIER= '',L1)')
00129      S   CDNOMC(1:ILNOMC),LDGARD
00130       ELSEIF (LLREDF) THEN
00131         INIMES=1
00132         WRITE (UNIT=CLMESS,FMT='(''CADRE '''''
00133 ',A,     S '''''' REDEFINI - MEMES PARAMETRES NUMERIQUES - '
00134 ',     S '' CONSERVATION A LA FERMETURE DU DERNIER FICHIER= '',L1)')
00135      S   CDNOMC(1:ILNOMC),LDGARD
00136       ELSEIF (FA%NIMSGA.EQ.2) THEN
00137         INIMES=2
00138       ELSE
00139         INIMES=0
00140       ENDIF
00141 C
00142       IF (INIMES.EQ.0)  THEN 
00143         IF (LHOOK) CALL DR_HOOK('FACADE_MT',1,ZHOOK_HANDLE)
00144         RETURN
00145       ENDIF
00146 C
00147       CLNSPR='FACADE'
00148       INUMER=FA%JPNIIL
00149 C
00150       IF (INIMES.EQ.1.AND.FA%NIMSGA.EQ.2) THEN
00151 C
00152 C        Cas ou il faut en fait 2 messages.
00153 C
00154         CALL FAIPAR_MT (FA, INUMER,INIMES,IREP,.FALSE.,CLMESS,
00155      S                  CLNSPR,CLACTI,.FALSE.)
00156         INIMES=2
00157       ENDIF
00158 C
00159       IF (INIMES.EQ.2) THEN
00160 C
00161         IF (IREP.EQ.-65.AND.ILNOMC.EQ.1) THEN
00162           ILNOMC=8
00163           CLACTI(1:ILNOMC)=FA%CHAINC(:ILNOMC)
00164         ELSE
00165           ILNOMC=MIN (LEN (CLACTI),ILNOMC,FA%NCPCAD)
00166           CLACTI(1:ILNOMC)=CDNOMC(1:ILNOMC)
00167         ENDIF
00168 C
00169         WRITE (UNIT=CLMESS,
00170      S         FMT='(''ARGUMENTS SIMPLES= '''''',A,'''''','
00171 '     S  ,I2,4('','',F7.4),3('','',I6),'','',I5,'','',F11.4,'', '',L1)')
00172      S       CLACTI(1:ILNOMC),KTYPTR,PSLAPO,PCLOPO,PSLOPO,PCODIL,
00173      S       KTRONC,KNLATI,KNXLON,KNIVER,PREFER,LDGARD
00174       ENDIF
00175 C
00176       CALL FAIPAR_MT (FA, INUMER,INIMES,IREP,LLFATA,CLMESS,
00177      S                CLNSPR,CLACTI(1:ILNOMC),.FALSE.)
00178 C
00179       IF (LHOOK) CALL DR_HOOK('FACADE_MT',1,ZHOOK_HANDLE)
00180       END
00181