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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FARCIS_MT (FA,  KREP, KRANG, PCHAMP, KSTRON, KPUILA )
00003       USE FA_MOD, ONLY : FA_COM
00004       USE PARKIND1, ONLY : JPRB
00005       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00006 C****
00007 C        Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
00008 C     elimination de la "puissance de laplacien" d'un champ en coeffi-
00009 C     cients spectraux issu d'un codage GRIB, de maniere a restituer
00010 C     le champ "d'origine" (a la precision du codage pres) .
00011 C     ( Reconstitution des CoeffIcients Spectraux )
00012 C**
00013 C    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
00014 C                KRANG  (Entree) ==> Rang de l'unite logique;
00015 C    ( Tableau ) PCHAMP (Entree ET Sortie) ==> Champ en coef. spectraux;
00016 C                KSTRON (Entree) ==> Sous-troncature non compactee;
00017 C                KPUILA (Entree) ==> Puissance de laplacien utilisee.
00018 C
00019 C      ( Les 2 derniers parametres sont ceux qui ont ete effectivement
00020 C        utilises lors de l'ecriture du champ )
00021 C*
00022 C       En mode multi-taches, il doit y avoir verrouillage du fichier
00023 C     concerne avant l'appel au sous-programme.
00024 C
00025 #include "precision.h"
00026 C
00027 C
00028       TYPE(FA_COM) :: FA
00029       INTEGER KREP, KRANG, KSTRON, KPUILA
00030 C
00031       REAL (KIND=JPDBLR) PCHAMP (FA%JPXCSP)
00032 C
00033       INTEGER IRANGC, ITRONC, INUMER, IDIMNC, ILCHAM, IMTRONC, IPUISX, J
00034       INTEGER INDICE, JN, JM, INDLAP, IMLIM, IOFF, IM, JIND, IPUIS2
00035       INTEGER IRAPOR, IPUISR, INIMES, IDEB, IFIN
00036 C
00037       LOGICAL LLMLAM
00038 C
00039 #include "facom2.h"
00040 #include "facom_mt.h"
00041 C**
00042 C     1.  -  CONTROLES DES PARAMETRES D'APPEL, INITIALISATIONS.
00043 C-----------------------------------------------------------------------
00044 C
00045       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00046       IF (LHOOK) CALL DR_HOOK('FARCIS_MT',0,ZHOOK_HANDLE)
00047       IF (KRANG.LE.0.OR.KRANG.GT.FA%JPNXFA) THEN
00048         KREP=-66
00049         GOTO 1001
00050       ENDIF
00051 C
00052       IF (FA%LIXLAP) THEN
00053         CALL FAIXLA_MT (FA)
00054         FA%LIXLAP=.FALSE.
00055       ENDIF
00056 C
00057       IRANGC=FA%NUCADR(KRANG)
00058       ITRONC=FA%MTRONC(IRANGC)
00059       LLMLAM=FA%LIMLAM(IRANGC)
00060 C
00061       IF (LLMLAM) IMTRONC=FA%NOZPAR(2,IRANGC)
00062       IF (ITRONC.LE.KSTRON) THEN
00063         KREP=-88
00064         GOTO 1001
00065       ELSEIF (LLMLAM.AND.IMTRONC.LE.KSTRON) THEN
00066         KREP=-88
00067         GOTO 1001
00068       ELSEIF (LLMLAM.AND.(IMTRONC.GT.3*ITRONC.
00069      S    OR.ITRONC.GT.3*IMTRONC)) THEN
00070 C Il s'agit d'un garde-fou, modifiable (ne pas oublier FAPULA et FACSIM)
00071         KREP=-114
00072         GOTO 1001
00073       ELSE        
00074         KREP=0
00075       ENDIF
00076 C
00077       IDIMNC=(1+KSTRON)**2
00078       IF (LLMLAM) THEN
00079         ILCHAM=FA%NSFLAM(IRANGC)
00080       ELSE  
00081         ILCHAM=(1+ITRONC)**2
00082       ENDIF  
00083 C**
00084 C     2.  -  RECONSTITUTION DU CHAMP "D'ORIGINE", DEBARRASSE DE LA
00085 C            PUISSANCE DE LAPLACIEN QUI N'AFFECTE QUE LA PARTIE HORS
00086 C            SOUS-TRONCATURE NON COMPACTEE.
00087 C-----------------------------------------------------------------------
00088 C
00089 C        On essaie d'eviter l'exponentiation, en preferant multiplier
00090 C     que diviser.
00091 C
00092       IF (KPUILA.NE.0) THEN
00093 C
00094         IPUISX=IABS (KPUILA)
00095 C
00096         IF (KPUILA.GT.0) THEN
00097           INDICE=1
00098         ELSE
00099           INDICE=0
00100         ENDIF
00101 C
00102         IF (IPUISX.LE.FA%JPUILA) THEN
00103 C
00104           IF (LLMLAM) THEN
00105 !$OMP PARALLEL DO PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,INDLAP)
00106 !$OMP&  IF(FA%LOPENMP)
00107             DO 2010 JN=1,ITRONC
00108             IMLIM=KSTRON-JN
00109             IDEB=MAX(FA%NOZPAR(2*JN+3,IRANGC)+4*(1+IMLIM),
00110      S             FA%NOZPAR(2*JN+3,IRANGC)+4)
00111             IFIN=FA%NOZPAR(2*JN+4,IRANGC)
00112             DO 2010 JIND=IDEB,IFIN
00113             IOFF=JIND-FA%NOZPAR(2*JN+3,IRANGC)
00114             IM=IOFF/4
00115             INDLAP=((JN-1)*FA%JPXTRO)+IM
00116             PCHAMP(JIND)=PCHAMP(JIND)*FA%XLAP2DA(INDLAP,IPUISX,INDICE)
00117  2010       CONTINUE         
00118 !$OMP END PARALLEL DO
00119           ELSE
00120             DO 201 J=IDIMNC+1,ILCHAM
00121             PCHAMP(J)=PCHAMP(J)*FA%XLAP2D(J,IPUISX,INDICE)
00122   201       CONTINUE
00123           ENDIF
00124         ELSEIF (IPUISX.LE.2*FA%JPUILA) THEN
00125           IPUIS2=IPUISX/2
00126 C
00127           IF (IPUISX.EQ.2*IPUIS2) THEN
00128 C
00129             IF (LLMLAM) THEN
00130 !$OMP PARALLEL DO PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,INDLAP)
00131 !$OMP&  IF(FA%LOPENMP)
00132               DO 2020 JN=1,ITRONC
00133               IMLIM=KSTRON-JN
00134               IDEB=MAX(FA%NOZPAR(2*JN+3,IRANGC)+4*(1+IMLIM),
00135      S               FA%NOZPAR(2*JN+3,IRANGC)+4)
00136               IFIN=FA%NOZPAR(2*JN+4,IRANGC)
00137               DO 2020 JIND=IDEB,IFIN
00138               IOFF=JIND-FA%NOZPAR(2*JN+3,IRANGC)
00139               IM=IOFF/4
00140               INDLAP=((JN-1)*FA%JPXTRO)+IM
00141               PCHAMP(JIND)=PCHAMP(JIND)
00142      S          *( FA%XLAP2DA(INDLAP,IPUIS2,INDICE)**2 )
00143  2020         CONTINUE               
00144 !$OMP END PARALLEL DO
00145             ELSE
00146               DO 202 J=IDIMNC+1,ILCHAM
00147               PCHAMP(J)=PCHAMP(J)*( FA%XLAP2D(J,IPUIS2,INDICE)**2 )
00148   202         CONTINUE
00149             ENDIF
00150 C
00151           ELSE
00152 C
00153             IF (LLMLAM) THEN
00154 !$OMP PARALLEL DO PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,INDLAP) 
00155 !$OMP&  IF(FA%LOPENMP)
00156               DO 2030 JN=1,ITRONC
00157               IMLIM=KSTRON-JN
00158               IDEB=MAX(FA%NOZPAR(2*JN+3,IRANGC)+4*(1+IMLIM),
00159      S               FA%NOZPAR(2*JN+3,IRANGC)+4)
00160               IFIN=FA%NOZPAR(2*JN+4,IRANGC)
00161               DO 2030 JIND=IDEB,IFIN
00162               IOFF=JIND-FA%NOZPAR(2*JN+3,IRANGC)
00163               IM=IOFF/4
00164               INDLAP=((JN-1)*FA%JPXTRO)+IM
00165               PCHAMP(JIND)=PCHAMP(JIND)
00166      S          *( FA%XLAP2DA(INDLAP,FA%JPUILA,INDICE)
00167      S            *FA%XLAP2DA(INDLAP,IPUISX-FA%JPUILA,INDICE) )
00168  2030         CONTINUE              
00169 !$OMP END PARALLEL DO
00170             ELSE
00171               DO 203 J=IDIMNC+1,ILCHAM
00172               PCHAMP(J)=PCHAMP(J)*( FA%XLAP2D(J,FA%JPUILA,INDICE)
00173      S                          *FA%XLAP2D(J,IPUISX-FA%JPUILA,INDICE) )
00174   203         CONTINUE
00175             ENDIF
00176 C
00177           ENDIF
00178 C
00179         ELSE
00180           IRAPOR=1+(IPUISX-1)/FA%JPUILA
00181           IPUISR=IPUISX/IRAPOR
00182 C
00183           IF (IPUISX.EQ.IRAPOR*IPUISR) THEN
00184 C
00185             IF (LLMLAM) THEN
00186 !$OMP PARALLEL DO PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,INDLAP)
00187 !$OMP&  IF(FA%LOPENMP)
00188               DO 2040 JN=1,ITRONC
00189               IMLIM=KSTRON-JN
00190               IDEB=MAX(FA%NOZPAR(2*JN+3,IRANGC)+4*(1+IMLIM),
00191      S               FA%NOZPAR(2*JN+3,IRANGC)+4)
00192               IFIN=FA%NOZPAR(2*JN+4,IRANGC)
00193               DO 2040 JIND=IDEB,IFIN
00194               IOFF=JIND-FA%NOZPAR(2*JN+3,IRANGC)
00195               IM=IOFF/4
00196               INDLAP=((JN-1)*FA%JPXTRO)+IM
00197               PCHAMP(JIND)=PCHAMP(JIND)
00198      S           *( FA%XLAP2DA(INDLAP,IPUISR,INDICE)**IRAPOR )
00199  2040         CONTINUE                
00200 !$OMP END PARALLEL DO
00201             ELSE
00202               DO 204 J=IDIMNC+1,ILCHAM
00203               PCHAMP(J)=PCHAMP(J)*( FA%XLAP2D(J,IPUISR,INDICE)**IRAPOR )
00204   204         CONTINUE
00205             ENDIF
00206 C
00207           ELSE
00208 C
00209             IF (LLMLAM) THEN
00210 !$OMP PARALLEL DO PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,INDLAP)
00211 !$OMP&  IF(FA%LOPENMP)
00212               DO 2050 JN=1,ITRONC
00213               IMLIM=KSTRON-JN
00214               IDEB=MAX(FA%NOZPAR(2*JN+3,IRANGC)+4*(1+IMLIM),
00215      S               FA%NOZPAR(2*JN+3,IRANGC)+4)
00216               IFIN=FA%NOZPAR(2*JN+4,IRANGC)
00217               DO 2050 JIND=IDEB,IFIN
00218               IOFF=JIND-FA%NOZPAR(2*JN+3,IRANGC)
00219               IM=IOFF/4
00220               INDLAP=((JN-1)*FA%JPXTRO)+IM
00221               PCHAMP(JIND)=PCHAMP(JIND)
00222      S          *( FA%XLAP2DA(INDLAP,FA%JPUILA,INDICE)**(IRAPOR-1)
00223      S         *FA%XLAP2DA(INDLAP,IPUISX-FA%JPUILA*(IRAPOR-1),INDICE) )
00224  2050         CONTINUE             
00225 !$OMP END PARALLEL DO
00226             ELSE
00227               DO 205 J=IDIMNC+1,ILCHAM
00228               PCHAMP(J)=PCHAMP(J)* 
00229      S                 (FA%XLAP2D(J,FA%JPUILA,INDICE)**(IRAPOR-1)
00230      S                *FA%XLAP2D(J,IPUISX-FA%JPUILA*(IRAPOR-1),INDICE) )
00231   205         CONTINUE
00232             ENDIF
00233 C
00234           ENDIF
00235 C
00236         ENDIF
00237 C
00238       ENDIF
00239 C**
00240 C    10.  -  PHASE TERMINALE : MESSAGERIE EVENTUELLE,
00241 C            VIA LE SOUS-PROGRAMME "FAIPAR" .
00242 C-----------------------------------------------------------------------
00243 C
00244  1001 CONTINUE
00245       LLFATA=LLMOER (KREP,KRANG)
00246 C
00247       IF (FA%LFAMOP.OR.LLFATA) THEN
00248         INIMES=2
00249         CLNSPR='FARCIS'
00250         INUMER=FA%JPNIIL
00251         WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KRANG='
00252 ',I4,     S    '', PCHAMP(1)='',G12.5,'', KSTRON='',I4,'', KPUILA='',I3)')
00253      S     KREP,KRANG,PCHAMP(1),KSTRON,KPUILA
00254         CALL FAIPAR_MT (FA, INUMER,INIMES,KREP,.FALSE.,CLMESS,
00255      S               CLNSPR,CLACTI,.FALSE.)
00256       ENDIF
00257 C
00258       IF (LHOOK) CALL DR_HOOK('FARCIS_MT',1,ZHOOK_HANDLE)
00259       END
00260