fatcha.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE fatcha_fort                                              &
&                     (fa,  krep, cdnomc,  ldcosp, klcham)
USE fa_mod, ONLY : fa_com, jpniil
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Sous-programme du logiciel de Fichiers ARPEGE:
!      recuperation de la taille d'un champ horizontal
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                CDNOMC (Entree) ==> Nom du cadre
!                LDCOSP (Entree) ==> Vrai si le champ est represente
!                                    par des coefficients spectraux;
!                KLCHAM (Sortie) ==> Taille du champ
!*
!       En mode multi-taches, il doit y avoir verrouillage du fichier
!     concerne avant l'appel au sous-programme.
!
!
TYPE(fa_com)   :: FA
INTEGER (KIND=JPLIKB) KREP, KLCHAM
CHARACTER(LEN=*) CDNOMC
LOGICAL LDCOSP
!
INTEGER (KIND=JPLIKB) ITRONC
INTEGER (KIND=JPLIKB) IRANGC, INIMES, INUMER
!
LOGICAL LLMLAM
!
CHARACTER(LEN=FA%JPXNOM) CLACTI 
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!**
!     1.  -  CONTROLES ET INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FATCHA_MT',0,zhook_handle)

krep=0

CALL fanuca_fort (fa, cdnomc, irangc, .false.)

IF (irangc.EQ.0) THEN
  krep=-51
  GOTO 1001
ENDIF

clacti=''

llmlam=fa%CADRE(irangc)%LIMLAM
itronc=fa%CADRE(irangc)%MTRONC
!
IF (ldcosp) THEN
  IF (llmlam) THEN
    klcham=fa%CADRE(irangc)%NSFLAM
  ELSE
    klcham=(1+itronc)*(2+itronc)
  ENDIF
ELSE
  klcham=fa%CADRE(irangc)%NVAPDG
ENDIF

1001 CONTINUE

llfata = .true.

IF (fa%LFAMOP.OR.llfata) THEN
  inimes=2
  clnspr='FATCHA'
  inumer=jpniil
!
  WRITE (unit=clmess,fmt='(''KREP='',I5,                  &
&        '', LDCOSP= '',L1, '', KLCHAM='',I6)')           &
&        krep, ldcosp, klcham
  CALL faipar_fort                                        &
&                 (fa, inumer,inimes,krep,.false.,clmess, &
&                  clnspr,clacti,.false.)
ENDIF
!
IF (lhook) CALL dr_hook('FATCHA_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"

END SUBROUTINE

SUBROUTINE fatchat64 (KREP, CDNOMC, LDCOSP, KLCHAM)
USE fa_mod, ONLY : fa => fa_com_default, &
&                  fa_com_default_init,  &
&                  new_fa_default
USE lfi_precision
IMPLICIT NONE
INTEGER (KIND=JPLIKB) KREP, KLCHAM
CHARACTER(LEN=*) CDNOMC
LOGICAL LDCOSP

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fatcha_fort (fa,  krep, cdnomc,  ldcosp, klcham)

END SUBROUTINE

SUBROUTINE fatcha (KREP, CDNOMC, LDCOSP, KLCHAM)
USE fa_mod, ONLY : fa => fa_com_default, &
&                  fa_com_default_init,  &
&                  new_fa_default
USE lfi_precision
IMPLICIT NONE
INTEGER (KIND=JPLIKM) KREP, KLCHAM
CHARACTER(LEN=*) CDNOMC
LOGICAL LDCOSP

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fatcha_mt (fa,  krep, cdnomc,  ldcosp, klcham)

END SUBROUTINE

SUBROUTINE fatcha_mt (FA, KREP, CDNOMC, LDCOSP, KLCHAM)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
type(fa_com)         fa
INTEGER (KIND=JPLIKM) KREP, KLCHAM
CHARACTER(LEN=*)      CDNOMC
LOGICAL               LDCOSP

INTEGER (KIND=JPLIKB) IREP, ILCHAM


CALL fatcha_fort (fa, irep, cdnomc,  ldcosp, ilcham)

krep   = int(  irep, jplikm)
klcham = int(ilcham, jplikm)

END SUBROUTINE


!INTF KREP            OUT                                                              
!INTF CDNOMC        IN                                                                 
!INTF LDCOSP        IN                                                                 
!INTF KLCHAM          OUT