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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FAIFLA_MT (FA, KRANG)
00003       USE FA_MOD, ONLY : FA_COM
00004       USE PARKIND1, ONLY : JPRB
00005       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00006 C****
00007 C        Ce sous-programme est charge des Initialisations des
00008 C     tableaux FLAp1d., utilises pour aplatir le spectre des champs
00009 C     d'un fichier avant le compactage (coefficients spectraux seulement).
00010 C**
00011 C
00012 C
00013 C**
00014 C     ARGUMENTS :    KRANG  (Entree) ==> Rang de l'unite logique
00015 C
00016 C
00017 #include "precision.h"
00018 C
00019 C
00020       TYPE(FA_COM) :: FA
00021       INTEGER KRANG
00022 C
00023       INTEGER J, IRANGC, IPUILA, ITRONC
00024 #include "facom_mt.h"
00025 C
00026       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00027       IF (LHOOK) CALL DR_HOOK('FAIFLA_MT',0,ZHOOK_HANDLE)
00028       IF (FA%FAIFLA_LLPREA) THEN
00029 C
00030 C
00031 C
00032 C         C'EST LE PREMIER APPEL au sous-programme,
00033 C         on commence par les allocations des differents tableaux
00034 C
00035         ALLOCATE (FA%FLAP1D (FA%JPXTRO,FA%JPNXFA))
00036         ALLOCATE (FA%FLAP1DA (FA%JPXTRO*FA%JPXTRO,FA%JPNXFA))
00037         FA%FAIFLA_LLPREA=.FALSE.
00038       ENDIF
00039 C
00040       IPUILA = FA%NPUFLA(KRANG)
00041       IRANGC = FA%NUCADR(KRANG)
00042       ITRONC = FA%MTRONC(IRANGC)
00043       IF (IPUILA.GT.0) THEN
00044 C
00045         DO J=1,ITRONC
00046           FA%FLAP1D(J,KRANG)=FA%XLAP1D(J,0)**IPUILA
00047         ENDDO
00048         DO J=1,FA%JPXTRO*FA%JPXTRO
00049           FA%FLAP1DA(J,KRANG)=FA%XLAP1DA(J,0)**IPUILA
00050         ENDDO
00051 C
00052       ELSEIF (IPUILA.LT.0) THEN
00053 C
00054         DO J=1,ITRONC
00055           FA%FLAP1D(J,KRANG)=FA%XLAP1D(J,1)**(-IPUILA)
00056         ENDDO
00057         DO J=1,FA%JPXTRO*FA%JPXTRO
00058           FA%FLAP1DA(J,KRANG)=FA%XLAP1DA(J,1)**(-IPUILA)
00059         ENDDO
00060 C
00061       ENDIF
00062 C
00063       IF (LHOOK) CALL DR_HOOK('FAIFLA_MT',1,ZHOOK_HANDLE)
00064       END
00065