mode_read_surf_cov.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.

MODULE mode_read_surf_cov
!
INTERFACE write_read_cov
  MODULE PROCEDURE read_surf_cov
END INTERFACE
!
CONTAINS

!     #############################################################
      SUBROUTINE read_surf_cov (HPROGRAM,HREC,PFIELD,OFLAG,KRESP,HCOMMENT,HDIR)
!     #############################################################
!
!
!
USE modd_surfex_mpi, ONLY : nproc, npio, nrank, idx_r, nreq, ncomm, nsize, nindex
USE modd_surf_par,  ONLY : xundef
!
#ifdef SFX_LFI
USE modd_io_surf_lfi, ONLY : nmask_lfi=>nmask, nfull_lfi=>nfull
#endif
#ifdef SFX_NC
USE modd_io_surf_nc, ONLY : nmask_nc=>nmask, nfull_nc=>nfull
#endif
#ifdef SFX_ASC
USE modd_io_surf_asc, ONLY : nmask_asc=>nmask, nfull_asc=>nfull
#endif
#ifdef SFX_FA
USE modd_io_surf_fa, ONLY : nmask_fa=>nmask, nfull_fa=>nfull
#endif
#ifdef SFX_MNH
USE modi_read_surfx2cov_mnh
#endif
!
USE modi_read_surf
USE modi_pack_same_rank
USE modi_read_and_send_mpi
USE modi_abor1_sfx
#ifdef SFX_ARO
USE modi_read_surfx1_aro
#endif
!
USE yomhook ,ONLY : lhook, dr_hook
USE parkind1 ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*      0.1   Declarations of arguments
!
!
!
 CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM    ! calling program
 CHARACTER(LEN=*), INTENT(IN) :: HREC        ! name of the article to be read
REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD ! array containing the data field
LOGICAL,DIMENSION(:), INTENT(IN) :: OFLAG   ! mask for array filling
INTEGER, INTENT(OUT) :: KRESP               ! KRESP  : return-code if a problem appears
 CHARACTER(LEN=*), OPTIONAL, INTENT(OUT) :: HCOMMENT ! name of the article to be read
 CHARACTER(LEN=1), OPTIONAL, INTENT(IN)  :: HDIR     ! type of field :
!                                                   ! 'H' : field with
!                                                   !       horizontal spatial dim.
!                                                   ! '-' : no horizontal dim.
!*      0.2   Declarations of local variables
!
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE,NPROC-1) :: ISTATUS
#endif
!INTEGER, DIMENSION(NPROC) :: ITREQ
REAL, DIMENSION(:),ALLOCATABLE :: ZWORKR
REAL, DIMENSION(:),ALLOCATABLE :: ZFIELD
INTEGER, DIMENSION(:), POINTER :: IMASKF
INTEGER, DIMENSION(COUNT(OFLAG)) :: IMASK
 CHARACTER(LEN=100) :: YCOMMENT
 CHARACTER(LEN=12)  :: YREC
 CHARACTER(LEN=16)  :: YREC2
 CHARACTER(LEN=1)   :: YDIR
 CHARACTER(LEN=4)  :: YLVL
INTEGER :: IFLAG 
INTEGER            :: IPIO_SAVE, IPAS, JP, IDEB, IFIN, JJ
INTEGER            :: JCOVER, JPROC, IPROC
INTEGER            :: IL1, IL2, IDX_SAVE, IDX, IVAL
INTEGER :: INFOMPI, IREQ, JPROC2, IFULL
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!
IF (lhook) CALL dr_hook('READ_SURF_COV_1',0,zhook_handle)
!
idx_save = idx_r
yrec = hrec
ycomment="empty"
ydir = 'H'
IF (PRESENT(hdir)) ydir = hdir
!
il1 = SIZE(pfield,1)
il2 = count(oflag)
!
IF (lhook) CALL dr_hook('READ_SURF_COV_1',1,zhook_handle)
!
IF (hprogram=='MESONH') THEN
#ifdef SFX_MNH
   yrec2 = yrec
   CALL read_surfx2cov_mnh(yrec2,il1,il2,pfield,oflag,kresp,ycomment,ydir)
#endif
ELSE
  !
  IF (lhook) CALL dr_hook('READ_SURF_COV_2',0,zhook_handle)
  !
  !mask associating the index of the cover in xcover to its real number
  jcover = 0
  DO jj = 1,SIZE(oflag)
    IF (oflag(jj)) THEN
      jcover=jcover+1
      imask(jcover) = jj
    ENDIF
  ENDDO
  !
  !the mask to call read_and_send_mpi depends on the I/O type
  IF (hprogram=='LFI   ') THEN
#ifdef SFX_LFI
    ifull = nfull_lfi
    ALLOCATE(zfield(nfull_lfi))
    imaskf=>nmask_lfi
#endif
  ELSEIF (hprogram=='ASCII ') THEN
#ifdef SFX_ASC
    ifull = nfull_asc
    ALLOCATE(zfield(nfull_asc))
    imaskf=>nmask_asc
#endif
  ELSEIF (hprogram=='FA     ') THEN
#ifdef SFX_FA
    ifull = nfull_fa
    ALLOCATE(zfield(nfull_fa))
    imaskf=>nmask_fa
#endif
  ELSEIF (hprogram=='NC     ') THEN
#ifdef SFX_NC
    ifull = nfull_nc
    ALLOCATE(zfield(nfull_nc))
    imaskf=>nmask_nc
#endif
  ENDIF
  !
  !if we want to get covers for the current task or for the whole domain
  IF (ydir=='H') THEN
     !second dimension because the reading of covers is parallelized with MPI
    ALLOCATE(zworkr(nsize))
  ELSEIF (nrank==npio) THEN
    ALLOCATE(zworkr(ifull))
  ELSE 
    ALLOCATE(zworkr(0))
  ENDIF
  zworkr(:) = 0.
  !
  IF (nproc>1 .AND. ydir=='H') THEN
    iflag = 0
    !for the parallelization of reading, NINDEX must be known by all tasks
    IF (nrank/=npio) THEN
      IF (ALLOCATED(nindex)) THEN
        IF (SIZE(nindex)==ifull) iflag=1
        DEALLOCATE(nindex)
      ENDIF
      ALLOCATE(nindex(ifull))
    ENDIF
#ifdef SFX_MPI
    CALL mpi_bcast(nindex,SIZE(nindex)*kind(nindex)/4,mpi_integer,npio,ncomm,infompi)
#endif
  ENDIF
  !
  ipio_save = npio
  !number of covers read by each task
  ipas = ceiling(il2*1./nproc)
  !
  pfield(:,:) = 0.
  !
  !first cover number read by the current task
  ideb = ipas*nrank
  !
  IF (lhook) CALL dr_hook('READ_SURF_COV_2',1,zhook_handle)
  !
  DO jp = 1,ipas
    !
    IF (lhook) CALL dr_hook('READ_SURF_COV_3',0,zhook_handle)
    !
    !index of the cover read by this task at this loop index
    jcover = ideb + jp
    !
    IF (jcover<=il2) THEN
      !
      !real number of the cover
      jj = imask(jcover)
      !
      IF (trim(hrec)=='COVER') THEN
        WRITE(yrec,'(A5,I3.3)') trim(hrec),jj
      ELSE
        WRITE(ylvl,'(I4)') jj
        yrec = trim(hrec)//adjustl(ylvl(:len_trim(ylvl)))
      ENDIF
      ycomment='X_Y_'//yrec
      !
      !
      IF (hprogram=='AROME ') THEN
#ifdef ARO
        CALL read_surfx1_aro(yrec,il1,pfield(:,jcover),kresp,ycomment,ydir)
#endif
      ELSE
        !
        !reads one cover by task
        !
        !number of the I/O task for this read 
        npio = nrank
        !
        !reading of the whol cover (HDIR='A')
        CALL read_surf(hprogram,yrec,zfield,kresp,ycomment,'A')
        !
        !NPIO rebecomes the I/O task 
        npio = ipio_save
        !
        idx = idx_save + jp
        IF (ydir=='H') THEN
          !
          !send covers to other tasks
          CALL read_and_send_mpi(zfield,pfield(:,jcover),imaskf,nrank,idx)
          !
        ELSEIF (ydir=='A' .OR. ydir=='E') THEN
          !
          !NPIO needs to know all covers read
          IF (nrank/=npio) THEN
            idx = idx + 1 
#ifdef SFX_MPI
            CALL mpi_send(zfield,SIZE(zfield)*kind(zfield)/4,mpi_real,npio,idx,ncomm,infompi)
#endif
          ELSE
            CALL pack_same_rank(imaskf,zfield,pfield(:,jcover))
          ENDIF
          !
        ELSE
          CALL abor1_sfx("READ_SURFX2COV:HDIR MUST BE H OR A OR E")
        ENDIF
        !   
      ENDIF
      !
    ENDIF
    !
    IF (lhook) CALL dr_hook('READ_SURF_COV_3',1,zhook_handle)
    !
    IF (nrank==npio .OR. ydir=='H') THEN
      !
      !receives pieces of cover fields
      !ITREQ(:) = 0
      !
!$OMP PARALLEL PRIVATE(ZHOOK_HANDLE_OMP)
IF (lhook) CALL dr_hook('READ_SURF_COV_4',0,zhook_handle_omp)
#ifdef SFX_MPI
!$OMP DO SCHEDULE(DYNAMIC,1) PRIVATE(JPROC,IDX,ISTATUS,INFOMPI) FIRSTPRIVATE(ZWORKR)
#endif
      DO jproc=0,nproc-1
        !
        !the cover exists and was read
        IF (ipas*jproc + jp<=il2) THEN
          !
          !IF (JPROC<NRANK) THEN
          !  ITREQ(JPROC+1) = JPROC+1
          !ELSE
          !  ITREQ(JPROC+1) = JPROC
          !ENDIF    
          !     
          IF (jproc/=nrank) THEN
            idx = idx_save + jp + 1
            !each task receives the part of the cover read that concerns it 
            !only NPIO in cas of HDIR/=H
#ifdef SFX_MPI           
            CALL mpi_recv(zworkr(:),SIZE(zworkr)*kind(zworkr)/4,&
                          mpi_real,jproc,idx,ncomm,istatus,infompi)
#endif
            ival = ipas*jproc + jp
            CALL pack_same_rank(imaskf,zworkr(:),pfield(:,ival))
            !
          ENDIF
          !
        ENDIF
        !
      ENDDO
#ifdef SFX_MPI
!$OMP END DO
#endif
IF (lhook) CALL dr_hook('READ_SURF_COV_4',1,zhook_handle_omp)
!$OMP END PARALLEL 

!
      IF (lhook) CALL dr_hook('READ_SURF_COV_5',0,zhook_handle)
      !
      !waits that all cover pieces are sent
#ifdef SFX_MPI
      IF (ydir=='H' .AND. ipas*nrank+jp<=il2 .AND. nproc>1) THEN
        CALL mpi_waitall(nproc-1,nreq(1:nproc-1),istatus,infompi)
      ENDIF
#endif
      !
      IF (lhook) CALL dr_hook('READ_SURF_COV_5',1,zhook_handle)
      !
!      IF (YDIR=='H' .OR. NRANK==NPIO) THEN
!        !packs data
!        IREQ = MAXVAL(ITREQ)
!!$OMP PARALLEL PRIVATE(ZHOOK_HANDLE_OMP)
!IF (LHOOK) CALL DR_HOOK('READ_SURF_COV_6',0,ZHOOK_HANDLE_OMP)
!!$OMP DO SCHEDULE(DYNAMIC,1) PRIVATE(JPROC,IVAL)
!        DO JPROC=0,IREQ-1
!          IVAL = IPAS*JPROC + JP
!          IF (JPROC>=NRANK ) IVAL = IVAL + IPAS
!          CALL PACK_SAME_RANK(IMASKF,ZWORKR(:,JPROC+1),PFIELD(:,IVAL))
!        ENDDO
!!$OMP END DO
!IF (LHOOK) CALL DR_HOOK('READ_SURF_COV_6',1,ZHOOK_HANDLE_OMP)
!!$OMP END PARALLEL
!      ENDIF
      !
    ENDIF
    !
  ENDDO
  !
  IF (lhook) CALL dr_hook('READ_SURF_COV_7',0,zhook_handle)
  !
  IF (nrank/=npio .AND. ydir=='H' .AND. iflag==0) THEN
    DEALLOCATE(nindex)
    ALLOCATE(nindex(0))
  ENDIF
  !
  idx_r = idx_r + ipas + 1
  DEALLOCATE(zworkr)
  IF (hprogram /= 'AROME ') THEN
    DEALLOCATE(zfield)
  ENDIF
  imaskf=>null()
  !  
  IF (lhook) CALL dr_hook('READ_SURF_COV_7',1,zhook_handle)
  !
ENDIF
!
IF (lhook) CALL dr_hook('READ_SURF_COV_8',0,zhook_handle)
!
!RJ: what is a point of comment here? last field comment? Should be 'COVER_PACKED' status?
IF (PRESENT(hcomment)) hcomment = ycomment
!
IF (lhook) CALL dr_hook('READ_SURF_COV_8',1,zhook_handle)
!
END SUBROUTINE read_surf_cov

END MODULE mode_read_surf_cov