fm_writ.F90

Go to the documentation of this file.

!     ######spl
      SUBROUTINE fm_writ(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
                        KLENCH,HCOMMENT,KRESP)
      USE parkind1, ONLY : jprb
      USE yomhook , ONLY : lhook, dr_hook
!     ###########################################################
!
!!****  *FM_WRIT* - routine to write a single data article into a "FM"-file
!!
!!    PURPOSE
!!    -------
!
!       The purpose of FMWRIT is to write one article into a Meso-nh data file.
!     This routine only holds for a LFI-file (not namelist).
!
!!**  METHOD
!!    ------
!!
!!      The unformatted write operation is actually performed by the routine
!!    LFIECR. You need to indicate the file name without the ".lfi"
!!    suffix, the data array and the
!!    length of this array. Furthermore, you have to give a name for the article
!!    you are writing (string) which you better choose by convention.
!!      FMWRIT also appends the grid-indicator (KGRID) at the beginning of
!!    the LFI logical article (IWORK(1)) ; then the length of the comment
!!    string (KLENCH) ; then the comment string itself which is first
!!    converted into integer type using ICHAR.
!!    Finally, it writes the data (integer or
!!    real) itself (rest of array IWORK). We stress that the length KLENG
!!    that the user has to indicate is the length of the real data array
!!    WITHOUT taking the other fields into account.
!!
!!    EXTERNAL
!!    --------
!!
!!      FMLOOK,LFIECR,ICHAR
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!      MODULE: MODD_FMDECLAR contains management parameters and
!!              storage arrays to move information around at the
!!              level of all "FM"-routines.
!!
!!    REFERENCE
!!    ---------
!!
!!      see the Technical Specifications Report for the Meso-nh project
!!      (in French)
!!
!!    AUTHOR
!!    ------
!!
!!      C. FISCHER      *METEO-FRANCE*
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      original                                                        06/94
!!      modified by V. Masson               16/09/96 (prints if error occurs)
!----------------------------------------------------------------------------
!
!*      0.    DECLARATIONS
!             ------------
!
USE modd_fmdeclar

IMPLICIT NONE
!
!*      0.1   Declarations of arguments
!
CHARACTER(LEN=*)          ,INTENT(IN) ::HFILEM   ! file name
CHARACTER(LEN=*)          ,INTENT(IN) ::HRECFM   ! name of the article to be written

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

INTEGER,                   INTENT(IN) ::KLENG  ! length of the data field
INTEGER(KIND=8),DIMENSION(1:KLENG),INTENT(IN) ::KFIELD ! array containing the data field
INTEGER,                   INTENT(IN) ::KGRID  ! C-grid indicator (u,v,w,T)
INTEGER,                   INTENT(IN) ::KLENCH ! length of comment string

CHARACTER(LEN=KLENCH),     INTENT(IN) ::HCOMMENT ! comment string)

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

!
!*      0.2   Declarations of local variables
!
INTEGER::IRESP,ITOTAL,INUMBR,J,IROW,IFMFNL,ILUPRI
INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE::IWORK
INTEGER,DIMENSION(1:JPXKRK)::ICOMMENT
CHARACTER(LEN=JPFINL)::YFNLFI
CHARACTER(LEN=LEN(HFILEM))::YINTFN
!
!*      0.3   Taskcommon for logical units
!
COMMON/TASKWRIT/ILUPRI,INUMBR,IRESP
!DIR$ TASKCOMMON TASKWRIT
!
!----------------------------------------------------------------------------
!
!*      1.1   THE NAME OF LFIFM
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FM_WRIT',0,zhook_handle)
iresp = 0 ; irow = 0 ; ilupri = 6
ifmfnl=jpfinl-4

irow=len(hfilem)

IF (irow.EQ.0) THEN
   iresp=-64
   GOTO 1000
ELSEIF (irow.GT.ifmfnl) THEN
   iresp=-65
   GOTO 1000
ENDIF
yintfn=adjustr(hfilem)
yfnlfi=yintfn//'.lfi'
yfnlfi=adjustl(yfnlfi)

!
!*      1.2   WE LOOK FOR THE FILE'S LOGICAL UNIT
!
CALL FMLOOK(YFNLFI,HFIPRI,INUMBR,IRESP)
IF (iresp.NE.0) GOTO 1000

!
!*      2.    GRID INDICATOR, COMMENT AND DATA ARE PUT TOGETHER
!
IF (kleng.LE.0) THEN
    iresp=-40
    GOTO 1000
ELSEIF (kleng.GT.jpxfie) THEN
    iresp=-43
    GOTO 1000
ELSEIF ((kgrid.LT.0).OR.(kgrid.GT.8)) THEN
    iresp=-46
    GOTO 1000
ENDIF

itotal=kleng+1+klench+1
IF(ALLOCATED(iwork)) DEALLOCATE(iwork)
ALLOCATE(iwork(itotal))

iwork(1)=kgrid

SELECT CASE (klench)
CASE(:-1)
    iresp=-55
    GOTO 1000
CASE(0)
    iwork(2)=klench
    iwork(3:kleng+2)=kfield(1:kleng)
CASE(1:JPXKRK)
    DO j=1,klench
        icomment(j)=ichar(hcomment(j:j))
    ENDDO
    iwork(2)=klench
    iwork(3:klench+2)=icomment(1:klench)
    iwork(klench+3:itotal)=kfield(1:kleng)
CASE(JPXKRK+1:)
    iresp=-57
    GOTO 1000
END SELECT

!
!  no compressing of any kind: the data is pure binary
!
!*      3.    UNFORMATTED, DIRECT ACCESS WRITE OPERATION
!
CALL LFIECR(IRESP,INUMBR,HRECFM,IWORK,ITOTAL)
IF (iresp.NE.0) GOTO 1000

DEALLOCATE(iwork)
!
!*      4.    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 FMWRIT with IRESP:',iresp
WRITE (ilupri,*) '   | HFILEM = ',hfilem
WRITE (ilupri,*) '   | HRECFM = ',hrecfm
WRITE (ilupri,*) '   | KLENG  = ',kleng
WRITE (ilupri,*) '   | KGRID  = ',kgrid
WRITE (ilupri,*) '   | KLENCH = ',klench
ENDIF
kresp=iresp

IF (lhook) CALL dr_hook('FM_WRIT',1,zhook_handle)
RETURN
      IF (lhook) CALL dr_hook('FM_WRIT',1,zhook_handle)
      END SUBROUTINE fm_writ