mode_read_surf_layers.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_layers
!
INTERFACE write_read_layers
  MODULE PROCEDURE read_surf_layers
END INTERFACE
!
CONTAINS
!
!     #############################################################
      SUBROUTINE read_surf_layers (HPROGRAM,HREC,ODIM,PFIELD,KRESP,HCOMMENT,HDIR,KPATCH)
!     #############################################################
!
!
!
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_surf
#endif
!
USE modi_abor1_sfx
USE modi_pack_same_rank
USE modi_read_and_send_mpi
USE modi_make_choice_array
!
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
LOGICAL, INTENT(IN) :: ODIM
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PFIELD ! array containing the data field
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.
INTEGER, OPTIONAL, INTENT(IN) :: KPATCH
!
!*      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
 CHARACTER(LEN=100) :: YCOMMENT
 CHARACTER(LEN=16)  :: YREC
 CHARACTER(LEN=1)   :: YDIR
 CHARACTER(LEN=4)  :: YLVL
INTEGER :: IFLAG, IPATCH, INPATCH
INTEGER :: IPIO_SAVE, IPAS, JP, IDEB, IFIN, JJ, JL
INTEGER :: JLAYER, JPROC, IPROC, IRESP
INTEGER :: IL1, IL2, IL3, IDX_SAVE, IDX, IVAL
INTEGER :: INFOMPI, IREQ, JPROC2, IFULL
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!
IF (lhook) CALL dr_hook('READ_SURF_LAYERS_1',0,zhook_handle)
!
idx_save = idx_r
yrec = hrec
ycomment="empty"
ydir = 'H'
IF (PRESENT(hdir)) ydir = hdir
inpatch = SIZE(pfield,3)
ipatch = -1
IF (PRESENT(kpatch).AND.inpatch==1) ipatch = kpatch
!
il1 = SIZE(pfield,1)
il2 = SIZE(pfield,2)
il3 = SIZE(pfield,3)
!
IF (lhook) CALL dr_hook('READ_SURF_LAYERS_1',1,zhook_handle)
!
IF (hprogram=='MESONH') THEN
#ifdef SFX_MNH
  DO jl=1,il2
    WRITE(ylvl,'(I4)') jl
    yrec=trim(hrec)//adjustl(ylvl(:len_trim(ylvl)))
    CALL make_choice_array(hprogram, inpatch, odim, yrec, pfield(:,jl,:), hdir=ydir, kpatch=ipatch)
  END DO
#endif
ELSE
  !
  IF (lhook) CALL dr_hook('READ_SURF_LAYERS_2',0,zhook_handle)
  !
  !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,il3))
    imaskf=>nmask_lfi
#endif
  ELSEIF (hprogram=='ASCII ') THEN
#ifdef SFX_ASC
    ifull = nfull_asc
    ALLOCATE(zfield(nfull_asc,il3))
    imaskf=>nmask_asc
#endif
  ELSEIF (hprogram=='FA     ') THEN
#ifdef SFX_FA
    ifull = nfull_fa
    ALLOCATE(zfield(nfull_fa,il3))
    imaskf=>nmask_fa
#endif
  ELSEIF (hprogram=='NC     ') THEN
#ifdef SFX_NC
    ifull = nfull_nc
    ALLOCATE(zfield(nfull_nc,il3))
    imaskf=>nmask_nc
#endif
  ELSE
    ALLOCATE(zfield(0,0))
  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,il3))
  ELSEIF (nrank==npio) THEN
    ALLOCATE(zworkr(ifull,il3))
  ELSE 
    ALLOCATE(zworkr(0,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_LAYERS_2',1,zhook_handle)
  !
  DO jp = 1,ipas
    !
    IF (lhook) CALL dr_hook('READ_SURF_LAYERS_3',0,zhook_handle)
    !
    !index of the cover read by this task at this loop index
    jlayer = ideb + jp
    !
    IF (jlayer<=il2) THEN
      !
      WRITE(ylvl,'(I4)') jlayer
      yrec = trim(hrec)//adjustl(ylvl(:len_trim(ylvl)))
      ycomment='X_Y_'//yrec
      !
      !
      IF (hprogram=='AROME ') THEN
#ifdef ARO
         CALL make_choice_array(hprogram, inpatch, odim, yrec, pfield(:,jlayer,:), hdir=ydir, kpatch=ipatch)
#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 make_choice_array(hprogram, inpatch, odim, yrec, zfield, hdir='A', kpatch=ipatch)
        !
        !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(:,jlayer,:),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(:,jlayer,:))
          ENDIF
          !
        ELSE
          CALL abor1_sfx("READ_SURF_LAYERS:HDIR MUST BE H OR A OR E")
        ENDIF
        !   
      ENDIF
      !
    ENDIF
    !
    IF (lhook) CALL dr_hook('READ_SURF_LAYERS_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_LAYERS_4',0,zhook_handle_omp)
#ifdef SFX_MPI
!$OMP DO SCHEDULE(DYNAMIC,1) PRIVATE(JPROC,IDX,ISTATUS,INFOMPI)
#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_LAYERS_4',1,zhook_handle_omp)
!$OMP END PARALLEL 

!
      IF (lhook) CALL dr_hook('READ_SURF_LAYERS_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_LAYERS_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_LAYERS_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_LAYERS_6',1,ZHOOK_HANDLE_OMP)
!!$OMP END PARALLEL
!      ENDIF
      !
    ENDIF
    !
  ENDDO
  !
  IF (lhook) CALL dr_hook('READ_SURF_LAYERS_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 ") DEALLOCATE(zfield)
  imaskf=>null()
  !  
  IF (lhook) CALL dr_hook('READ_SURF_LAYERS_7',1,zhook_handle)
  !
ENDIF
!
IF (lhook) CALL dr_hook('READ_SURF_LAYERS_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_LAYERS_8',1,zhook_handle)
!
END SUBROUTINE read_surf_layers

END MODULE mode_read_surf_layers