fmattr.F90

Go to the documentation of this file.

!     ######spl
      SUBROUTINE fmattr(HFILEM,HFIPRI,KNUMBR,KRESP)
      USE parkind1, ONLY : jprb
      USE yomhook , ONLY : lhook, dr_hook
!     #############################################
!
!!****  *FMATTR* - routine to attribute a logical unit to a file name
!!
!!    PURPOSE
!!    -------
!
!       The purpose of FMATTR is to attribute to the file named HFILEM
!     the logical unit number KNUMBR chosen among the free logical units
!
!!**  METHOD
!!    ------
!!
!!      If FMATTR is called for the very first time, then all the management
!!    arrays used by the FM-routines are initialized in FMINIT. 
!!    Otherwise, the name HFILEM is searched in the array CNAMFI, where
!!    it should not exist ! Finally, a logical unit number is searched
!!    in array CNAMFI. As soon as a free place is found (CNAMFI=CPUDFN),
!!    this place becomes the logical unit number for HFILEM and CNAMFI is
!!    set to HFILEM.
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    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                                                        04/94
!!      modified by C. Fischer                5/7/95 (locks for multitasking)
!!      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) ::HFIPRI  ! file for prints in FM

INTEGER,              INTENT(OUT)::KNUMBR  ! logical unit number
INTEGER,              INTENT(OUT)::KRESP   ! return-code if problems araised
!
!*      0.2   Declarations of local variables
!
INTEGER::IRESP=0,j,ilogiq=0,ilupri
CHARACTER(LEN=JPFINL)::YLOCFN,YLOCFN2
!
!*      0.3   Taskcommon for logical units
!
COMMON/TASKATTR/ILUPRI
!DIR$ TASKCOMMON TASKATTR
!
!----------------------------------------------------------------------------
!
!*      1.    INITIALISATION AND TEST THAT FILE DOES NOT ALREADY EXIST
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FMATTR',0,zhook_handle)
iresp = 0 ; ilogiq = 0 ; ilupri = 6
ylocfn=hfilem ; ylocfn=adjustl(ylocfn)


IF (lfcatt) THEN
    CALL fminit
    lfcatt=.false.
ELSE
    IF (nopefi.LT.0) THEN
       iresp=-50
       GOTO 1000
    ELSE
       DO j=1,jpnxlu
         IF (ylocfn.EQ.cnamfi(j)) THEN
           iresp=-51
           GOTO 1000
         ENDIF
       ENDDO
    ENDIF
ENDIF
!
!*     2.     WE LOOK FOR A FREE PLACE IN ARRAY CNAMFI
!
!   That place will become the number for the logical unit attributed to HFILEM
!
DO j=1,jpnxlu
    IF (cnamfi(j).EQ.cpudfn) THEN
       ilogiq=j
       cnamfi(j)=ylocfn
       EXIT
    ENDIF
ENDDO
IF (ilogiq.EQ.0) THEN
    iresp=-52
    GOTO 1000
ENDIF

knumbr=ilogiq ; nopefi=nopefi+1
!
!*     3.     MESSAGE PRINTING WHATEVER THE ISSUE WAS
!
1000   CONTINUE

IF (iresp.NE.0) THEN
   ylocfn2=adjustl(hfipri)
!
! in the special case where FMATTR is called to reserve a logical unit
! for the output file itself (i.e. HFILEM=HFIPRI),
! no print is performed because we do not know
! whether this file was actually opened or not.
!
   IF (ylocfn2.EQ.ylocfn) THEN
      ilupri=ilogiq
   ELSE
      DO j=1,jpnxlu
         IF (cnamfi(j).EQ.ylocfn2) THEN
            ilupri=j
            EXIT
         ENDIF
      ENDDO
      WRITE (ilupri,*) ' exit from FMATTR with IRESP:',iresp
      WRITE (ilupri,*) '   | HFILEM = ',hfilem
   ENDIF
ENDIF
kresp=iresp

IF (lhook) CALL dr_hook('FMATTR',1,zhook_handle)
RETURN
      IF (lhook) CALL dr_hook('FMATTR',1,zhook_handle)
      END SUBROUTINE fmattr