read_surf_atm.F90

Go to the documentation of this file.

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
!SFX_LIC for details. version 1.
!     #########
SUBROUTINE read_surf_atm     (HPROGRAM, PFIELD, KFORC_STEP, KNB, KINIT)  
!**************************************************************************
!
!!    PURPOSE
!!    -------
!         Read in the ascii file the atmospheric forcing for the actual time
!         step KFORC_STEP, and for the next one.
!         The two time step are needed for the time interpolation of the
!         forcing.
!         If the end of the file  is reached, set the two step to the last
!         values.
!         Return undef value if the variable is not present
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      A. Lemonsu  *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original     03/2008
!         
USE modd_surfex_mpi, ONLY : nrank, npio, nindex, xtime_comm_read, xtime_npio_read
!
USE modd_surf_par,   ONLY : xundef
USE modd_io_surf_ol, ONLY : xstart,xcount,xstride,lpartr
USE modd_io_surf_asc,ONLY : nni_forc
!
USE modd_arch, ONLY : little_endian_arch
!
USE mode_char2real
!
USE modi_abor1_sfx
USE modi_read_and_send_mpi
USE modi_gather_and_write_mpi
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include 'mpif.h'
#endif
!
! global variables
REAL, DIMENSION(:,:),INTENT(INOUT) :: pfield
INTEGER,INTENT(IN)               :: kforc_step
INTEGER,INTENT(IN)               :: knb 
INTEGER,INTENT(IN)               :: kinit
 CHARACTER(LEN=6)    ,INTENT(IN)  :: hprogram

! local variables
INTEGER                          :: i, ini, j, i1
 CHARACTER(LEN=4), DIMENSION(:), ALLOCATABLE  :: yf
 CHARACTER(LEN=4) :: ywork
DOUBLE PRECISION :: xtime0
REAL*4                            :: zwork4
REAL, DIMENSION(:,:), ALLOCATABLE :: zfield
REAL                              :: zwork
LOGICAL                          :: gswap              ! T: swap has been done
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('READ_SURF_ATM',0,zhook_handle)
!
IF (nrank==npio) THEN
  ini = SIZE(nindex)
  ALLOCATE(zfield(ini,SIZE(pfield,2)))
  IF (hprogram == 'BINARY') THEN
    ALLOCATE(yf(ini))
  ENDIF
ELSE
  ALLOCATE(zfield(0,0)) 
  ALLOCATE(yf(0))
ENDIF
!
 CALL gather_and_write_mpi(pfield,zfield)
!
IF (nrank==npio) THEN
  !
#ifdef SFX_MPI
  xtime0 = mpi_wtime()
#endif
  !
  IF (hprogram == 'ASCII ') THEN
    !
    IF (kforc_step .EQ. 1) THEN
      i1 = 1
      rewind(kinit)
    ELSE
      i1 = 2
      zfield(:,1) = zfield(:,knb)
    ENDIF
    DO i=i1,knb
      IF (nni_forc==1) THEN
        READ(unit=kinit,fmt=*) zwork
        zfield(:,i) = zwork
      ELSE
        READ(unit=kinit,fmt=*) zfield(:,i)
      END IF
    ENDDO
    !
  ELSE IF (hprogram == 'BINARY') THEN
    !
    IF (kforc_step .EQ. 1) THEN    
      i1 = 1
      gswap = .false.
    ELSE
      i1 = 2
      zfield(:,1) = zfield(:,knb)
    ENDIF
    DO i=i1,knb
      IF (nni_forc==1) THEN
        READ(unit=kinit,rec=kforc_step+i-1) ywork
        yf(:) = ywork
      ELSE
        READ(unit=kinit,rec=kforc_step+i-1) yf(:)
      END IF
      zfield(:,i) = yf(:)
      IF (     any(abs(zfield(:,i))>0. .AND. abs(zfield(:,i))<1.e-30) &
          .OR. any(abs(zfield(:,i))>1.e6)                       ) THEN  
        CALL abor1_sfx('READ_SURF_ATM: SWAP SET IN YOUR PARAMS_CONFIG FILE SEEMS '//&
          'INAPPROPRIATE - VERIFY  ')  
      END IF  
    ENDDO
    !
  ENDIF
  !
#ifdef SFX_MPI
  xtime_npio_read = xtime_npio_read + (mpi_wtime() - xtime0)
#endif
  !  
ENDIF
!
 CALL read_and_send_mpi(zfield,pfield)
!
DEALLOCATE(zfield)
IF (hprogram=='BINARY') THEN
  DEALLOCATE(yf)
ENDIF
!
lpartr=.false.
!
IF (lhook) CALL dr_hook('READ_SURF_ATM',1,zhook_handle)

END SUBROUTINE read_surf_atm