sfx_xios_send_block.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 sfx_xios_send_block(HDTAG,PFIELD,PFIELD2,PFIELD3,&
                HDOMAIN,HAXIS,HAXIS2,HDCOMMENT,KFREQOP)
!!
!!
!!     PURPOSE 
!!     --------
!!
!!     Front-end to XIOS for client models
!!
!!     It performes field declaration to XIOS if needed, provided it is
!!     not too late with respect to xios context definition closing
!!     (see sfx_xios_declare_field)  
!!
!!     It copes with client models which process fields by 'blocks'
!!     over the first dimension, and wish to send them by blocks too,
!!     a set of blocks being provided, duly ordered, between two
!!     calendar updates
!!
!!     It gathers field blocks and send them to XIOS, using
!!     xios_send_field, as soon as the field is complete (i.e. enough
!!     blocks have been received, compared to a MODD_XIOS variable)
!!
!!     METHOD :
!!     -------------------- 
!!     
!!     For each new field name received, create an entry in buffer
!!     array and records full MPI-task field size (as known by
!!     Xios). 
!!
!!     For all field names, add the block to the buffer and, if field
!!     is complete, send it to Xios and clears the buffer
!!
!!     EXTERNAL
!!     --------
!!
!!     XIOS LIBRARY
!!
!!
!!     REFERENCE
!!     ---------
!!
!!     XIOS Reference guide - Yann Meurdesoif - 10/10/2014 - 
!!     svn co --r 515 http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-1.0 <dir> 
!!     cd <dir>/doc ; ....
!!
!!     AUTHOR
!!     ------
!!
!!     S.Sénési, CNRM
!!
!!     MODIFICATION
!!     --------------
!!
!!     Original    01/2016
!!
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_surfex_mpi, ONLY : nrank
!
USE modd_xios, ONLY : lxios, lxios_def_closed, nblock , ntimestep
!
! NBLOCK dans arpege : YOMDIM:NGPBLKS
#ifdef WXIOS 
USE modi_sfx_xios_declare_field
USE xios ,ONLY : xios_is_defined_field_attr, xios_get_field_attr, &
      xios_is_defined_grid_attr, xios_get_grid_attr, &
      xios_is_defined_domain_attr, xios_get_domain_attr, &
      xios_is_valid_field, xios_send_field, xios_set_field_attr,&
      xios_get_handle, xios_add_child, xios_set_attr,&
      xios_field, xios_fieldgroup, xios_field_is_active,&
      xios_update_calendar
#endif
!
USE modi_abor1_sfx
!
USE yomhook  , ONLY : lhook, dr_hook
USE parkind1 , ONLY : jpim, jprb
!
IMPLICIT NONE
!
!   Arguments
!
 CHARACTER(LEN=*), INTENT(IN)               :: HDTAG   ! Field name
REAL(KIND=JPRB) , INTENT(IN), OPTIONAL, DIMENSION(:)  :: PFIELD  ! Field data block
REAL(KIND=JPRB) , INTENT(IN), OPTIONAL, DIMENSION(:,:):: PFIELD2 ! (or) 2d field data block
REAL(KIND=JPRB) , INTENT(IN), OPTIONAL, DIMENSION(:,:,:):: PFIELD3 ! (or) 3d field data block
 CHARACTER(LEN=*), INTENT(IN), OPTIONAL     :: HDOMAIN ! Field domain name, defaults to 'FULL' 
 CHARACTER(LEN=*), INTENT(IN), OPTIONAL     :: HAXIS   ! Axis name, for 2d fields
 CHARACTER(LEN=*), INTENT(IN), OPTIONAL     :: HAXIS2  ! 2nd axis name, for 3d fields
 CHARACTER(LEN=*), INTENT(IN), OPTIONAL     :: HDCOMMENT ! Comment 'a la Surfex' (i.e. '<long name> (<units>)')
 INTEGER         , INTENT(IN), OPTIONAL     :: KFREQOP ! Sampling frequency, in minutes
!
!  Local variables
!
#ifdef WXIOS
!
! A basic type for handling fields and their buffer
!
TYPE buf_t
   CHARACTER(LEN=100) :: YLNAME   ! Field name , as for XIOS
   INTEGER(KIND=JPIM) :: ISIZEMAX ! Expected size of the complete field
                                  ! for the whole of the MPI task
   INTEGER(KIND=JPIM) :: ISIZE    ! Current usable size (ie. over received blocks)
   INTEGER(KIND=JPIM) :: INDIM    ! Number of dimensions 
   INTEGER(KIND=JPIM) :: ILEV     ! Size of 2nd dim  (from first call)
   INTEGER(KIND=JPIM) :: ILEV2    ! Size of 3rd dim (from first call)
   INTEGER(KIND=JPIM) :: IBLOCK   ! Number of blocks received for current timestep
   REAL(KIND=JPRB), ALLOCATABLE, DIMENSION (:,:,:) :: ZFIELD ! Accumulate received blocks
END TYPE buf_t
!
TYPE(xios_field) :: field_hdl, other_field_hdl
TYPE(xios_fieldgroup) :: fieldgroup_hdl
INTEGER(KIND=JPIM)             :: ISIZE = 1000         ! Initial number of managed field entries 
INTEGER(KIND=JPIM), PARAMETER  :: INCR = 100          ! Increment in field entries number when reallocating
INTEGER(KIND=JPIM), PARAMETER  :: IMAXSIZE = 10000    ! Max number of field entries
!
TYPE(buf_t), POINTER                   :: YLF       ! Current buffer entry
TYPE(buf_t), ALLOCATABLE, TARGET, SAVE :: YLFIELDS(:)! Array of buffer entries
TYPE(buf_t), ALLOCATABLE               :: YLTEMP(:) ! id - temporary
!
INTEGER(KIND=JPIM)      :: JI, IL, IEMPTY, IIDIM, ITAKE, ILEV, INFIELDS
 CHARACTER(LEN=100)      :: YLTAG   ! Field name
 CHARACTER(LEN=300)      :: YLAXIS, YLAXIS2 
 CHARACTER(LEN=300)      :: YLDOMAIN
 CHARACTER(LEN=300)      :: YLGRID
 CHARACTER(LEN=300)      :: YLCOMMENT
!
INTEGER                 :: IFREQOP 
!
LOGICAL :: GLISDEF
!
#endif
!
REAL(KIND=JPRB)          :: ZHOOK_HANDLE
!
!#include "abor1.intfb.h"
!
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_1',0,zhook_handle)
!
IF (.NOT. lxios) THEN
  IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_1',1,zhook_handle)
  RETURN
ENDIF
!
#ifdef WXIOS
!
IF (lxios_def_closed) THEN 
  IF (.NOT. xios_field_is_active(hdtag) ) THEN 
    IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_1',1,zhook_handle)
    RETURN
  ENDIF
ENDIF
yltag = trim(hdtag)
!
!$OMP SINGLE
!
ALLOCATE(ylfields(isize))
ylfields(:)%YLNAME = ''
!
!   Search if field is known - a simple loop on the table -
!   probably not much quick ...
!
il = 0
DO ji=1,isize
  IF (ylfields(ji)%YLNAME == yltag) THEN 
    il = ji
    EXIT
  ENDIF
ENDDO
!
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_1',1,zhook_handle)
!
IF ( il==0 ) THEN
  !
  ! Field is not yet recorded -> ask XIOS if field is known,  and what's its size
  ! By exception : if XIOS still in init phase, declare field domain if needed
  !
  IF (.NOT. lxios_def_closed) THEN

IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_2',0,zhook_handle)

    yldomain=''
    IF (PRESENT(hdomain)) yldomain = trim(hdomain)
    ylcomment=''
    IF (PRESENT(hdcomment)) ylcomment = trim(hdcomment)
    ifreqop=0
    IF (PRESENT(kfreqop)) ifreqop = kfreqop
    !
    IF (PRESENT(pfield)) THEN 
      CALL sfx_xios_declare_field(yltag, yldomain, hcomment=ylcomment, kfreqop=ifreqop)
    ELSEIF (PRESENT(pfield2)) THEN 
      ylaxis=''
      IF (PRESENT(haxis)) ylaxis = trim(haxis)
      CALL sfx_xios_declare_field(yltag, yldomain, haxis=ylaxis, &
              klev=SIZE(pfield2,2), hcomment=ylcomment,kfreqop=ifreqop)
    ELSEIF (PRESENT(pfield3)) THEN 
      ylaxis ='' ; IF (PRESENT(haxis))  ylaxis  = trim(haxis)
      ylaxis2='' ; IF (PRESENT(haxis2)) ylaxis2 = trim(haxis2)
      CALL sfx_xios_declare_field(yltag, yldomain, &
              haxis =ylaxis , klev =SIZE(pfield3,2), &
              haxis2=ylaxis2, klev2=SIZE(pfield3,3), hcomment=ylcomment,kfreqop=ifreqop)
    ELSE
      CALL abor1_sfx("SFX_XIOS_SEND_BLOCK: NO PFIELDx FOR "//trim(yltag))
    ENDIF
    !
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_2',1,zhook_handle)

  ELSE
    !
    IF (.NOT. xios_is_valid_field(yltag)) THEN
      CALL abor1_sfx("SFX_XIOS_SEND_BLOCK: FIELD "//trim(yltag)//&
              &" WASN'T DECLARED TO XIOS (NEITHER IN XML CONFIG FILE, NOR SOON ENOUGH FROM CODE)")
    ENDIF
    !
    ! Find a place (i.e. index IEMPTY) to record the new field
    !
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_3',0,zhook_handle)

    iempty = 0
    DO ji = 1,isize
      IF (trim(ylfields(ji)%YLNAME) == '') THEN 
        iempty = ji
        EXIT
      ENDIF
    ENDDO
    !
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_3',1,zhook_handle)
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_4',0,zhook_handle)


    IF ( iempty == 0 ) THEN
      ! The fields table is full. Allocate a new one and copy the content
      IF (isize > imaxsize) THEN 
        CALL abor1_sfx("SFX_XIOS_SEND_BLOCK: MAX BUFFER ENTRIES NUMBER WAS REACHED")
      ENDIF
      !
      ALLOCATE(yltemp(isize))
      yltemp = ylfields
      DEALLOCATE(ylfields)
      !
      ALLOCATE(ylfields(isize+incr))
      ylfields(1:isize) = yltemp(1:isize)
      DEALLOCATE(yltemp)
      !
      ylfields(isize+1:isize+incr)%YLNAME = ''
      !
      iempty = isize+1
      isize  = isize+incr
      !
    ENDIF
    !
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_4',1,zhook_handle)
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_5',0,zhook_handle)

    ! Record the new field attributes (not its data)
    !
    ylf => ylfields(iempty)
    ylf%YLNAME = trim(yltag)
    !
    CALL xios_is_defined_field_attr(yltag, grid_ref=glisdef)
    IF (glisdef)  THEN 
      CALL xios_get_field_attr(yltag, grid_ref=ylgrid)
      IF (ylgrid(1:4)=='FULL') THEN 
        yldomain='FULL'
      ELSEIF (ylgrid(1:3)=='SEA') THEN 
        yldomain='SEA'
      ELSEIF (ylgrid(1:5)=='WATER') THEN 
        yldomain='WATER'
      ELSEIF (ylgrid(1:6)=='NATURE') THEN 
        yldomain='NATURE'
      ELSEIF (ylgrid(1:4)=='TOWN') THEN 
        yldomain='TOWN'
      ENDIF
    ELSE
      CALL xios_is_defined_field_attr(yltag, domain_ref=glisdef)
      IF (glisdef)  THEN 
        CALL xios_get_field_attr(yltag, domain_ref=yldomain)
      ELSE
        CALL abor1_sfx('SFX_XIOS_SEND_BLOCK : FIELD '//trim(yltag)//' HAS NO DOMAIN')
      ENDIF
    ENDIF
    !
    CALL xios_get_domain_attr(yldomain, data_ni=iidim)
    !
    ylf%ISIZEMAX = iidim
    !
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_5',1,zhook_handle)
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_6',0,zhook_handle)

    infields = 0
    IF (PRESENT(pfield)) THEN
       ylf%ILEV  = 1
       ylf%ILEV2 = 1
       ylf%INDIM = 1
       infields  = infields+1
    ENDIF
    IF (PRESENT(pfield2)) THEN
      ylf%ILEV  = SIZE(pfield2,2)
      ylf%ILEV2 = 1
      ylf%INDIM = 2
      infields  = infields+1
    ENDIF
    IF (PRESENT(pfield3)) THEN
      ylf%ILEV  = SIZE(pfield3,2)
      ylf%ILEV2 = SIZE(pfield3,3)
      ylf%INDIM = 3
      infields  = infields+1
    ENDIF
    IF (infields /= 1 ) &
      CALL abor1_sfx('SFX_XIOS_SEND_BLOCK : TOO FEW OR MANY PFIELDx ARGS FOR '//hdtag)
    ALLOCATE(ylf%ZFIELD(ylf%ISIZEMAX,ylf%ILEV,ylf%ILEV2))
    ylf%ISIZE  = 0
    ylf%IBLOCK = 0
    !
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_6',1,zhook_handle)

  ENDIF
  !
ELSE
  !
  ylf => ylfields(il)
  !
ENDIF
!
IF (lxios_def_closed)  THEN 
  !
  ! Check consistency between calls : discarded for efficiency purpose
  !IF (ILEV .NE. YLF%ILEV) THEN
  !    !   CALL ABOR1_SFX('SFX_XIOS_SEND_BLOCK : INCONSISTENT LEVELS # FOR '//YLTAG)
  !ENDIF
  !
  ! Allocate the data buffer if needed
  !
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_7',0,zhook_handle)
  IF (.NOT. ALLOCATED(ylf%ZFIELD)) THEN
    ALLOCATE(ylf%ZFIELD(ylf%ISIZEMAX,ylf%ILEV,ylf%ILEV2))
  ENDIF
  !
  ! Add the block data to the field buffer and send the field if it is
  ! complete
  !
  IF (ylf%INDIM ==1 ) THEN 
    itake=SIZE(pfield)
  ELSEIF (ylf%INDIM ==2 ) THEN 
    itake=SIZE(pfield2,1)
  ELSEIF (ylf%INDIM ==3 ) THEN 
    itake=SIZE(pfield3,1)
  ENDIF
  !
  ylf%IBLOCK = ylf%IBLOCK+1
  IF ((ylf%ISIZE + itake) > ylf%ISIZEMAX) THEN 
    ! xxx a modifier : le dernier blc arpege arrive avec taille NPROMA
    IF (ylf%IBLOCK .NE. nblock) THEN 
      CALL abor1_sfx("SFX_XIOS_SEND_BLOCK: FIELD "//trim(yltag)//&
              " OVERFLOWS - CHECK ITS DECLARATION TO XIOS (MAYBE TWO INCONSISTENT DECLARATIONS ?)")
    ENDIF
    itake = ylf%ISIZEMAX - ylf%ISIZE 
  ENDIF
  ! Store the field and update its size
  IF (itake > 0 ) THEN 
    IF (ylf%INDIM==1) THEN 
      ylf%ZFIELD(ylf%ISIZE+1:ylf%ISIZE+itake,1,1) = pfield(1:itake)
    ELSEIF (ylf%INDIM==2) THEN 
      ylf%ZFIELD(ylf%ISIZE+1:ylf%ISIZE+itake,:,1) = pfield2(1:itake,:)
    ELSEIF (ylf%INDIM==3) THEN 
      ylf%ZFIELD(ylf%ISIZE+1:ylf%ISIZE+itake,:,:) = pfield3(1:itake,:,:)
    ENDIF
  ELSEIF ( itake < 0 ) THEN
    CALL abor1_sfx('SFX_XIOS_SEND_BLOCK :isizemax < isize')     
  ENDIF
  !
  ylf%ISIZE = ylf%ISIZE + itake
  !
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_7',1,zhook_handle)
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_8',0,zhook_handle)
  IF (ylf%IBLOCK==nblock) THEN
    ! Send field and clears the buffer (incl. de-allocation)
    IF (ylf%INDIM==1) THEN 
      CALL xios_send_field(trim(yltag),ylf%ZFIELD(:,1,1))
    ELSEIF (ylf%INDIM==2) THEN 
      CALL xios_send_field(trim(yltag),ylf%ZFIELD(:,:,1))
    ELSEIF (ylf%INDIM==3) THEN 
      CALL xios_send_field(trim(yltag),ylf%ZFIELD(:,:,:))
    ENDIF
    ylf%IBLOCK = 0
    ylf%ISIZE  = 0
    DEALLOCATE(ylf%ZFIELD)
  ENDIF  
IF (lhook) CALL dr_hook('SFX_XIOS_SEND_BLOCK_8',1,zhook_handle)
ENDIF
!
!$OMP END SINGLE
!
IF (ALLOCATED(ylfields)) DEALLOCATE(ylfields)
!
#endif
!
END SUBROUTINE sfx_xios_send_block