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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FACIES_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 obtenir le contenu d'un Cadre.
00011 C     ( FACIES... par analogie avec FADIES, avec "C" pour Cadre... )
00012 C**
00013 C        Arguments : CDNOMC ==> Nom symbolique du cadre;
00014 C  (tous de Sortie,  KTYPTR ==> Type de transformation horizontale
00015 C   sauf CDNOMC)     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 #include "precision.h"
00041 C
00042 C
00043       TYPE(FA_COM) :: FA
00044       INTEGER KTYPTR, KTRONC, KNLATI, KNXLON, KNIVER
00045 C
00046       INTEGER KNLOPA (FA%JPXPAH), KNOZPA (FA%JPXIND)
00047 C
00048       REAL (KIND=JPDBLR) PSLAPO, PCLOPO, PSLOPO, PCODIL, PREFER
00049       REAL (KIND=JPDBLR) PSINLA (FA%JPXGEO), PAHYBR (0:FA%JPXNIV)
00050       REAL (KIND=JPDBLR) PBHYBR (0:FA%JPXNIV)
00051 C
00052       CHARACTER CDNOMC*(*)
00053 C
00054       LOGICAL LDGARD
00055 C
00056       INTEGER IPHASE, IREP, IRANGC, ILNOMC, INIMES, INUMER, ILCDNO, J
00057       INTEGER INPAHE, ISULEI, INPIND, INPGEO
00058 C
00059       LOGICAL LLVERG, LLMLAM
00060 #include "facom_mt.h"
00061 C
00062 C
00063 C**
00064 C     0.  -  SI PREMIERE UTILISATION, APPEL AU SOUS-PROGRAMME "FARINE".
00065 C-----------------------------------------------------------------------
00066 C
00067       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00068       IF (LHOOK) CALL DR_HOOK('FACIES_MT',0,ZHOOK_HANDLE)
00069       IF (FA%FACIES_LLPREA) THEN
00070         CALL FARINE_MT (FA, 2)
00071         FA%FACIES_LLPREA=.FALSE.
00072       ENDIF
00073 C**
00074 C     1.  -  CONTROLE DE L'ARGUMENT "CDNOMC".
00075 C-----------------------------------------------------------------------
00076 C
00077       LLVERG=.FALSE.
00078       ILCDNO=LEN (CDNOMC)
00079       ILNOMC=1
00080 C
00081       IF (ILCDNO.LE.0) THEN
00082         IREP=-65
00083         GOTO 1001
00084       ELSEIF (CDNOMC.EQ.' ') THEN
00085         IREP=-68
00086         GOTO 1001
00087       ENDIF
00088 C
00089       DO 101 J=ILCDNO,1,-1
00090 C
00091       IF (CDNOMC(J:J).NE.' ') THEN
00092         ILNOMC=J
00093         GOTO 102
00094       ENDIF
00095 C
00096   101 CONTINUE
00097 C
00098   102 CONTINUE
00099 C
00100       IF (ILNOMC.GT.FA%NCPCAD) THEN
00101         IREP=-65
00102         GOTO 1001
00103       ENDIF
00104 C**
00105 C     2.  -  RECHERCHE DU CADRE DANS LES TABLES.
00106 C-----------------------------------------------------------------------
00107 C
00108 C             Verrouillage global prealable, si necessaire.
00109 C
00110       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'ON')
00111       LLVERG=FA%LFAMUL
00112 C
00113       CALL FANUCA_MT (FA, CDNOMC,IRANGC,.FALSE.)
00114 C
00115       IF (IRANGC.EQ.0) THEN
00116         IREP=-51
00117         GOTO 1001
00118       ENDIF
00119 C**
00120 C     3.  -  TRANSFERT DES TABLES DU LOGICIEL DANS LES ARGUMENTS.
00121 C-----------------------------------------------------------------------
00122 C
00123       LLMLAM=FA%LIMLAM(IRANGC)
00124 C
00125       KTYPTR=FA%NTYPTR(IRANGC)
00126       KTRONC=FA%MTRONC(IRANGC)
00127       KNIVER=FA%NNIVER(IRANGC)
00128       KNLATI=FA%NLATIT(IRANGC)
00129 C
00130       IF (.NOT.LLMLAM) THEN
00131          INPAHE=(1+KNLATI)/2
00132       ELSE
00133          ISULEI=FA%NOZPAR(1,IRANGC)
00134          INPAHE=8
00135          INPIND=2*ISULEI+4
00136          INPGEO=18
00137       ENDIF
00138 C
00139       KNXLON=FA%NXLOPA(IRANGC)
00140       PSLAPO=FA%SSLAPO(IRANGC)
00141       PCLOPO=FA%SCLOPO(IRANGC)
00142       PSLOPO=FA%SSLOPO(IRANGC)
00143       PCODIL=FA%SCODIL(IRANGC)
00144       PREFER=FA%SPREFE(IRANGC)
00145       LDGARD=FA%NGARDE(IRANGC).EQ.2.OR.
00146      S       (FA%NGARDE(IRANGC).EQ.1.AND.FA%LIGARD)
00147 C
00148       IF (.NOT.LLMLAM) THEN
00149 C
00150          DO 301 J=1,INPAHE
00151          KNLOPA(J)=FA%NLOPAR(J,IRANGC)
00152          KNOZPA(J)=FA%NOZPAR(J,IRANGC)
00153          PSINLA(J)=FA%SINLAT(J,IRANGC)
00154   301    CONTINUE
00155 C
00156       ELSE
00157 C
00158          DO 311 J=1,INPAHE
00159             KNLOPA(J)=FA%NLOPAR(J,IRANGC)
00160   311    CONTINUE
00161          DO 313 J=1,INPIND
00162             KNOZPA(J)=FA%NOZPAR(J,IRANGC)
00163   313    CONTINUE
00164          DO 315 J=1,INPGEO
00165             PSINLA(J)=FA%SINLAT(J,IRANGC)
00166   315    CONTINUE
00167 C
00168       ENDIF
00169 C
00170       DO 302 J=0,KNIVER
00171       PAHYBR(J)=FA%SFOHYB(1,J,IRANGC)
00172       PBHYBR(J)=FA%SFOHYB(2,J,IRANGC)
00173   302 CONTINUE
00174 C
00175       IREP=0
00176 C**
00177 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00178 C            VIA LE sous-programme "FAIPAR" .
00179 C-----------------------------------------------------------------------
00180 C
00181  1001 CONTINUE
00182 C
00183 C          Deverrouillage global eventuel.
00184 C
00185       IF (LLVERG) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'OFF')
00186 C
00187       LLFATA=IREP.NE.0.AND.FA%NRFAGA.NE.2
00188 C
00189       IF (LLFATA.OR.FA%NIMSGA.EQ.2) THEN
00190         INIMES=2
00191       ELSE
00192         IF (LHOOK) CALL DR_HOOK('FACIES_MT',1,ZHOOK_HANDLE)
00193         RETURN
00194       ENDIF
00195 C
00196       CLNSPR='FACIES'
00197 C
00198       IF (IREP.EQ.-65.AND.ILCDNO.LE.0) THEN
00199         ILNOMC=8
00200         CLACTI(1:ILNOMC)=FA%CHAINC(:ILNOMC)
00201       ELSE
00202         ILNOMC=MIN (LEN (CLACTI),ILNOMC)
00203         CLACTI(1:ILNOMC)=CDNOMC(1:ILNOMC)
00204       ENDIF
00205 C
00206       ILNOMC=MIN (ILNOMC,FA%NCPCAD)
00207       WRITE (UNIT=CLMESS,
00208      S       FMT='(''ARGUMENTS SIMPLES= '''''',A,'''''','
00209 ',     S   I2,4('','',F7.4),3('','',I6),'','',I5,'','',F11.4,'', '',L1)')
00210      S     CLACTI(1:ILNOMC),KTYPTR,PSLAPO,PCLOPO,PSLOPO,PCODIL,
00211      S     KTRONC,KNLATI,KNXLON,KNIVER,PREFER,LDGARD
00212       INUMER=FA%JPNIIL
00213       CALL FAIPAR_MT (FA, INUMER,INIMES,IREP,LLFATA,CLMESS,
00214      S                CLNSPR,CLACTI(1:ILNOMC),.FALSE.)
00215 C
00216       IF (LHOOK) CALL DR_HOOK('FACIES_MT',1,ZHOOK_HANDLE)
00217       END
00218