fairno.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE fairno_fort                           &
&                     (fa,  krep, knumer, cdsttu )
USE fa_mod, ONLY : fa_com, free_fichier, jpniil
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!       Sous-programme de FERMETURE d'une unite logique "Fichier ARPEGE"
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                KNUMER (Entree) ==> Numero de l'unite logique;
!                CDSTTU (Entree) ==> "STATUS" eventuel pour "CLOSE".
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KREP, KNUMER
!
INTEGER (KIND=JPLIKB) IREP, IRANG, J, IPOSNU
INTEGER (KIND=JPLIKB) IRANGC, INIMES, ILNOMC
!
CHARACTER(LEN=*) CDSTTU
CHARACTER(LEN=7) CLSTTU
!
LOGICAL LLSTTU, LLVERF, LLRLFI
!
CHARACTER(LEN=FA%JPXNOM) CLACTI 
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!**
!     1.  -  CONTROLES DES PARAMETRES D'APPEL, PUIS INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FAIRNO_MT',0,zhook_handle)
clacti=''
irep=0
llverf=.false.
llrlfi=.false.
CALL fanumu_fort                 &
&               (fa, knumer,irang)
!
!         Verrouillage global eventuel.
!
IF (fa%LFAMUL) CALL lfiver_fort                        &
&                              (fa%LFI, fa%VRGLAS,'ON')
!
IF (irang.EQ.0) THEN
  irep=-51
  GOTO 1001
ELSEIF (int(len(cdsttu), jplikb).LE.0) THEN
  irep=-65
  GOTO 1001
ELSE
  llsttu=cdsttu.EQ.'KEEP'.OR.cdsttu.EQ.'DELETE'
!
  IF (llsttu) THEN
    clsttu=cdsttu(1:min(int(len(cdsttu), jplikb),  &
&                         int(len(clsttu), jplikb)))
  ELSE
    clsttu='DEFAUT'
  ENDIF
!
ENDIF
!
IF (fa%LFAMUL) CALL lfiver_fort                               &
&                              (fa%LFI, fa%FICHIER(irang)%VRFICH,'ON')
llverf=fa%LFAMUL
!
IF (fa%FICHIER(irang)%LCREAF.AND..NOT.llsttu) THEN
!
!         On force le relachement d'un fichier "parasite".
!
  llsttu=.true.
  clsttu='DELETE'
ENDIF
!**
!     2.  -  FERMETURE DU FICHIER, AU SENS DU LOGICIEL LFI.
!-----------------------------------------------------------------------
!
!**
!     3.  -  "NETTOYAGE" DES TABLES AYANT PERMIS DE GERER LE FICHIER.
!            ( au moins celles ayant un caractere "global" )
!-----------------------------------------------------------------------
!
fa%FICHIER(irang)%NULOGI=jpniil
!
DO j=1,fa%NFIOUV
!
IF (fa%NULIND(j).EQ.irang) THEN
  iposnu=j
  GOTO 302
ENDIF
!
ENDDO
!
irep=-66
GOTO 1001
!
302 CONTINUE
!
fa%NFIOUV=fa%NFIOUV-1
!
DO j=iposnu,fa%NFIOUV
fa%NULIND(j)=fa%NULIND(j+1)
ENDDO
!
IF (fa%LFAMUL) THEN
  CALL lfiver_fort                                &
&                 (fa%LFI, fa%FICHIER(irang)%VRFICH,'OFF')
  CALL lfiver_fort                                &
&                 (fa%LFI, fa%FICHIER(irang)%VRFICH,'REL')
ENDIF
!
llverf=.false.
irangc=fa%FICHIER(irang)%NUCADR
fa%CADRE(irangc)%NULCAD=fa%CADRE(irangc)%NULCAD-1
!
!        Si le cadre auquel etait rattache le fichier n'a plus d'autre
!     fichier rattache, et qu'on ne devait pas conserver ce cadre,
!     on le supprime.
!
IF (fa%CADRE(irangc)%NULCAD.LE.0.AND. &
&   (fa%CADRE(irangc)%NGARDE.EQ.0.OR.  &
&   (fa%CADRE(irangc)%NGARDE.EQ.1.AND. &
&     .NOT.fa%LIGARD)))                &
&      CALL factui_fort                &
&                     (fa, irep,irangc)
CALL free_fichier (fa%FICHIER(irang))
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE SOUS-PROGRAMME "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
krep=irep
llfata=llmoer(irep,irang)
!
!        Deverrouillage(s) eventuel(s).
!
IF (llverf) CALL lfiver_fort                                &
&                           (fa%LFI, fa%FICHIER(irang)%VRFICH,'OFF')
IF (fa%LFAMUL) CALL lfiver_fort                         &
&                              (fa%LFI, fa%VRGLAS,'OFF')
!
IF (llfata) THEN
  inimes=2
ELSE
  inimes=ixnvms(irang)
ENDIF
!
IF (inimes.EQ.0)  THEN 
  IF (lhook) CALL dr_hook('FAIRNO_MT',1,zhook_handle)
  RETURN
ENDIF
!
clnspr='FAIRME'
!
IF (irep.EQ.-65) THEN
  ilnomc=8
  clacti(1:ilnomc)=fa%CHAINC(:ilnomc)
 ELSE
  ilnomc=min( int(len(clacti), jplikb),  &
&               int(len(cdsttu), jplikb) )
  clacti(1:ilnomc)=cdsttu(1:ilnomc)
ENDIF
!
IF (inimes.EQ.2) THEN
!
  ilnomc=min(ilnomc,fa%NCPCAD)
  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KNUMER='',I3, &
&         '', CDSTTU='''''',A,'''''''')') krep,knumer,     &
&       clacti(1:ilnomc)
  CALL faipar_fort                                     &
&                 (fa, knumer,inimes,irep,llfata,clmess, &
&               clnspr,clacti(1:ilnomc),llrlfi)
!
ENDIF
!
IF (lhook) CALL dr_hook('FAIRNO_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"
#include "facom2.ixnvms.h"

END SUBROUTINE fairno_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE fairno64              &
&           (krep, knumer, cdsttu)
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   
CHARACTER (LEN=*)      CDSTTU                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fairno_fort                     &
&           (fa, krep, knumer, cdsttu)

END SUBROUTINE fairno64

SUBROUTINE fairno                &
&           (krep, knumer, cdsttu)
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   
CHARACTER (LEN=*)      CDSTTU                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fairno_mt                       &
&           (fa, krep, knumer, cdsttu)

END SUBROUTINE fairno

SUBROUTINE fairno_mt                 &
&           (fa, krep, knumer, cdsttu)
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   
CHARACTER (LEN=*)      CDSTTU                                 ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  INUMER                                 ! IN   
! Convert arguments

inumer     = int(    knumer, jplikb)

CALL fairno_fort                     &
&           (fa, irep, inumer, cdsttu)

krep       = int(      irep, jplikm)

END SUBROUTINE fairno_mt



!INTF KREP            OUT 
!INTF KNUMER        IN    
!INTF CDSTTU        IN