fanuca.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE fanuca_fort                             &
&                     (fa,  cdnomc, krangc, ldverr )
USE fa_mod, ONLY : fa_com
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        Ce sous-programme calcule le RANG du Cadre de NOM
!     *CDNOMC* dans la table des noms de cadres *FA%CNOMCA*;
!     S'IL N'Y EST PAS TROUVE, LE RESULTAT EST ZERO.
!        Ce sous-programme, appele par plusieurs sous-programmes
!     du Logiciel de Fichiers ARPEGE, se charge lors de son
!     premier appel d'appeler le sous-programme preparatoire FARINE.
!**
!       Arguments : CDNOMC (Entree) ==> Nom de cadre cherche;
!                   KRANGC (Sortie) ==> Rang dans la table des cadres
!                                       du logiciel FA (0 si absent);
!                   LDVERR (Entree) ==> Sert, en mode multi-taches
!                                       seulement, a savoir si l'on doit
!                                       verrouiller globalement ou pas.
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KRANGC
!
INTEGER (KIND=JPLIKB) J, IRESUL
!
CHARACTER CDNOMC*(*)
!
LOGICAL LDVERR, LLVERG
!
!

!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FANUCA_MT',0,zhook_handle)
IF (fa%FANUCA_LLPREA) THEN
  CALL farine_fort              &
&                 (fa, 2_jplikb )
  fa%FANUCA_LLPREA=.false.
ENDIF
!
!          VERROUILLAGE GLOBAL (A CAUSE DE L'UTILISATION DE FA%NFIOUV )
!
llverg=fa%LFAMUL.AND.ldverr
IF (llverg) CALL lfiver_fort                        &
&                           (fa%LFI, fa%VRGLAS,'ON')
!
DO j=1,fa%NCADEF
!
IF (cdnomc.EQ.fa%CADRE(fa%NCAIND(j))%CNOMCA) THEN
  iresul=fa%NCAIND(j)
  GOTO 20
ENDIF
!
ENDDO
!
iresul=0
!
20 CONTINUE
!
!          DEVERROUILLAGE GLOBAL
!
IF (llverg) CALL lfiver_fort                         &
&                           (fa%LFI, fa%VRGLAS,'OFF')
krangc=iresul
!
IF (lhook) CALL dr_hook('FANUCA_MT',1,zhook_handle)
END SUBROUTINE fanuca_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE fanuca64                &
&           (cdnomc, krangc, ldverr)
USE fa_mod, ONLY : fa => fa_com_default, &
&                   fa_com_default_init,  &
&                   new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
CHARACTER (LEN=*)      CDNOMC                                 ! IN   
INTEGER (KIND=JPLIKB)  KRANGC                                 !   OUT
LOGICAL                LDVERR                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fanuca_fort                       &
&           (fa, cdnomc, krangc, ldverr)

END SUBROUTINE fanuca64

SUBROUTINE fanuca                  &
&           (cdnomc, krangc, ldverr)
USE fa_mod, ONLY : fa => fa_com_default, &
&                   fa_com_default_init,  &
&                   new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
CHARACTER (LEN=*)      CDNOMC                                 ! IN   
INTEGER (KIND=JPLIKM)  KRANGC                                 !   OUT
LOGICAL                LDVERR                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fanuca_mt                         &
&           (fa, cdnomc, krangc, ldverr)

END SUBROUTINE fanuca

SUBROUTINE fanuca_mt                   &
&           (fa, cdnomc, krangc, ldverr)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
! Arguments
type(fa_com)          fa                                     ! INOUT
CHARACTER (LEN=*)      CDNOMC                                 ! IN   
INTEGER (KIND=JPLIKM)  KRANGC                                 !   OUT
LOGICAL                LDVERR                                 ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IRANGC                                 !   OUT
! Convert arguments


CALL fanuca_fort                       &
&           (fa, cdnomc, irangc, ldverr)

krangc     = int(    irangc, jplikm)

END SUBROUTINE fanuca_mt

!INTF CDNOMC        IN    
!INTF KRANGC          OUT 
!INTF LDVERR        IN