lfifmd.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI

SUBROUTINE lfifmd_fort               &
&                     (lfi, kfacmd )
USE lfimod, ONLY : lficom
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        Ce sous-programme permet de changer le Facteur Multiplicatif
!     par Defaut du logiciel de fichiers indexes LFI.
!        Apres appel reussi a ce sous-programme, toute ouverture d'unite
!     logique LFI pour laquelle il n'y a pas de facteur multiplicatif
!     predefini (via *LFIAFM*) se fera en traitant le fichier avec une
!     longueur PHYSIQUE d'article de LFI%JPLARD*KFACMD mots.
!
!        La valeur implicite de ce Facteur Multiplicatif par Defaut est
!     definie dans *LFIINI* ( en l'occurrence, il s'agit de 1 ) .
!**
!       ARGUMENT  : KFACMD (Entree) ==> Facteur Multiplicatif par Defaut
!
!
TYPE(lficom) :: LFI
INTEGER (KIND=JPLIKB) KFACMD, INIMES, IREP, INUMER
CHARACTER(LEN=LFI%JPLSPX) CLNSPR
CHARACTER(LEN=LFI%JPLMES) CLMESS
CHARACTER(LEN=LFI%JPLFTX) CLACTI
LOGICAL LLFATA

!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('LFIFMD_FORT',0,zhook_handle)
clacti=''
IF (lfi%LFIFMD_LLPREA) THEN
  CALL lfiini_fort                 &
&                 (lfi, 2_jplikb )
  lfi%LFIFMD_LLPREA=.false.
ENDIF
!
IF (kfacmd.LE.0) THEN
  irep=-14
ELSEIF (kfacmd.GT.lfi%JPFACX) THEN
  irep=-28
ELSE
  irep=0
!
!          Modification, sous Verrouillage Global eventuel.
!
  IF (lfi%LMULTI) CALL lfiver_fort                       &
&                                 (lfi, lfi%VERGLA,'ON')
!
  lfi%MFACTU(0)=kfacmd
!
  IF (lfi%LMULTI) CALL lfiver_fort                        &
&                                 (lfi, lfi%VERGLA,'OFF')
ENDIF
!
!        MESSAGERIE EVENTUELLE, AVEC ABORT SI NECESSAIRE .
!
llfata=irep.NE.0.AND.lfi%NERFAG.NE.2
!
IF (llfata) THEN
  inimes=2
ELSEIF (irep.NE.0) THEN
  inimes=0
ELSEIF (lfi%NIMESG.EQ.0) THEN
  IF (lhook) CALL dr_hook('LFIFMD_FORT',1,zhook_handle)
  RETURN
ELSE
  inimes=lfi%NIMESG
ENDIF
!
clnspr='LFIFMD'
inumer=lfi%JPNIL
!
IF (inimes.EQ.2) THEN
!
  IF (lfi%LFRANC) THEN
    WRITE (unit=clmess,                              &
&           fmt='(''KFACMD='',I5,'', CODE INTERNE='', &
&           I4)') kfacmd,irep
  ELSE
    WRITE (unit=clmess,                               &
&           fmt='(''KFACMD='',I5,'', INTERNAL CODE='', &
&           I4)') kfacmd,irep
  ENDIF
!
  CALL lfiems_fort                                 &
&                 (lfi, inumer,inimes,irep,llfata, &
&                  clmess,clnspr,clacti)
ENDIF
!
IF (inimes.GE.1) THEN
!
  IF (lfi%LFRANC) THEN
    WRITE (unit=clmess,fmt=                                        &
&         '(''Reglage du Facteur Multiplicatif par Defaut a'',I3)') &
&         kfacmd
  ELSE
    WRITE (unit=clmess,fmt=                         &
&         '(''Default Multiply Factor set to'',I3)') &
&         kfacmd
  ENDIF
!
ENDIF
!
CALL lfiems_fort                                 &
&               (lfi, inumer,inimes,irep,llfata, &
&                clmess,clnspr,clacti)
!
IF (lhook) CALL dr_hook('LFIFMD_FORT',1,zhook_handle)
END SUBROUTINE lfifmd_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE lfifmd64           &
&           (kfacmd)
USE lfimod, ONLY : lfi => lficom_default, &
&                   lficom_default_init,   &
&                   new_lfi_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKB)  KFACMD                                 ! IN   

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfifmd_fort            &
&           (lfi, kfacmd)

END SUBROUTINE lfifmd64

SUBROUTINE lfifmd             &
&           (kfacmd)
USE lfimod, ONLY : lfi => lficom_default, &
&                   lficom_default_init,   &
&                   new_lfi_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKM)  KFACMD                                 ! IN   

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfifmd_mt             &
&           (lfi, kfacmd)

END SUBROUTINE lfifmd

SUBROUTINE lfifmd_mt             &
&           (lfi, kfacmd)
USE lfimod, ONLY : lficom
USE lfi_precision
IMPLICIT NONE
! Arguments
type(lficom)          lfi                                    ! INOUT
INTEGER (KIND=JPLIKM)  KFACMD                                 ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IFACMD                                 ! IN   
! Convert arguments

ifacmd     = int(    kfacmd, jplikb)

CALL lfifmd_fort            &
&           (lfi, ifacmd)


END SUBROUTINE lfifmd_mt

!INTF KFACMD        IN