faprst.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE faprst_fort                                             &
&                     (fa,  krep, knumer, knumod, khctpi, cdoper, ldprgr)
USE fa_mod, ONLY : fa_com
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Sous-programme permettant de mettre en place les defauts de compression
!     utilises par PROGRID
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                KNUMER (Entree) ==> Numero de l'unite logique;
!                KNUMOD (Entree) ==> Numero du modele
!                KHCTPI (Entree) ==> Voir PROGRID
!                CDOPER (Entree) ==> Voir PROGRID
!                LDPRGR (Entree) ==> Activer ou non
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KREP, KNUMER, KNUMOD, KHCTPI
!
CHARACTER CDOPER
!
LOGICAL LDPRGR
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FAPRST_MT',0,zhook_handle)

krep=0

IF (ldprgr) THEN
  CALL faregu_fort (fa, knumer, 'IDMOD',  knumod,   1_jplikb)
  CALL faregu_fort (fa, knumer, 'FACDEC', 0_jplikb, 1_jplikb)
  SELECT CASE (cdoper)
    CASE ('K')
      CALL faregu_fort (fa, knumer, 'GEXTE',  0_jplikb, 1_jplikb)
      CALL faregu_fort (fa, knumer, 'BOUST',  0_jplikb, 1_jplikb)
      CALL faregu_fort (fa, knumer, 'DIFFE',  0_jplikb, 1_jplikb)
    CASE ('X')
      CALL faregu_fort (fa, knumer, 'GEXTE',  1_jplikb, 1_jplikb)
      CALL faregu_fort (fa, knumer, 'BOUST',  1_jplikb, 1_jplikb)
      CALL faregu_fort (fa, knumer, 'DIFFE', -1_jplikb, 1_jplikb)
    CASE ('L')
      CALL faregu_fort (fa, knumer, 'GEXTE',  1_jplikb, 1_jplikb)
      CALL faregu_fort (fa, knumer, 'BOUST',  1_jplikb, 1_jplikb)
      CALL faregu_fort (fa, knumer, 'DIFFE',  2_jplikb, 1_jplikb)
  END SELECT
ENDIF

IF (lhook) CALL dr_hook('FAPRST_MT',1,zhook_handle)

END SUBROUTINE faprst_fort

! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE faprst64                                        &
&           (krep, knumer, knumod, khctpi, cdoper, ldprgr)
USE fa_mod, ONLY : fa => fa_com_default, &
&                  fa_com_default_init,  &
&                  new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKB)  KREP                                   !   OUT
INTEGER (KIND=JPLIKB)  KNUMER                                 ! IN   
INTEGER (KIND=JPLIKB)  KNUMOD                                 ! IN   
INTEGER (KIND=JPLIKB)  KHCTPI                                 ! IN   
CHARACTER              CDOPER                                 ! IN   
LOGICAL                LDPRGR                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL faprst_fort                                               &
&           (fa, krep, knumer, knumod, khctpi, cdoper, ldprgr)

END SUBROUTINE faprst64

SUBROUTINE faprst                                          &
&           (krep, knumer, knumod, khctpi, cdoper, ldprgr)
USE fa_mod, ONLY : fa => fa_com_default, &
&                  fa_com_default_init,  &
&                  new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
INTEGER (KIND=JPLIKM)  KNUMOD                                 ! IN   
INTEGER (KIND=JPLIKM)  KHCTPI                                 ! IN   
CHARACTER              CDOPER                                 ! IN   
LOGICAL                LDPRGR                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL faprst_mt                                                 &
&           (fa, krep, knumer, knumod, khctpi, cdoper, ldprgr)

END SUBROUTINE faprst

SUBROUTINE faprst_mt                                           &
&           (fa, krep, knumer, knumod, khctpi, cdoper, ldprgr)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
! Arguments
type(fa_com)          fa                                     ! INOUT
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
INTEGER (KIND=JPLIKM)  KNUMOD                                 ! IN   
INTEGER (KIND=JPLIKM)  KHCTPI                                 ! IN   
CHARACTER              CDOPER                                 ! IN   
LOGICAL                LDPRGR                                 ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  INUMER                                 ! IN   
INTEGER (KIND=JPLIKB)  INUMOD                                 ! IN   
INTEGER (KIND=JPLIKB)  IHCTPI                                 ! IN   
! Convert arguments

inumer     = int(    knumer, jplikb)
inumod     = int(    knumod, jplikb)
ihctpi     = int(    khctpi, jplikb)

CALL faprst_fort                                               &
&           (fa, irep, inumer, inumod, ihctpi, cdoper, ldprgr)

krep       = int(      irep, jplikm)

END SUBROUTINE faprst_mt

!INTF KREP            OUT                                                              
!INTF KNUMER        IN                                                                 
!INTF KNUMOD        IN                                                                 
!INTF KHCTPI        IN                                                                 
!INTF CDOPER        IN                                                                 
!INTF LDPRGR        IN