farflu.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE farflu_fort                                     &
&                     (fa,  kxnivv, kxtron, kxlati, kxlong )
USE fa_mod, ONLY : fa_com, jpniil
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        Sous-programme servant a specifier des Limites Utilisateur
!     en termes de Resolutions horizontale et verticale, valides
!     globalement pour tous les Fichiers et Cadres ARPEGE.
!            ( Resolution Fichiers - Limites Utilisateur )
!**
!        Arguments : KXNIVV ==> Nombre maximum de niveaux verticaux;
!  (tous d'Entree)   KXTRON ==> Troncature maximum;
!                    KXLATI ==> Nombre maximum de latitudes pole a pole;
!                    KXLONG ==> Nombre maxi de longitudes par parallele.
!*
!        S'il y a des cadres deja definis (dynamiquement ou non) avec
!     des valeurs correspondantes plus grandes, cela provoque une erreur
!     globale.
!        Si les valeurs donnees en argument depassent les limites cor-
!     repondantes du logiciel, elles sont ecretees, avec un message.
!        Une messagerie de niveau 1 est emise dans le cas normal ou
!     ci-dessus.
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KXNIVV, KXTRON, KXLATI, KXLONG
!
INTEGER (KIND=JPLIKB) INUMER, INIMES, IREP, IMINIM
INTEGER (KIND=JPLIKB) IXNIVV, IXTRON, IXLATI, J
INTEGER (KIND=JPLIKB) IXLONG, IRANGC
!
LOGICAL LLDEPA, LLVERG
!
!
!
CHARACTER(LEN=FA%JPXNOM) CLACTI 
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!**
!     1.  -  SI PREMIERE UTILISATION, APPEL AU SOUS-PROGRAMME "FARINE".
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FARFLU_MT',0,zhook_handle)
clacti=''
IF (fa%FARFLU_LLPREA) THEN
  CALL farine_fort              &
&                 (fa, 2_jplikb )
  fa%FARFLU_LLPREA=.false.
ENDIF
!**
!     2.  -  CONTROLES.
!-----------------------------------------------------------------------
!
iminim=min(kxnivv,kxtron,kxlati,kxlong)
!
IF (iminim.LE.0) THEN
  llverg=.false.
  lldepa=.false.
  irep=-64
  GOTO 1001
ELSE
  lldepa=kxnivv.GT.fa%JPXNIV.OR.kxtron.GT.fa%JPXTRO.OR. &
&         kxlati.GT.fa%JPXLAT.OR.kxlong.GT.fa%JPXLON
  ixnivv=min(kxnivv,fa%JPXNIV)
  ixtron=min(kxtron,fa%JPXTRO)
  ixlati=min(kxlati,fa%JPXLAT)
  ixlong=min(kxlong,fa%JPXLON)
ENDIF
!
!             Verrouillage global, si necessaire.
!
IF (fa%LFAMUL) CALL lfiver_fort                        &
&                              (fa%LFI, fa%VRGLAS,'ON')
llverg=fa%LFAMUL
!
IF (ixtron.LE.fa%NSTROI) THEN
  irep=-99
  GOTO 1001
ENDIF
!
!        Controles vis-a-vis des cadres deja definis, s'il y en a.
!
DO j=1,fa%NCADEF
irangc=fa%NCAIND(j)
!
IF (fa%CADRE(irangc)%MTRONC.GT.ixtron) THEN
  irep=-104
  GOTO 1001
ELSEIF (fa%CADRE(irangc)%NNIVER.GT.ixnivv) THEN
  irep=-105
  GOTO 1001
ELSEIF (fa%CADRE(irangc)%NLATIT.GT.ixlati) THEN
  irep=-106
  GOTO 1001
ELSEIF (fa%CADRE(irangc)%NXLOPA.GT.ixlong) THEN
  irep=-107
  GOTO 1001
ENDIF
!
ENDDO
!**
!     3.  -  MODIFICATION DES LIMITES USAGER.
!-----------------------------------------------------------------------
!
fa%NXNIVV=ixnivv
fa%NXTRON=ixtron
fa%NXLATI=ixlati
fa%NXLONG=ixlong
irep=0
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE sous-programme "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
!
!          Deverrouillage global eventuel.
!
IF (llverg) CALL lfiver_fort                         &
&                           (fa%LFI, fa%VRGLAS,'OFF')
!
llfata=irep.NE.0.AND.fa%NRFAGA.NE.2
!
IF (llfata) THEN
  inimes=2
ELSEIF (fa%NIMSGA.EQ.0) THEN
  IF (lhook) CALL dr_hook('FARFLU_MT',1,zhook_handle)
  RETURN
ELSE
  inimes=fa%NIMSGA
ENDIF
!
clnspr='FARFLU'
inumer=jpniil
!
IF (inimes.EQ.2) THEN
  WRITE (unit=clmess,fmt='(''KXNIVV='',I4,'', KXTRON='',I4, &
&         '', KXLATI='',I4,'', KXLONG='',I4)')               &
&     kxnivv,kxtron,kxlati,kxlong
  CALL faipar_fort                                     &
&                 (fa, inumer,inimes,irep,llfata,clmess, &
&               clnspr,clacti,.false.)
ENDIF
!
IF (inimes.GE.1) THEN
!
  IF (lldepa) THEN
    WRITE (unit=clmess,fmt=                                       &
&   '(''LIMITES USAGER (***ECRETEES***): FA%NXNIVV='',I4,          &
&   '', FA%NXTRON='',I4,'', FA%NXLATI='',I4,'', FA%NXLONG='',I4)') &
&     fa%NXNIVV,fa%NXTRON,fa%NXLATI,fa%NXLONG
  ELSE
    WRITE (unit=clmess,fmt=                                        &
&    '(''LIMITES USAGER EFFECTIVES: FA%NXNIVV='',I4,                &
&    '', FA%NXTRON='',I4,'', FA%NXLATI='',I4,'', FA%NXLONG='',I4)') &
&     fa%NXNIVV,fa%NXTRON,fa%NXLATI,fa%NXLONG
  ENDIF
!
  CALL faipar_fort                                      &
&                 (fa, inumer,inimes,irep,.false.,clmess, &
&               clnspr,clacti,.false.)
ENDIF
!
IF (lhook) CALL dr_hook('FARFLU_MT',1,zhook_handle)
END SUBROUTINE farflu_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE farflu64                        &
&           (kxnivv, kxtron, kxlati, kxlong)
USE fa_mod, ONLY : fa => fa_com_default, &
&                   fa_com_default_init,  &
&                   new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKB)  KXNIVV                                 ! IN   
INTEGER (KIND=JPLIKB)  KXTRON                                 ! IN   
INTEGER (KIND=JPLIKB)  KXLATI                                 ! IN   
INTEGER (KIND=JPLIKB)  KXLONG                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL farflu_fort                               &
&           (fa, kxnivv, kxtron, kxlati, kxlong)

END SUBROUTINE farflu64

SUBROUTINE farflu                          &
&           (kxnivv, kxtron, kxlati, kxlong)
USE fa_mod, ONLY : fa => fa_com_default, &
&                   fa_com_default_init,  &
&                   new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKM)  KXNIVV                                 ! IN   
INTEGER (KIND=JPLIKM)  KXTRON                                 ! IN   
INTEGER (KIND=JPLIKM)  KXLATI                                 ! IN   
INTEGER (KIND=JPLIKM)  KXLONG                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL farflu_mt                                 &
&           (fa, kxnivv, kxtron, kxlati, kxlong)

END SUBROUTINE farflu

SUBROUTINE farflu_mt                           &
&           (fa, kxnivv, kxtron, kxlati, kxlong)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
! Arguments
type(fa_com)          fa                                     ! INOUT
INTEGER (KIND=JPLIKM)  KXNIVV                                 ! IN   
INTEGER (KIND=JPLIKM)  KXTRON                                 ! IN   
INTEGER (KIND=JPLIKM)  KXLATI                                 ! IN   
INTEGER (KIND=JPLIKM)  KXLONG                                 ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IXNIVV                                 ! IN   
INTEGER (KIND=JPLIKB)  IXTRON                                 ! IN   
INTEGER (KIND=JPLIKB)  IXLATI                                 ! IN   
INTEGER (KIND=JPLIKB)  IXLONG                                 ! IN   
! Convert arguments

ixnivv     = int(    kxnivv, jplikb)
ixtron     = int(    kxtron, jplikb)
ixlati     = int(    kxlati, jplikb)
ixlong     = int(    kxlong, jplikb)

CALL farflu_fort                               &
&           (fa, ixnivv, ixtron, ixlati, ixlong)


END SUBROUTINE farflu_mt

!INTF KXNIVV        IN    
!INTF KXTRON        IN    
!INTF KXLATI        IN    
!INTF KXLONG        IN