org_charac_type1.F

Go to the documentation of this file.

!                   ***************************
                    SUBROUTINE org_charac_type1
!                   ***************************
!
     &(nomb,characteristic)
!
!***********************************************************************
! PARALLEL   V6P3                                   21/08/2010
!***********************************************************************
!
!brief    MPI TYPE FOR TYPE CHARAC_TYPE - CHARACTERISTICS /
!
!history  C. DENIS
!+        01/07/2011
!+        V6P1
!+
!
!history  N.DURAND (HRW), S.E.BOURBAN (HRW)
!+        13/07/2010
!+        V6P0
!+   Translation of French comments within the FORTRAN sources into
!+   English comments
!
!history  N.DURAND (HRW), S.E.BOURBAN (HRW)
!+        21/08/2010
!+        V6P0
!+   Creation of DOXYGEN tags for automated documentation and
!+   cross-referencing of the FORTRAN sources
!
!history  J-M HERVOUET
!+        22/06/2012
!+        V6P2
!+   DX,DY and DZ added. Problem of integer 8 treated as a double
!+   solved. Much clearer now.
!+
!history  J-M HERVOUET
!+        04/10/2012
!+        V6P3
!+   NOMB = 0 now allowed
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!| NOMB           |<---| NUMBER OF VARIABLES
!| CHARACTERISTIC |--->| DATATYPE FOR CHARACTERISTIC
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
      USE declarations_parallel
      USE declarations_special
      USE interface_parallel, ONLY : p_mpi_type_get_extent,
     &     p_mpi_type_create_struct, p_mpi_type_commit
      IMPLICIT NONE
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER, INTENT(IN)    :: NOMB
      INTEGER, INTENT(INOUT) :: CHARACTERISTIC
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
#if defined HAVE_MPI
      INTEGER, PARAMETER :: MAX_BASKET_SIZE=10
!
!     ARRAY OF DISPLACEMENTS BETWEEN BASIC COMPONENTS, HERE INITIALISED ONLY
!
!      INTEGER (KIND=MPI_ADDRESS_KIND), DIMENSION(18) :: CH_DELTA
      INTEGER (KIND=MY_ADDRESS_KIND), DIMENSION(18) :: CH_DELTA
!
!     ARRAY OF BLOCKLENGTHS OF TYPE COMPONENTS, BASKET INITIALISED TO 1
!
      INTEGER, DIMENSION(18) :: CH_BLENGTH
!     ARRAY OF COMPONENT TYPES IN TERMS OF THE MPI COMMUNICATION
      INTEGER, DIMENSION(18) :: CH_TYPES
      INTEGER IER
!      INTEGER (KIND=MPI_ADDRESS_KIND) :: EXTENT,ILB,IUB,INTEX
      INTEGER (KIND=MY_ADDRESS_KIND) :: EXTENT,ILB,IUB,INTEX
!
      INTEGER I
!
      ch_blength=(/1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1/)
      ch_delta=  (/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/)
!
!     TERMINATE ON MPI PARTS NOT HANDLED BY COMPAD
#  if defined COMPAD
      WRITE(lu,*) 'ORG_CHARAC_TYPE1: COMPAD MAYBE CRITICAL',
     &     'MPI OPERATION'
      WRITE(lu,*) '  PLEASE CONTACT JR @ ADJOINTWARE'
      CALL plante(1)
      stop
#  endif
!     INTEGERS IN THE STRUCTURE
!
      CALL p_mpi_type_get_extent(mpi_integer,ilb,intex,ier)
      ch_delta(1)=0
!     9 IS THE FIRST DOUBLE PRECISION THAT COMES AFTER AN INTEGER
      DO i=2,9
        ch_delta(i)=ch_delta(i-1)+intex
      ENDDO
!
!     DOUBLE PRECISION IN THE STRUCTURE
!
!     Handle components of active data type correctly
#  if defined COMPAD
      CALL p_mpi_type_get_extent(ampi_type,ilb,intex,ier)
#  else
      CALL p_mpi_type_get_extent(mpi_double_precision,ilb,intex,ier)
#  endif
!     THE SIX REMAINING DOUBLE PRECISION (INCLUDING BASKET)
      DO i=10,17
        ch_delta(i)=ch_delta(i-1)+intex
      ENDDO
!     ADDRESS AFTER THE BASKET
      ch_delta(18)=ch_delta(17)+intex*max_basket_size
!
      IF(nomb.GE.0.AND.nomb.LE.max_basket_size) THEN
        ch_blength(17) = nomb  ! CH%BASKET RANGE APPLIED FOR COMMUNICATION
      ELSE
        WRITE(lu,*) ' PARALLEL::ORG_CHARAC_TYPE1::',
     &        ' NOMB NOT IN RANGE [0..MAX_BASKET_SIZE]'
        WRITE(lu,*) ' MAX_BASKET_SIZE, NOMB: ',max_basket_size,nomb
        CALL plante(1)
        stop
      ENDIF
      ch_types(1)=mpi_integer
      ch_types(2)=mpi_integer
      ch_types(3)=mpi_integer
      ch_types(4)=mpi_integer
      ch_types(5)=mpi_integer
      ch_types(6)=mpi_integer
      ch_types(7)=mpi_integer
      ch_types(8)=mpi_integer
!     Handle components of active data type correctly
#  if defined COMPAD
      ch_types(9)=ampi_type
      ch_types(10)=ampi_type
      ch_types(11)=ampi_type
      ch_types(12)=ampi_type
      ch_types(13)=ampi_type
      ch_types(14)=ampi_type
      ch_types(15)=ampi_type
      ch_types(16)=ampi_type
      ch_types(17)=ampi_type
#  else
      ch_types(9)=mpi_double_precision
      ch_types(10)=mpi_double_precision
      ch_types(11)=mpi_double_precision
      ch_types(12)=mpi_double_precision
      ch_types(13)=mpi_double_precision
      ch_types(14)=mpi_double_precision
      ch_types(15)=mpi_double_precision
      ch_types(16)=mpi_double_precision
      ch_types(17)=mpi_double_precision
#  endif
      ch_types(18)=mpi_ub       ! THE TYPE UPPER BOUND MARKER
      CALL p_mpi_type_create_struct(18,ch_blength,ch_delta,ch_types,
     &                              characteristic,ier)
      CALL p_mpi_type_commit(characteristic,ier)
      CALL p_mpi_type_get_extent(characteristic,ilb,extent,ier)
      iub=ilb+extent
!
      IF(ilb.NE.ch_delta(1).OR.iub.NE.ch_delta(18)) THEN
        WRITE(lu,*) ' PARALLEL::ORG_CHARAC_TYPE1:'
        WRITE(lu,*) ' MEMORY PROBLEM WITH THIS COMPILER: '
        WRITE(lu,*) ' ILB=',ilb,' NOT EQUAL TO CH_DELTA(1)=',
     &        ch_delta(1)
        WRITE(lu,*) ' OR'
        WRITE(lu,*) ' IUB=',iub,' NOT EQUAL TO CH_DELTA(18)=',
     &        ch_delta(18)
        CALL plante(1)
        stop
      ENDIF
#else
      WRITE(lu,*) 'CALL OF ORG_CHARAC_TYPE1, VOID VERSION'
#endif
!
!----------------------------------------------------------------------
!
      RETURN
      END SUBROUTINE org_charac_type1