fmclos.F90

Go to the documentation of this file.

!     ######spl
      SUBROUTINE fmclos(HFILEM,HSTATU,HFIPRI,KRESP)
      USE parkind1, ONLY : jprb
      USE yomhook , ONLY : lhook, dr_hook
!     #############################################
!
!!****  *FMCLOS* - routine to close a meso-nh file opened with the "FM"-routines
!!
!!    PURPOSE
!!    -------
!
!       The purpose of FMCLOS is to close a mesonh file composed of the DESFM
!     and the LFIFM part. The LFIFM file is closed
!     using the LFI-package for direct access Fortran files. The DESFM file is
!     closed using a classical CLOSE statement.
!
!!**  METHOD
!!    ------
!!
!!      The closure is proceeded in 4 steps:
!!        1. close DESFM
!!        2. close LFIFM by calling LFIFER
!!        3. erase the file from the management arrays (FMFREE)
!!        4. the cpio and storage command is loaded into the pipe
!!           the pipe has the special fortran unit 10
!!
!!    EXTERNAL
!!    --------
!!
!!      FMLOOK,FMFREE,LFIFER,CLOSE,FLUSH
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!      MODULE: MODD_FMDECLAR contains management parameters and
!!              storage arrays to move information around at the
!!              level of all "FM"-routines.
!!              MODD_FMMULTI contains variables for multitasking
!!
!!    REFERENCE
!!    ---------
!!
!!      see the Technical Specifications Report for the Meso-nh project
!!      (in French)
!!
!!    AUTHOR
!!    ------
!!
!!      C. FISCHER      *METEO-FRANCE*
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      original                                                        06/94
!!      modified by C. Fischer                    4/11/94 (write in the pipe)
!!      modified by C. Fischer                5/7/95 (locks for multitasking)
!!      modified by P. Jabouille                  26/06/96 (case NFITYP=2 :
!!                                     file is not sent to the remote machine)
!!      modified by V. Masson               16/09/96 (prints if error occurs)
!!
!----------------------------------------------------------------------------
!
!*      0.    DECLARATIONS
!             ------------
!
USE modd_fmdeclar
USE modd_fmmulti

IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
CHARACTER(LEN=*),     INTENT(IN) ::HFILEM  ! file name
CHARACTER(LEN=*),     INTENT(IN) ::HSTATU  ! status for the closed file

CHARACTER(LEN=*),     INTENT(IN) ::HFIPRI  ! file for prints in FM

INTEGER,              INTENT(OUT)::KRESP   ! return-code if problems araised

!
!*      0.2   Declarations of local variables
!
INTEGER::IRESP,IROWF,IPOSNU,J,INUMBR,IFMFNL,ILUPRI,IERR
CHARACTER(LEN=7)::YSTATU
CHARACTER(LEN=JPFINL)::YFNDES,YFNLFI
CHARACTER(LEN=LEN(HFILEM))::YINTFN
CHARACTER(LEN=10)::YTRANS,YCPIO
CHARACTER(LEN=100)::YCOMMAND
LOGICAL::GSTATU
!
!*      0.3   Taskcommon for logical units
!
COMMON/TASKCLOS/ILUPRI,INUMBR,IRESP,YFNDES,YFNLFI,YSTATU
!DIR$ TASKCOMMON TASKCLOS
!
!----------------------------------------------------------------------------
!
!*      1.1   THE NAME OF DESFM=HFILEM.des
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FMCLOS',0,zhook_handle)
iresp = 0 ; irowf = 0 ; iposnu = 0 ; ilupri = 6 ; ierr = 0
ifmfnl=jpfinl-4
ytrans='transfer.x'

irowf=len(hfilem)

IF (irowf.EQ.0) THEN
   iresp=-59
   GOTO 1000
ELSEIF (irowf.GT.ifmfnl) THEN
   iresp=-60
   GOTO 1000
ENDIF
yintfn=adjustr(hfilem)
yfndes=yintfn//'.des'
yfndes=adjustl(yfndes)
!
!*      1.2   TEST FOR FILE EXISTENCE AND SEARCH OF ITS LOGICAL UNIT
!
CALL FMLOOK(YFNDES,HFIPRI,INUMBR,IRESP)
IF (iresp.NE.0) THEN
        GOTO 1000
ELSEIF (len(hstatu).LE.0) THEN
        iresp=-41
        GOTO 1000
ELSE
        gstatu=hstatu.EQ.'KEEP'.OR.hstatu.EQ.'DELETE'
        IF (gstatu) THEN
        ystatu=hstatu(1:min0(len(hstatu),len(ystatu)))
        ELSE
        ystatu='DEFAULT'
        ENDIF
ENDIF
!
!*      1.3   THE LOGICAL UNIT OF DESFM IS RELEASED FOR "FM"
!
CALL FMFREE(YFNDES,HFIPRI,IRESP)
IF (iresp.NE.0) GOTO 1000
!
!*      2.    CLOSURE OF DESFM
!
!  case of a namelist
!
CLOSE (UNIT=INUMBR,IOSTAT=IRESP,STATUS=YSTATU)
IF (iresp.NE.0) GOTO 1000
!
!*      3.1   THE NAME OF LFIFM=HFILEM.lfi
!
yfnlfi=yintfn//'.lfi'
yfnlfi=adjustl(yfnlfi)
!
!*      3.2   TEST FOR FILE EXISTENCE AND SEARCH OF ITS LOGICAL UNIT
!
CALL FMLOOK(YFNLFI,HFIPRI,INUMBR,IRESP)
IF (iresp.NE.0) GOTO 1000
!
!*      3.3   THE LOGICAL UNIT FOR LFIFM IS RELEASED FOR "FM"
!
CALL FMFREE(YFNLFI,HFIPRI,IRESP)
IF (iresp.NE.0) GOTO 1000
!
!*      4.    CLOSURE OF LFI
!
!  case of a LFI file
!
CALL LFIFER(IRESP,INUMBR,YSTATU)
IF (iresp.NE.0) GOTO 1000
!
!*      5.    INPUT FOR THE UNIX SYSTEM TO SAVE AND SEND THE FILE
!
print*,'KTYPE=',nfityp(inumbr)
SELECT CASE (nfityp(inumbr))
CASE(:-1)
  iresp=-66
  GOTO 1000
CASE(0)
  ycpio='NIL'
CASE(1)
  ycpio='MESONH'
CASE(2)
  print*,'FILE ',hfilem,' NOT TRANSFERED'
  GOTO 1000
CASE(3:)
  iresp=-66
  GOTO 1000
END SELECT
WRITE (ycommand,20) ytrans,ycpio,hfilem
!
! write into the pipe : the "flush" forces instanteneous buffer transfer
! which is necessary for parallel treatment
!
print*,'YCOMMAND=',ycommand
WRITE (10,'(A100)') ycommand
!CALL FLUSH(10,IERR)
!
!*      6.    UPDATING OF ARRAY NFITYP
!
nfityp(inumbr)=jpniil
!
!*      7.    MESSAGE PRINTING WHATEVER THE ISSUE WAS
!
1000    CONTINUE

IF (iresp.NE.0) THEN
yfnlfi=adjustl(hfipri)
DO j=1,jpnxlu
    IF (cnamfi(j).EQ.yfnlfi) THEN
       ilupri=j
       EXIT
    ENDIF
ENDDO
WRITE (ilupri,*) ' exit from FMCLOS with IRESP:',iresp
WRITE (ilupri,*) '   | HFILEM = ',hfilem
WRITE (ilupri,*) '   | HSTATU = ',hstatu
ENDIF
kresp=iresp

! format: 10c for transfer.x and mesonh/nil
!         32c for file name
! if you have to change this format one day, don't forget the blank after 1H
20    FORMAT(a10,1h ,a10,1h ,a32)

IF (lhook) CALL dr_hook('FMCLOS',1,zhook_handle)
RETURN
      IF (lhook) CALL dr_hook('FMCLOS',1,zhook_handle)
      END SUBROUTINE fmclos