SUBROUTINE MKGLOBSTAB
!****-------------------------------------------------------------------
!**** *MKGLOBSTAB* - create global obs tables needed for message
!****                passing of obs. eq.
!****-------------------------------------------------------------------
!     Interface.
!     ----------
!        *CALL* *MKGLOBSTAB

!     Method.  Find out which processors need to do the interpolation
!     -------  in gridpoint space to obtain the observation equivalents
!              (GOM arrays) for my observations.
!              Do the same for the adjoint where also
!              the halo area is included. Build send and recieve tables
!              to be used in MPOBSEQ and its adjoint. For the adjoint sort
!              by the unique sequence number for reproducibility.

!     Externals.   keysort - sorting routine (ifsaux)
!     ----------   

!     Author.
!     -------
!        Mats Hamrud  *ECMWF*

!     Modifications.
!     --------------
!        Original   : 96-04-01
!     M.Hamrud    : 96-10-01  Modifications for 4-D var
!     E.Andersson : 98-08-18  TOVS control variable
!     W.Sadiki/C.Soci : 99-06 Ecremage pour 3d-Var/Aladin
!     F.Taillefer : 00-10-20  Observation LSM introduction for CANARI
!     E. Holm     : 00-09-19  Retrieved ozone layers added
!     D.Dent      : 00-09-01  convert from MPE to MPL
!     V.Guidard/C.Fischer: 02-09-13 correct rlatobs/rlonobs for LAM/4D
!     S.Saarinen  : 02-06-21 : TOVSCV addr. index taken from ODB's MDB_MAPOMM_AT_INDEX
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     S.Saarinen  : 11-Mar-2004 MLNKH2SAT changed to MLNKH2B
!     M.Hamrud    : 15-Mar-2005 New GOM structures/ almost complete rewrite
!     S. Healy    : 11-May-2005 Changes for 2D operators
!     C.Fischer   : 16-Jun-2005 Bloody Mats ! - forces me to re-introduce Aladin
!     E.Wattrelot : 10-Nov-2006 Changes for baysian inversion of reflectivities
!     R. El Khatib: 31-Aug-2007 Some omp directives disabled if NECSX
!     B. CHAPNIK  : 22-Sep-2008 Removal of LSCREEN condition (for traj in aladin 4Dvar)
!     ------------------------------------------------------------------

USE YOMCT0B,ONLY: LECMWF
USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMLUN   , ONLY : NULOUT   ,NULERR
USE YOMCT0   , ONLY : NPROC    ,NPRINTLEV,LALLOPR  ,LCANARI  ,&
 & NCONF    ,LELAM    ,N_REGIONS ,N_REGIONS_NS , LRPLANE
USE YOMANCS  , ONLY : RMDI
USE YOMCST   , ONLY : RPI
USE YOMDIM   , ONLY : NDGLG    ,NDGSAG   ,NDGENG   ,&
 & NDLUNG   ,NDLUXG   ,NDGUNG  ,NDLSUR   ,NDSUR1   ,NDGSUR   ,&
 & NDGUXG   ,NDGUXL   ,NDLON  
USE YOMDIMO  , ONLY : NOBTOT   ,NOBTOTG  ,NACTIM   ,&
 & NOBTOVG   ,NOBPROF ,NOBPROFG 
USE YOMMP    , ONLY : NPRCIDS  ,MYPROC   ,NSTA     ,&
 & NONL     ,NGPSET2PE ,&
 & NFRSTLAT ,NLSTLAT,NPTRFRSTLAT
USE YOMCOCTP , ONLY : NSATEM   ,NGTHRB
USE YOMGEM   , ONLY : NLOENG   ,NSTTYP
USE YOMLEG   , ONLY : RLATIG   ,RMU      ,RSQM2
! add parameters from geometry for aladin for 2d profiles
! for radar reflectivity
USE YEMGEO , ONLY : ELON1    ,ELAT1    ,ELON2    ,ELAT2    ,&
 & EDELX    ,EDELY    ,ELON0    ,ELAT0    ,ELONC    ,ELATC    ,&
 & LMRT
USE YOMSC2   , ONLY : NOBWIDE
USE YOMGLOBS , ONLY : MAXSENDOBS,MAXRECVOBS ,MTOTSENDOBS ,MAXSENDOBSAD ,&
 & MAXRECVOBSAD,MTOTRECVOBSAD   ,NOBTOTP  ,NTSLTOBP ,&
 & NSTAGLOBS,MTOTRECVOBS,MTOTSENDOBSAD,&
 & NOBSSEND ,NSTASEND ,NCHSEND  ,&
 & NRETSEND ,&
 & RLATSEND ,RLONSEND ,NTYPSEND ,NOBSRECV ,&
 & NSTARECV ,NLOCRECV ,NLOCPROF,NOBSRECVAD ,NSTARECVAD       ,&
 & RLATRECVAD,RLONRECVAD,NTYPRECVAD      ,&
 & NOBSSENDAD,NSTASENDAD,NLOCSENDAD,NLOCPROFAD,NGLOBKEYAD      ,&
 & MAPSENDOBS,MAPRECVOBSAD,NUSEQIND,NUSEQOBS, &
 & LPREMPOBS,NSTRECVTSLAD,NENRECVTSLAD,NENDS,NENDS5
USE YOMECTAB , ONLY : NTSLPT,NOBSPROFS
USE YOMTVRAD , ONLY : TOVSCVBG ,TOVSCVER ,TOVSCVX5  ,NVATOVINDX ,&
 & NVATOVLENG
USE YOMVAR   , ONLY : LTOVSCV  ,NUPTRA   ,LCO2  ,LTSCV, LCLDSINK
USE YOMDB
USE ECSORT_MIX , ONLY : KEYSORT
USE MPL_MODULE , ONLY : MPL_SEND, MPL_RECV, MPL_WAIT, MPL_ALLGATHERV,&
 & JP_BLOCKING_STANDARD, JP_NON_BLOCKING_STANDARD
USE YOMTS    , ONLY : TSCVBG, TSCVX5

IMPLICIT NONE

INTEGER(KIND=JPIM),ALLOCATABLE :: IBUFS(:)  ! Integer send buffer
INTEGER(KIND=JPIM),ALLOCATABLE :: IBUFR(:)  ! Integer receive buffer
INTEGER(KIND=JPIM),ALLOCATABLE :: ISORTTBLAD(:,:) ! Help array for sorting
INTEGER(KIND=JPIM),ALLOCATABLE :: IUSEQAD(:),IUSEQADPROF(:)
INTEGER(KIND=JPIM),ALLOCATABLE :: IBUFS2(:),IBUFR2(:)
REAL(KIND=JPRB)   ,ALLOCATABLE :: ZBUFS2(:),ZBUFR2(:)
INTEGER(KIND=JPIM) :: IBUFS1(2*NACTIM),IBUFR1(2*NACTIM)
REAL(KIND=JPRB),ALLOCATABLE ::   ZLATOBS(:)      ! Latitudes of obs. (global)
REAL(KIND=JPRB),ALLOCATABLE ::   ZLONOBS(:)      ! Longitudes of obs. (global)
REAL(KIND=JPRB),ALLOCATABLE ::   ZLATOBS2(:)      ! Latitudes of obs. (global)
REAL(KIND=JPRB),ALLOCATABLE ::   ZLONOBS2(:)      ! Longitudes of obs. (global)
INTEGER(KIND=JPIM),ALLOCATABLE :: IPROCPROF(:)   ! Proc.no. of obs. (global)
INTEGER(KIND=JPIM),ALLOCATABLE :: IPROCPROFAD(:) ! Proc.no. of obs. (global)
INTEGER(KIND=JPIM),ALLOCATABLE :: IPROCPROFAD_TS(:,:)     ! Proc.no. of obs. per timeslot (global)
INTEGER(KIND=JPIM),ALLOCATABLE :: ITOVINDX(:)    ! TOVS number in global obs array
INTEGER(KIND=JPIM),ALLOCATABLE :: IPROCOBS(:)    ! Proc.no. of obs. (global)
LOGICAL :: LLP,LLTOVSCV
INTEGER(KIND=JPIM) :: IU,IOFF,IOBSPO,IOBS,IBTOT,ILENA,IOBSAD
INTEGER(KIND=JPIM) :: ISEND,ITAG,ILEN,IRECV,IBUFLEN,ISENDREQ,ISENDREQI,ISENDREQZ
INTEGER(KIND=JPIM) :: IOBTOT,IRET,IGLG,IPTW,IPTE,IWRONG1,ILSB,ILFB,IWRONG2
INTEGER(KIND=JPIM) :: ILBEG,ILEND
INTEGER(KIND=JPIM) :: IPROC,IOFFS,IOFFRAD,IOFFG,INOBS,ISTA,IOFFA
INTEGER(KIND=JPIM) :: ICOUNT,ICOUNTAD,ITOV,ITOVGS,ITOVG, &
 & ICDTYPE,IOBSTYPE,IGRP ,ICOUNTP(NPROC),ICOUNTPT(NPROC,NACTIM)
INTEGER(KIND=JPIM) :: JTSLOT,JROC,JOBS,JGL,JSQN,JCOUNT
REAL(KIND=JPRB) ::    ZLATRN,Z,ZLATRS,ZDPISNL,ZLONW,ZLONE,ZLAT,ZLON
INTEGER(KIND=JPIM) :: IRETKODE,IOUNT,IOFFI,IOFFZ,ICDRET,IOFFTS
INTEGER(KIND=JPIM) :: INFO(1),IRECVCOUNTS(NPROC)
INTEGER(KIND=JPIM) :: JA,JB,ISTAL,IENDL,IGLOFF,IPE,IPTZ,IPTI,JROF
INTEGER(KIND=JPIM) :: ISLSENDPOS(1),ISLRECVPOS(1),ISENDPTR(1),IRECVPTR(1),ISLCOMM(1)
INTEGER(KIND=JPIM) :: IOBMAP(4,NDGLG),IOBMAPLEN,IDUM,IDUMO,IDUMA(1)
INTEGER(KIND=JPIM) :: ISLSTA(1-NOBWIDE:NDGENG+NOBWIDE)
INTEGER(KIND=JPIM) :: ISLONL(1-NOBWIDE:NDGENG+NOBWIDE)
INTEGER(KIND=JPIM) :: ISLOFF(1-NOBWIDE:NDGENG+NOBWIDE)
INTEGER(KIND=JPIM) :: IFRSTACTLAT,ILSTACTLAT,IFRSTLOFF,IPTRFLOFF,IMAXPROFTS
INTEGER(KIND=JPIM) :: ISTAPROFS(NACTIM),ITSLTPROF(NACTIM),ITSLTPROFAD(NACTIM),ISTAPROFSAD(NACTIM)
INTEGER(KIND=JPIM) :: IOBSPROF(NOBPROF),IPROFNUM(NOBPROF)
INTEGER(KIND=JPIM) :: ILIMB_ERROR, IRADAR_ERROR
INTEGER(KIND=JPIM),ALLOCATABLE :: IPROFAD(:)
REAL(KIND=JPRB), ALLOCATABLE :: ZLAT_2D(:),ZLON_2D(:), ZGELAM(:), ZGELAT(:), ZGNORX(:), ZGNORY(:)  
REAL(KIND=JPRB), ALLOCATABLE :: ZTLAT_2D(:),ZTLON_2D(:)
REAL(KIND=JPRB)    :: ZEXT,Z2PI,ZELAT1, ZELAT2, ZELON1,& 
&   ZELON2, ZX, ZX1, ZX2, ZY, ZY1, ZY2 ,ZTLON
REAL(KIND=JPRB) :: ZLON1, ZLAT1, ZLON0, ZLAT0, ZLONC, ZLATC, Z180SPI
REAL(KIND=JPRB), ALLOCATABLE :: Z_PGX(:), Z_PGY(:)
INTEGER(KIND=JPIM),ALLOCATABLE :: IOBNUMA(:)
INTEGER(KIND=JPIM) :: IAD
INTEGER(KIND=JPIM),ALLOCATABLE :: IPROFAD_TS(:,:)
REAL(KIND=JPRB) :: ZINFO(1)
REAL(KIND=JPRB) :: ZHOOK_HANDLE


#include "fcobs.h"

INTERFACE
#include "getdb.h"
#include "putdb.h"
#include "abortdb.h"
END INTERFACE

#include "abor1.intfb.h"
#include "slcset.intfb.h"
#include "limb_plane.intfb.h"
#include "radar_profs.intfb.h"
#include "elalo2xy.intfb.h"

#include "openmp_obs.h"
!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('MKGLOBSTAB',0,ZHOOK_HANDLE)
LLTOVSCV = LTOVSCV .AND. NCONF/100 == 1 .AND. NOBTOVG /= 0
LLP = NPRINTLEV >= 1 .OR. LALLOPR
llp =.true.
IU = NULOUT
WRITE(NULOUT,*) 'IN MKGLOBSTAB'
CALL GSTATS(1877,0)
INFO(1) = 0
IF (LLTOVSCV) INFO(1) = 1

CALL GETDB('MKGLOBSTAB', 0, IRETKODE, INFO, 1,ZINFO,0, &
 & -1, -1, -1, -1, -1, -1)  

IF (IRETKODE /= NOBTOT) THEN
  WRITE(NULERR,'('' ** INCONSISTENT NO. OF OBSERVATIONS FROM GETDB'')')
  WRITE(NULERR,*)'Expecting NOBTOT=',NOBTOT,', but got =',IRETKODE
  CALL ABORTDB('MKGLOBSTAB','INCONSISTENCIES FROM GETDB',IRETKODE)
ENDIF




IF(LLTOVSCV) THEN
  TOVSCVBG(:,:)=RMDI
  TOVSCVER(:,:)=RMDI
  TOVSCVX5(:,:)=RMDI
ENDIF

IF (LTSCV) THEN
   TSCVBG(:)=RMDI
   TSCVX5(:)=RMDI
ENDIF

!     ------------------------------------------------------------------
!*      0.  ALLOCATIONS OF ARRAYS
!           ---------------------


ALLOCATE(NOBSSEND(NPROC,NACTIM))
IF(LLP)WRITE(IU,9) 'NOBSSEND ',SIZE(NOBSSEND ),SHAPE(NOBSSEND )
ALLOCATE(NOBSRECV(NPROC,NACTIM))
IF(LLP)WRITE(IU,9) 'NOBSRECV ',SIZE(NOBSRECV ),SHAPE(NOBSRECV )
ALLOCATE(NSTASEND(NPROC,NACTIM))
IF(LLP)WRITE(IU,9) 'NSTASEND ',SIZE(NSTASEND ),SHAPE(NSTASEND )
ALLOCATE(NSTARECV(NPROC,NACTIM))
IF(LLP)WRITE(IU,9) 'NSTARECV ',SIZE(NSTARECV ),SHAPE(NSTARECV )
ALLOCATE(NOBSSENDAD(NPROC,NACTIM))
IF(LLP)WRITE(IU,9) 'NOBSSENDAD',SIZE(NOBSSENDAD),SHAPE(NOBSSENDAD)
ALLOCATE(NOBSRECVAD(NPROC,NACTIM))
IF(LLP)WRITE(IU,9) 'NOBSRECVAD',SIZE(NOBSRECVAD),SHAPE(NOBSRECVAD)
ALLOCATE(NSTASENDAD(NPROC,NACTIM))
IF(LLP)WRITE(IU,9) 'NSTASENDAD',SIZE(NSTASENDAD),SHAPE(NSTASENDAD)
ALLOCATE(NSTARECVAD(NPROC,NACTIM))
IF(LLP)WRITE(IU,9) 'NSTARECVAD',SIZE(NSTARECVAD),SHAPE(NSTARECVAD)
ALLOCATE(MAPSENDOBS(NACTIM))
IF(LLP)WRITE(IU,9) 'MAPSENDOBS',SIZE(MAPSENDOBS),SHAPE(MAPSENDOBS)
ALLOCATE(MAPRECVOBSAD(NACTIM))
IF(LLP)WRITE(IU,9) 'MAPRECVOBSAD',SIZE(MAPRECVOBSAD),SHAPE(MAPRECVOBSAD)
ALLOCATE(NSTRECVTSLAD(NACTIM,NPROC))
IF(LLP)WRITE(IU,9) 'NSTRECVTSLAD',SIZE(NSTRECVTSLAD),SHAPE(NSTRECVTSLAD)
ALLOCATE(NENRECVTSLAD(NACTIM,NPROC))
IF(LLP)WRITE(IU,9) 'NENRECVTSLAD',SIZE(NENRECVTSLAD),SHAPE(NENRECVTSLAD)
ALLOCATE(NENDS(NPROC))
IF(LLP)WRITE(IU,9) 'NENDS',SIZE(NENDS),SHAPE(NENDS)
ALLOCATE(NENDS5(NPROC))
IF(LLP)WRITE(IU,9) 'NENDS5',SIZE(NENDS5),SHAPE(NENDS5)

ALLOCATE(ZLATOBS(NOBPROF))
IF(LLP)WRITE(IU,9) 'ZLATOBS',SIZE(ZLATOBS ),SHAPE(ZLATOBS )
ALLOCATE(ZLONOBS(NOBPROF))
IF(LLP)WRITE(IU,9) 'ZLONOBS',SIZE(ZLONOBS ),SHAPE(ZLONOBS )
ALLOCATE(IPROCPROF(NOBPROF))
IF(LLP)WRITE(IU,9) 'IPROCPROF',SIZE(IPROCPROF ),SHAPE(IPROCPROF )

ALLOCATE(ZLATOBS2(NOBPROF))
IF(LLP)WRITE(IU,9) 'ZLATOBS2',SIZE(ZLATOBS2 ),SHAPE(ZLATOBS2 )
ALLOCATE(ZLONOBS2(NOBPROF))
IF(LLP)WRITE(IU,9) 'ZLONOBS2',SIZE(ZLONOBS2 ),SHAPE(ZLONOBS2 )

!     ------------------------------------------------------------------
!*       1.    FIND ALL POSITIONS WE NEED TO INTERPOLATE TO FOR
!              COMPARISON WITH MY OBSERVATIONS
!              -------------------------------

IF(LELAM) THEN
  ZLATOBS(:)=RMDI
  ZLONOBS(:)=RMDI
ENDIF

IBTOT = 0
ISTAPROFS(:) = 0
ITSLTPROF(:) = 0
DO JTSLOT = 1,NACTIM
  ISTAPROFS(JTSLOT) = IBTOT
  IOBSPO = NTSLPT(JTSLOT)
  DO JOBS = 1,NTSLTOBP(MYPROC,JTSLOT)
    IOBSPO = IOBSPO + 1
    IF ( LELAM .AND. (ROBSU(IOBSPO,MDBTLA) == RMDI .OR. &
       & ROBSU(IOBSPO,MDBTLO) == RMDI) ) THEN  
      CYCLE
    ENDIF
    IOBSTYPE= ROBSU(IOBSPO,MDBOTP)

    IF(NOBSPROFS(IOBSTYPE) > 1) THEN 

! Allocate the arrays of the lat/lon within the 2D plane (sbh)      

      ALLOCATE(ZLAT_2D(NOBSPROFS(IOBSTYPE)))
      ALLOCATE(ZLON_2D(NOBSPROFS(IOBSTYPE)))
      ALLOCATE(ZTLAT_2D(NOBSPROFS(IOBSTYPE)))
      ALLOCATE(ZTLON_2D(NOBSPROFS(IOBSTYPE)))
 
! call the routine that calculates the lat/lons in the vicinity
! of the reflectivity observation (ew)

      IF (IOBSTYPE==13) THEN 
 
      CALL RADAR_PROFS(ROBSU(IOBSPO,MDBLAT),&
&     ROBSU(IOBSPO,MDBLON),&
&     IOBSTYPE,NOBSPROFS(IOBSTYPE),ZLAT_2D,ZLON_2D,IRADAR_ERROR)

! transform lat, lon of my vicinity in X,Y coordinates
! only for the working grid
!         For the limited area model ALADIN

! initial parameter
  Z2PI=2.0_JPRB*RPI
  Z180SPI  = 180._JPRB/RPI
  ZEXT = (15._JPRB*RPI)/180._JPRB
  ZELAT1 = ELAT1 - ZEXT
  ZELAT2 = ELAT2 + ZEXT
  ZELON1 = ELON1 - ZEXT
  ZELON2 = ELON2 + ZEXT

  IF (ZELON1 < 0.0_JPRB) ZELON1 = ZELON1 + Z2PI
  IF (ZELON2 < 0.0_JPRB) ZELON2 = ZELON2 + Z2PI

!  calculation of the limites of the domain C+I in the working grid
  ZX1 = REAL(NDLUNG-1,JPRB)
  ZX2 = REAL(NDLUXG-1,JPRB)
  ZY1 = REAL(NDGUNG-1,JPRB)
  ZY2 = REAL(NDGUXG-1,JPRB)

!  initialisation (X,Y) coordinates to the missing value (RMDI)
!  DO JCOUNT = 1 , NOBSPROFS(IOBSTYPE)
!    IAD = JCOUNT
!    ROBHDR(IAD,MDBTLA) = RMDI
!    ROBHDR(IAD,MDBTLO) = RMDI
!  ENDDO

!  transformation from the sphere to the working grid
  IOBS = 0
  ALLOCATE(Z_PGX(NOBSPROFS(IOBSTYPE)))
  ALLOCATE(Z_PGY(NOBSPROFS(IOBSTYPE)))
  ALLOCATE(IOBNUMA(NOBSPROFS(IOBSTYPE)))
  DO JCOUNT = 1 , NOBSPROFS(IOBSTYPE)
    IAD  = JCOUNT
    ZLAT = ZLAT_2D(JCOUNT)
    ZLON = ZLON_2D(JCOUNT)
    IF (ZLON < 0.0_JPRB) ZLON = ZLON + Z2PI
    IF (ELON1 < 0.0_JPRB .OR. ELON1 > Z2PI) CALL ABOR1('ELON1')
    IF (ELON2 < 0.0_JPRB .OR. ELON2 > Z2PI) CALL ABOR1('ELON2')
    IF (ZLON < 0.0_JPRB .OR. ZLON > Z2PI) CALL ABOR1('ZLON')
    ZTLON = (ZLON-ZELON1)*(ZLON-ZELON2)*(ZELON2-ZELON1)
    IF (ZLAT >= ZELAT1.AND.ZLAT <= ZELAT2.AND.ZTLON <= 0.0_JPRB) THEN
      IOBS          = IOBS+1
      IOBNUMA(IOBS) = JOBS
      Z_PGY(IOBS)     = ZLAT
      Z_PGX(IOBS)     = ZLON
    ELSE
      WRITE(NULOUT,*) 'GREPGEOM Obs at position lat = ',ZLAT_2D(JCOUNT),&
                     &' lon = ',ZLON_2D(JCOUNT),' not found in between corners.'
      ZTLAT_2D(JCOUNT)=ROBSU(IOBSPO,MDBLAT) ! initialisation of profiles corners
      ZTLON_2D(JCOUNT)=ROBSU(IOBSPO,MDBLON) ! initialisation of profiles corners
    ENDIF
  ENDDO
  ILEN = IOBS

  IF (LRPLANE) THEN
    ALLOCATE(ZGELAM(ILEN)) ; ALLOCATE(ZGELAT(ILEN))
    ALLOCATE(ZGNORX(ILEN)) ; ALLOCATE(ZGNORY(ILEN))
    ZGELAM(1:ILEN)=Z_PGX(1:ILEN) ; ZGELAT(1:ILEN)=Z_PGY(1:ILEN)
    ZLON0=ELON0*Z180SPI ; ZLAT0=ELAT0*Z180SPI
    ZLON1=ELON1*Z180SPI ; ZLAT1=ELAT1*Z180SPI
    ZLONC=ELONC*Z180SPI ; ZLATC=ELATC*Z180SPI

    WRITE(NULOUT,*) 'Call ELALO2XY by MKGLOBSTAB for radar vicinity'

    CALL ELALO2XY(ILEN,ZLON0,ZLAT0,ZLON1,ZLAT1,ZLONC,ZLATC,LMRT,ZGELAM,ZGELAT,&
     & Z_PGX,Z_PGY,ZGNORX,ZGNORY)  
    DEALLOCATE(ZGELAM) ; DEALLOCATE(ZGELAT)
    DEALLOCATE(ZGNORX) ; DEALLOCATE(ZGNORY)
  ELSE
    Z_PGX(1:ILEN)=Z_PGX(1:ILEN)-ELON1
    Z_PGY(1:ILEN)=Z_PGY(1:ILEN)-ELAT1
  ENDIF

!  Initial. of the (X,Y) coord. for the obs. inside the C+I domain
  DO JCOUNT = 1 , ILEN
    IAD = IOBNUMA(JCOUNT)
    ZY  = Z_PGY(JCOUNT) / EDELY
    ZX  = Z_PGX(JCOUNT) / EDELX

   IF ( ZX >= ZX1.AND. ZX <= ZX2.AND.ZY >= ZY1.AND. ZY <= ZY2 ) THEN
      ZTLAT_2D(JCOUNT) = ZY
      ZTLON_2D(JCOUNT) = ZX
    ELSE
      WRITE(NULOUT,*) 'GREPGEOM Obs at position lat = ',ZLAT_2D(JCOUNT),&
       & ' lon = ',ZLON_2D(JCOUNT),' not found in C+I in mkglob for radar'
      ZTLAT_2D(JCOUNT) = ZY1
      ZTLON_2D(JCOUNT) = ZX1
    ENDIF
  ENDDO
  DEALLOCATE(Z_PGX)
  DEALLOCATE(Z_PGY)
  DEALLOCATE(IOBNUMA)
! end of transform of my lat, lon of my vicinity in X,Y

        DO JROF=1,NOBSPROFS(IOBSTYPE) 
           ZTLAT_2D(JROF)=ROBSU(IOBSPO,MDBTLA)+1.0_JPRB+(JROF-1.0_JPRB)/2._JPRB
           ZTLON_2D(JROF)=ROBSU(IOBSPO,MDBTLO)+1.0_JPRB+(JROF-1.0_JPRB)/2._JPRB
!            ZLAT_2D(JROF)=ROBSU(IOBSPO,MDBTLA)+1.0_JPRB
!            ZLON_2D(JROF)=ROBSU(IOBSPO,MDBTLO)+1.0_JPRB
!           IF (JROF==1 .OR. JROF==NOBSPROFS(IOBSTYPE)) THEN 
!          WRITE(NULOUT,*)"ZLAT_2D dans mkglobstab",ZTLAT_2D(JROF),ROBSU(IOBSPO,MDBTLA)
!           ENDIF
        ENDDO
      ELSE
 ! call the routine that calculates the lat/lons in the plane (sbh)
  
      CALL LIMB_PLANE(ROBSU(IOBSPO,MDBLAT),ROBSU(IOBSPO,MDBLON),&
      &ROBSU(IOBSPO,MDB_LIMB_AZIMUTH),&
      &IOBSTYPE,NOBSPROFS(IOBSTYPE),ZLAT_2D,ZLON_2D,ILIMB_ERROR)
      
      ENDIF

      DO JROF=1,NOBSPROFS(IOBSTYPE) 
     
        IBTOT = IBTOT+1
        IF (LCANARI .OR. LELAM) THEN
          IF (LELAM)THEN
! adding profiles from radar_profs in radar case
            IF (IOBSTYPE==13) THEN
                ZLATOBS(IBTOT) = ZTLAT_2D(JROF)
                ZLONOBS(IBTOT) = ZTLON_2D(JROF)
            ELSE
! else case of LELAM only in the case of 2D_OPERATOR!!
               ZLATOBS (IBTOT) = ROBSU(IOBSPO,MDBTLA)+1.0_JPRB
               ZLONOBS (IBTOT) = ROBSU(IOBSPO,MDBTLO)+1.0_JPRB
            ENDIF
          ELSE
            ZLATOBS (IBTOT) = ROBSU(IOBSPO,MDBTLA)
            ZLONOBS (IBTOT) = ROBSU(IOBSPO,MDBTLO)
          ENDIF
        ELSE
          IF(NSTTYP > 1) THEN
            ZLATOBS (IBTOT) = ROBSU(IOBSPO,MDBTLA)
            ZLONOBS (IBTOT) = ROBSU(IOBSPO,MDBTLO)
          ELSE

! use the lat-lons calculated in limb_plane (sbh)
  
        IF (ILIMB_ERROR == 0) THEN 
  
               ZLATOBS (IBTOT) = ZLAT_2D(JROF)
               ZLONOBS (IBTOT) = ZLON_2D(JROF)
        
        ELSE

! error in limb_plane 
    
               ZLATOBS (IBTOT) = ROBSU(IOBSPO,MDBLAT) 
               ZLONOBS (IBTOT) = ROBSU(IOBSPO,MDBLON)            

        ENDIF 
  
          ENDIF
        ENDIF
        IOBSPROF(IBTOT) = IOBSPO
        IPROFNUM(IBTOT) = JROF
      ENDDO
      
      DEALLOCATE(ZLAT_2D)
      DEALLOCATE(ZLON_2D)
      DEALLOCATE(ZTLAT_2D)
      DEALLOCATE(ZTLON_2D)
      
    ELSE
      IBTOT = IBTOT+1
      IF (LCANARI .OR. LELAM ) THEN
        IF (LELAM)THEN
          ZLATOBS (IBTOT) = ROBSU(IOBSPO,MDBTLA)+1.0_JPRB
          ZLONOBS (IBTOT) = ROBSU(IOBSPO,MDBTLO)+1.0_JPRB
        ELSE
          ZLATOBS (IBTOT) = ROBSU(IOBSPO,MDBTLA)
          ZLONOBS (IBTOT) = ROBSU(IOBSPO,MDBTLO)
        ENDIF
      ELSE
        IF(NSTTYP > 1) THEN
          ZLATOBS (IBTOT) = ROBSU(IOBSPO,MDBTLA)
          ZLONOBS (IBTOT) = ROBSU(IOBSPO,MDBTLO)
        ELSE
          ZLATOBS (IBTOT) = ROBSU(IOBSPO,MDBLAT)
          ZLONOBS (IBTOT) = ROBSU(IOBSPO,MDBLON)
        ENDIF
      ENDIF
      IOBSPROF(IBTOT) = IOBSPO
      IPROFNUM(IBTOT) = 0
    ENDIF
  ENDDO
  ITSLTPROF(JTSLOT) = IBTOT - ISTAPROFS(JTSLOT)
ENDDO

IF(.NOT.LELAM) THEN
  DO JTSLOT = 1,NACTIM
    IOFF = ISTAPROFS(JTSLOT)
    DO JOBS = 1,ITSLTPROF(JTSLOT)
      ZLATOBS2(IOFF+JOBS) = MAX(-RPI*0.5_JPRB,MIN(RPI*0.5_JPRB,ZLATOBS (IOFF+JOBS)))
      ZLONOBS2(IOFF+JOBS) = MOD(ZLONOBS (IOFF+JOBS) +2.0_JPRB* RPI,2.0_JPRB*RPI)
    ENDDO
  ENDDO
ELSE
  DO JTSLOT = 1,NACTIM
    IOFF = ISTAPROFS(JTSLOT)
    DO JOBS = 1,ITSLTPROF(JTSLOT)
      ZLATOBS2(IOFF+JOBS) = ZLATOBS (IOFF+JOBS)
      ZLONOBS2(IOFF+JOBS) = ZLONOBS (IOFF+JOBS)
    ENDDO
  ENDDO
ENDIF

!     ------------------------------------------------------------------
!*       2.    CONTRUCT SEND AND RECIEVE TABLES.
!              -------------------------------- 

!*       2.1   FIND OUT WHICH PROCESSORS THAT HAVE TO COMPUTE
!              THE OBS.EQ. FOR MY OBSERVATIONS

IPROCPROF(:) = -99
NOBSRECV(:,:) = 0
CALL GSTATS(1877,1)
IF ( LELAM ) THEN

!  Aladin Case (No RLATIG for Aladin)

!!$OMP PARALLEL DO SCHEDULE(STATIC,1)&
!!$OMP&  PRIVATE(JGL,IGLG,ZLATRN,ZLATRS,ZDPISNL,IPTW,ZLONW,IPTE) &
!!$OMP& PRIVATE (ZLONE,JOBS,ZLAT,ZLON)
  DO JA=1,N_REGIONS_NS
    ISTAL=NFRSTLAT(JA)
    IENDL=NLSTLAT(JA)
    IGLOFF=NPTRFRSTLAT(JA)-1 !??
    DO JB=1,N_REGIONS(JA)
      IPE=NGPSET2PE(JA,JB)
      DO JGL = 1,NLSTLAT(JA)-NFRSTLAT(JA)+1
        IGLG=JGL+NFRSTLAT(JA)-1
        IF(IGLG == NDGUNG) THEN
          ZLATRS = REAL(NDGUNG,JPRB)
        ELSE
          ZLATRS = REAL(IGLG-1,JPRB)
        ENDIF
        IF(IGLG == NDGLG) THEN
          ZLATRN = REAL(NDGLG,JPRB)
        ELSE
          ZLATRN = REAL(IGLG,JPRB)
        ENDIF
        IPTW = NSTA(IGLOFF+JGL,JB)
        IPTE = IPTW+NONL(IGLOFF+JGL,JB)-1
        ZLONW = REAL(MAX(NDLUNG,MIN(NDLUXG,IPTW)),JPRB)
        ZLONE = REAL(MAX(NDLUNG,MIN(NDLUXG,IPTE)),JPRB)
        DO JTSLOT = 1,NACTIM
          IOFF = ISTAPROFS(JTSLOT)
          DO JOBS = 1,ITSLTPROF(JTSLOT)
            ZLAT = ZLATOBS(IOFF+JOBS)
            ZLON = ZLONOBS(IOFF+JOBS)
            IF(ZLAT /= RMDI  .AND. ZLON /= RMDI  .AND. &
             & ZLAT <= ZLATRN .AND. ZLAT >= ZLATRS .AND. &
             & ZLON >= ZLONW .AND. ZLON <= ZLONE ) THEN  
              IF(IPROCPROF(IOFF+JOBS) /= -99 .AND. IPROCPROF(IOFF+JOBS) /= IPE ) THEN
                WRITE(NULERR,*) 'MKGLOBSTAB OBS ',JTSLOT,JOBS,' MULTIPLE ASSIGN ', &
                 & IPROCPROF(IOFF+JOBS),IPE
                CALL ABOR1('MKGLOBSTAB:MULTIPLE ASSIGN ')
              ENDIF
!             Processor that has to compute
              IPROCPROF(IOFF+JOBS) = IPE
!             Count how many profiles to recieve for each proc. and timeslot
              NOBSRECV(IPE,JTSLOT) = NOBSRECV(IPE,JTSLOT)+1
            ENDIF
          ENDDO
        ENDDO
      ENDDO
    ENDDO
  ENDDO
!!$OMP END PARALLEL DO

ELSE

  CALL GSTATS(1019,0)
#ifndef NECSX
! This looks like a compiler bug on NEC. REK
!$OMP PARALLEL DO SCHEDULE(STATIC,1)&
!$OMP& PRIVATE (JA,ISTAL,IENDL,IGLOFF,JB,IPE) &
!$OMP& PRIVATE (JGL,IGLG,ZLATRN,ZLATRS,ZDPISNL,IPTW,ZLONW,IPTE) & 
!$OMP& PRIVATE (ZLONE,JTSLOT,IOFF,JOBS,ZLAT,ZLON)
#endif
 DO JA=1,N_REGIONS_NS
    ISTAL=NFRSTLAT(JA)
    IENDL=NLSTLAT(JA)
    IGLOFF=NPTRFRSTLAT(JA)-1 !??
    DO JB=1,N_REGIONS(JA)
      IPE=NGPSET2PE(JA,JB)
      DO JGL = 1,NLSTLAT(JA)-NFRSTLAT(JA)+1
        IGLG=JGL+NFRSTLAT(JA)-1
        IF(IGLG == 1) THEN
          ZLATRN = RPI*0.5_JPRB
        ELSE
          ZLATRN = RLATIG(IGLG)
        ENDIF
        IF(IGLG == NDGLG) THEN
          ZLATRS = -RPI*0.5_JPRB-EPSILON(Z)
        ELSE
          ZLATRS = RLATIG(IGLG+1)
        ENDIF
        ZDPISNL = 2.0_JPRB*RPI/REAL(NLOENG(IGLG),JPRB)
        IPTW = NSTA(IGLOFF+JGL,JB) !??
        ZLONW = ZDPISNL*REAL(IPTW-1,JPRB)
        IPTE = IPTW+NONL(IGLOFF+JGL,JB) !??
        IF(IPTE-1 == NLOENG(IGLG)) THEN
          ZLONE = 2.0_JPRB*RPI
        ELSE
          ZLONE = ZDPISNL*REAL(IPTE-1,JPRB)
        ENDIF
        DO JTSLOT = 1,NACTIM
          IOFF = ISTAPROFS(JTSLOT)
          DO JOBS = 1,ITSLTPROF(JTSLOT)
            ZLAT = ZLATOBS2(IOFF+JOBS)
            IF(ZLAT <= ZLATRN .AND. ZLAT > ZLATRS) THEN
              ZLON = ZLONOBS2(IOFF+JOBS)
              IF(ZLON >= ZLONW .AND. ZLON < ZLONE) THEN  
#ifndef NECSX
!!$                IF(IPROCPROF(IOFF+JOBS) /= -99 .AND. IPROCPROF(IOFF+JOBS) /= IPE ) THEN
!!$                  WRITE(NULERR,*) 'MKGLOBSTAB OBS ',JTSLOT,JOBS,' MULTIPLE ASSIGN ', &
!!$                   & IPROCPROF(IOFF+JOBS),IPE
!!$                  CALL ABOR1('MKGLOBSTAB:MULTIPLE ASSIGN ')
!!$                ENDIF
#endif
                !             Processor that has to compute
                IPROCPROF(IOFF+JOBS) = IPE
                !             Count how many profiles to recieve for each proc. and timeslot
                NOBSRECV(IPE,JTSLOT) = NOBSRECV(IPE,JTSLOT)+1
              ENDIF
            ENDIF
          ENDDO
        ENDDO
      ENDDO
    ENDDO
  ENDDO
#ifndef NECSX
!$OMP END PARALLEL DO
#endif
  CALL GSTATS(1019,1)

ENDIF

IWRONG1 = 0
DO JOBS = 1,NOBPROF
  IF (LELAM .AND. ZLATOBS(JOBS) == RMDI .OR. ZLONOBS(JOBS) == RMDI) CYCLE
  IF(IPROCPROF(JOBS) == -99) THEN
    IWRONG1 = IWRONG1+1
    WRITE(NULERR,'(A,I8,A,2F20.15,A)')&
     &' OBS ',JOBS,' AT ',ZLATOBS (JOBS),ZLONOBS (JOBS),&
     &' NOT FOUND'
  ENDIF
ENDDO
IF(IWRONG1 /= 0) CALL ABOR1('MKGLOBSTAB :IWRONG1 NE 0')

! Start adresses in recieve tables (tables ordered by proc. and timeslot)
IOFFS = 0
DO JTSLOT = 1,NACTIM
  DO JROC = 1,NPROC
    NSTARECV(JROC,JTSLOT) = IOFFS
    IOFFS = IOFFS+NOBSRECV(JROC,JTSLOT)
  ENDDO
ENDDO

!          ADJOINT

NOBSSENDAD(:,:) = 0
ICOUNTAD = 0
ITSLTPROFAD(:) = 0

IF(NCONF /= 1 .AND. NCONF /= 302) THEN
  IF ( LELAM ) THEN
    ALLOCATE(IPROFAD(NOBPROFG+512)) ! Arbitrary large number (we don't know the size)
    ALLOCATE(IPROCPROFAD(NOBPROFG+512))
!  LAM case

!!$OMP PARALLEL DO SCHEDULE(STATIC,1)&
!!$OMP&  PRIVATE(JGL,IGLG,ZLATRN,ZLATRS,ZDPISNL,IPTW,ZLONW,IPTE) &
!!$OMP& PRIVATE (ZLONE,JOBS,ZLAT,ZLON)
    DO JTSLOT = 1,NACTIM
      DO JA=1,N_REGIONS_NS
        IGLOFF = NPTRFRSTLAT(JA)-1 !??
        IFRSTLOFF = NFRSTLAT(JA)-1
        IPTRFLOFF = NPTRFRSTLAT(JA)-1
        ILBEG=NFRSTLAT(JA)-IFRSTLOFF
        ILEND=NLSTLAT (JA)-IFRSTLOFF
        IDUM=1
        DO JB=1,N_REGIONS(JA)
          IFRSTACTLAT = NFRSTLAT(JA)
          ILSTACTLAT = NLSTLAT(JA)
          DO JGL=ILBEG,ILEND
            IF (NONL(IPTRFLOFF+JGL,JB) == 0) THEN
              IFRSTACTLAT = IFRSTACTLAT+1
            ELSE
              EXIT
            ENDIF
          ENDDO
          DO JGL=ILEND,ILBEG,-1
            IF (NONL(IPTRFLOFF+JGL,JB) == 0) THEN
              ILSTACTLAT = ILSTACTLAT-1
            ELSE
              EXIT
            ENDIF
          ENDDO
          IPE=NGPSET2PE(JA,JB)
          CALL SLCSET('OB',NOBWIDE,IDUM,IDUM,JA,JB,&
           & NDGLG,NDLON,NDGSAG,NDGENG,NDGUXL,NDGUXG,1,NDGENG,&
           & NDSUR1,NDLSUR,NDGSUR,IDUM,IDUM,&
           & IPTRFLOFF,IFRSTLOFF,IFRSTACTLAT,ILSTACTLAT,&
           & NSTA,NONL,NLOENG,NPTRFRSTLAT,NFRSTLAT,NLSTLAT,&
           & RMU,RSQM2,&
           & ISLSTA,ISLONL,ISLOFF,IDUMA,IDUMA,IDUMO,&
           & IDUMO,IDUMO,IDUMO,&
           & ISLSENDPOS,ISLRECVPOS,ISENDPTR,IRECVPTR,ISLCOMM,IOBMAP,IOBMAPLEN)
          ILSB = MAX(NDGSAG,IFRSTACTLAT-NOBWIDE)-IFRSTLOFF
          ILFB = MIN(NDGENG,ILSTACTLAT +NOBWIDE)-IFRSTLOFF
          IF(ILFB+(NFRSTLAT(JA)-1) < NDGLG) THEN
            ILFB=ILFB-1
          ENDIF
          DO JGL = ILSB,ILFB
            IGLG = JGL+(NFRSTLAT(JA)-1)
            IF(IGLG < NDGUNG .OR. IGLG > NDGLG) CYCLE
            IF(IGLG == NDGUNG) THEN
              ZLATRS = REAL(NDGUNG,JPRB)-EPSILON(Z)
            ELSE
              ZLATRS = REAL(IGLG-1,JPRB)
            ENDIF
            IF(IGLG == NDGLG) THEN
              ZLATRN = REAL(NDGLG,JPRB)
            ELSE
              ZLATRN = REAL(IGLG,JPRB)
            ENDIF
            IPTW = ISLSTA(JGL)
            IPTE = IPTW+ISLONL(JGL)-1
            ZLONW = REAL(MAX(NDLUNG,MIN(NDLUXG,IPTW)),JPRB)
            ZLONE = REAL(MAX(NDLUNG,MIN(NDLUXG,IPTE)),JPRB)
            IF( ZLONW == ZLONE )THEN
              WRITE(NULERR,'("MKGLOBSTAB: IGLG=",I6," IPTW=",I4," ZLONW=",E25.15,&
               & " IPTE=",I6," ZLONE=",E25.15)')IGLG,IPTW,ZLONW,IPTE,ZLONE  
              CALL ABOR1('MKGLOBSTAB:ZLONW == ZLONE')
            ENDIF
            IOFF = ISTAPROFS(JTSLOT)
            DO JOBS = 1,ITSLTPROF(JTSLOT)
              ZLAT = ZLATOBS(IOFF+JOBS)
              ZLON = ZLONOBS(IOFF+JOBS)
              IF(ZLAT /= RMDI .AND. ZLON /= RMDI .AND. &
               & ZLAT <= ZLATRN .AND. ZLAT > ZLATRS .AND. &
               & ZLON >= ZLONW .AND. ZLON < ZLONE ) THEN  
                ICOUNTAD = ICOUNTAD+1
                IPROFAD(ICOUNTAD) = IOFF+JOBS
                IPROCPROFAD(ICOUNTAD) = IPE
                NOBSSENDAD(IPE,JTSLOT) = NOBSSENDAD(IPE,JTSLOT)+1
                ITSLTPROFAD(JTSLOT) = ITSLTPROFAD(JTSLOT)+1
              ENDIF
            ENDDO
          ENDDO
        ENDDO
      ENDDO
    ENDDO
!!$OMP END PARALLEL DO

  ELSE

    IMAXPROFTS = 1.5_JPRB*MAXVAL(ITSLTPROF(:))+4096
    ALLOCATE(IPROFAD_TS(IMAXPROFTS,NACTIM)) ! Arbitrary large number (we don't know the size)
    ALLOCATE(IPROCPROFAD_TS(IMAXPROFTS,NACTIM))
    CALL GSTATS(1019,0)
!$OMP PARALLEL DO SCHEDULE(STATIC,1)&
!$OMP& PRIVATE (JTSLOT,ICOUNTAD,JA,IGLOFF,IFRSTLOFF,IPTRFLOFF,ILBEG,ILEND,IDUM) &
!$OMP& PRIVATE (JB,IFRSTACTLAT,ILSTACTLAT,JGL,IPE,ISLSTA,ISLONL,ISLOFF,IDUMA,IDUMO) &
!$OMP& PRIVATE (ISLSENDPOS,ISLRECVPOS,ISENDPTR,IRECVPTR,ISLCOMM,IOBMAP,IOBMAPLEN) &
!$OMP& PRIVATE (ILSB,ILFB) &
!$OMP& PRIVATE (IGLG,ZLATRN,ZLATRS,ZDPISNL,IPTW,ZLONW,IPTE) &
!$OMP& PRIVATE (ZLONE,IOFF,JOBS,ZLAT,ZLON)
    DO JTSLOT = 1,NACTIM
      ICOUNTAD = 0
      DO JA=1,N_REGIONS_NS
        IGLOFF = NPTRFRSTLAT(JA)-1 !??
        IFRSTLOFF = NFRSTLAT(JA)-1
        IPTRFLOFF = NPTRFRSTLAT(JA)-1
        ILBEG=NFRSTLAT(JA)-IFRSTLOFF
        ILEND=NLSTLAT (JA)-IFRSTLOFF
        IDUM=1
        DO JB=1,N_REGIONS(JA)
          IFRSTACTLAT = NFRSTLAT(JA)
          ILSTACTLAT = NLSTLAT(JA)
          DO JGL=ILBEG,ILEND
            IF (NONL(IPTRFLOFF+JGL,JB) == 0) THEN
              IFRSTACTLAT = IFRSTACTLAT+1
            ELSE
              EXIT
            ENDIF
          ENDDO
          DO JGL=ILEND,ILBEG,-1
            IF (NONL(IPTRFLOFF+JGL,JB) == 0) THEN
              ILSTACTLAT = ILSTACTLAT-1
            ELSE
              EXIT
            ENDIF
          ENDDO
          IPE=NGPSET2PE(JA,JB)
          CALL SLCSET('OB',NOBWIDE,IDUM,IDUM,JA,JB,&
           & NDGLG,NDLON,NDGSAG,NDGENG,IDUM,NDGUXG,1,NDGENG,&
           & NDSUR1,NDLSUR,NDGSUR,IDUM,IDUM,&
           & IPTRFLOFF,IFRSTLOFF,IFRSTACTLAT,ILSTACTLAT,&
           & NSTA,NONL,NLOENG,NPTRFRSTLAT,NFRSTLAT,NLSTLAT,&
           & RMU,RSQM2,&
           & ISLSTA,ISLONL,ISLOFF,IDUMA,IDUMA,IDUMO,&
           & IDUMO,IDUMO,IDUMO,&
           & ISLSENDPOS,ISLRECVPOS,ISENDPTR,IRECVPTR,ISLCOMM,IOBMAP,IOBMAPLEN)
          ILSB = MAX(NDGSAG,IFRSTACTLAT-NOBWIDE)-IFRSTLOFF
          ILFB = MIN(NDGENG,ILSTACTLAT +NOBWIDE)-IFRSTLOFF
          IF(ILFB+(NFRSTLAT(JA)-1) < NDGLG) THEN
            ILFB=ILFB-1
          ENDIF
          DO JGL = ILSB,ILFB
            IGLG = JGL+(NFRSTLAT(JA)-1)
            IF(IGLG < 1 .OR. IGLG > NDGLG) CYCLE
            IF(IGLG <= 1) THEN
              ZLATRN = RPI*0.5_JPRB
            ELSE
              ZLATRN = RLATIG(IGLG)
            ENDIF
            IF(IGLG >= NDGLG) THEN
              ZLATRS = -RPI*0.5_JPRB-EPSILON(Z)
            ELSE
              ZLATRS = RLATIG(IGLG+1)
            ENDIF
            ZDPISNL = 2.0_JPRB*RPI/REAL(NLOENG(IGLG),JPRB)
            IPTW = ISLSTA(JGL)
            ZLONW = ZDPISNL*REAL(IPTW-1,JPRB)
            ZLONW = MOD(ZLONW +2.0_JPRB* RPI,2.0_JPRB*RPI)
            IPTE = IPTW+ISLONL(JGL)-1
            IF(IPTE == NLOENG(IGLG)) THEN
              ZLONE = 2.0_JPRB*RPI
            ELSE
              ZLONE = ZDPISNL*REAL(IPTE-1,JPRB)
              ZLONE = MOD(ZLONE +2.0_JPRB* RPI,2.0_JPRB*RPI)
            ENDIF
            IF( ZLONW == ZLONE )THEN
              WRITE(NULERR,'("MKGLOBSTAB: IGLG=",I6," IPTW=",I4," ZLONW=",E25.15,&
               & " IPTE=",I6," ZLONE=",E25.15)')IGLG,IPTW,ZLONW,IPTE,ZLONE  
              CALL ABOR1('MKGLOBSTAB:ZLONW == ZLONE')
            ENDIF
            IOFF = ISTAPROFS(JTSLOT)
            DO JOBS = 1,ITSLTPROF(JTSLOT)
              ZLAT = ZLATOBS2(IOFF+JOBS)
              IF (ZLAT <= ZLATRN .AND. ZLAT > ZLATRS) THEN
                ZLON = ZLONOBS2(IOFF+JOBS)
                IF( ( ((ZLONW < ZLONE).AND.(ZLON >= ZLONW .AND. ZLON < ZLONE)).OR.&
               & ((ZLONW > ZLONE).AND.(ZLON >= ZLONW .OR. ZLON < ZLONE)) ) ) THEN
                  ICOUNTAD = ICOUNTAD+1
                  IF(ICOUNTAD > IMAXPROFTS) THEN
                    WRITE(NULERR,*)'JOBS,JTSLOT,IMAXPROFTS ',JOBS,JTSLOT,IMAXPROFTS
                    CALL ABOR1('MKGLOBSTAB:ICOUNTAD > IMAXPROFTS')
                  ENDIF
                  IPROFAD_TS(ICOUNTAD,JTSLOT) = IOFF+JOBS
                  IPROCPROFAD_TS(ICOUNTAD,JTSLOT) = IPE
                  NOBSSENDAD(IPE,JTSLOT) = NOBSSENDAD(IPE,JTSLOT)+1
                  ITSLTPROFAD(JTSLOT) = ITSLTPROFAD(JTSLOT)+1
                ENDIF
              ENDIF
            ENDDO
          ENDDO
        ENDDO
      ENDDO
    ENDDO
!$OMP END PARALLEL DO
    CALL GSTATS(1019,1)

    
    IOBSAD=SUM(NOBSSENDAD(:,:))
    ALLOCATE(IPROFAD(IOBSAD))
    ALLOCATE(IPROCPROFAD(IOBSAD))
    IOFFA=0
    DO JTSLOT = 1,NACTIM
      IOBSAD=SUM(NOBSSENDAD(:,JTSLOT))
      DO JOBS=1,IOBSAD
        IPROFAD(IOFFA+JOBS) = IPROFAD_TS(JOBS,JTSLOT)
        IPROCPROFAD(IOFFA+JOBS) = IPROCPROFAD_TS(JOBS,JTSLOT)
      ENDDO
      IOFFA = IOFFA+IOBSAD
    ENDDO
    DEALLOCATE(IPROFAD_TS)
    DEALLOCATE(IPROCPROFAD_TS)
  ENDIF

  IWRONG2 = 0
  DO JTSLOT = 1,NACTIM
    DO JROC = 1,NPROC
      IF(NOBSSENDAD(JROC,JTSLOT) < NOBSRECV(JROC,JTSLOT)) THEN
        WRITE(NULERR,*)'NOBSSENDAD(JROC,JTSLOT) < NOBSRECV(JROC,JTSLOT)',&
         & JROC,JTSLOT,NOBSSENDAD(JROC,JTSLOT),NOBSRECV(JROC,JTSLOT)
        IWRONG2=IWRONG2+1
      ENDIF
    ENDDO
  ENDDO
  IF(IWRONG2 /= 0) CALL ABOR1('MKGLOBSTAB:IWRONG2 NE 0')
ENDIF

IOFFS = 0
IOFFRAD = 0
DO JTSLOT = 1,NACTIM
  DO JROC = 1,NPROC
    NSTASENDAD(JROC,JTSLOT) = IOFFS
    IOFFS = IOFFS+NOBSSENDAD(JROC,JTSLOT)
  ENDDO
ENDDO
ISTAPROFSAD(1) = 0
DO JTSLOT = 2,NACTIM
  ISTAPROFSAD(JTSLOT) = ISTAPROFSAD(JTSLOT-1)+ITSLTPROFAD(JTSLOT-1)
ENDDO
WRITE(NULOUT,*) 'ITSLTPROFAD ',ITSLTPROFAD
WRITE(NULOUT,*) 'ISTAPROFSAD ',ISTAPROFSAD
  
!*       2.2   BUILD SEND TABLES (RECEIVE FOR ADJOINT) 

!*       2.2.1 NUMBERS OF PROFILES TO SEND AND RECIEVE(ADJOINT)
!              FOR EACH TIMESLOT

NOBSSEND(:,:)   = 0
NOBSRECVAD(:,:) = 0
NOBSSEND(MYPROC,:) = NOBSRECV(MYPROC,:)
NOBSRECVAD(MYPROC,:) = NOBSSENDAD(MYPROC,:) 
ITAG = 9991
ILEN = 2*NACTIM
CALL GSTATS(691,0)
DO JROC=1,NPROC-1
  ISEND = MOD(MYPROC+JROC-1,NPROC)+1
  IBUFS1(1:NACTIM) = NOBSRECV(ISEND,:)
  IBUFS1(NACTIM+1:ILEN) = NOBSSENDAD(ISEND,:)
  CALL MPL_SEND(IBUFS1(1:ILEN),KDEST=NPRCIDS(ISEND),KTAG=ITAG, &
   & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQ, &
   & CDSTRING='MKGLOBSTAB:1')  
  IRECV = MOD(-JROC-1+MYPROC+NPROC,NPROC)+1
  CALL MPL_RECV(IBUFR1(1:ILEN),KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, &
   & KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=IOUNT,CDSTRING='MKGLOBSTAB:1') 
  CALL MPL_WAIT(IBUFS1(1:ILEN),KREQUEST=ISENDREQ,CDSTRING='MKGLOBSTAB:1')
  NOBSSEND(IRECV,:) = IBUFR1(1:NACTIM)
  NOBSRECVAD(IRECV,:) = IBUFR1(NACTIM+1:ILEN)
ENDDO
CALL GSTATS(691,1)
CALL GSTATS(1877,0)

MAXRECVOBS = MAXVAL(NOBSRECV)
MAXSENDOBSAD = MAXVAL(NOBSSENDAD)
MAXSENDOBS = MAXVAL(NOBSSEND)
MTOTSENDOBS = SUM(NOBSSEND)
MAXRECVOBSAD = MAXVAL(NOBSRECVAD)
MTOTRECVOBSAD = SUM(NOBSRECVAD)
MTOTRECVOBS = SUM(NOBSRECV)
MTOTSENDOBSAD = SUM(NOBSSENDAD)
WRITE(NULOUT,'(4(A,I8))')&
 & ' MAXSENDOBS   = ' , MAXSENDOBS,&
 & ' MTOTSENDOBS  = ' , MTOTSENDOBS,&
 & ' MAXRECVOBSAD = ' , MAXRECVOBSAD,&
 & ' MTOTRECVOBSAD= ' , MTOTRECVOBSAD,&    
 & ' MTOTRECVOBS  = ' , MTOTRECVOBS,&    
 & ' MTOTSENDOBSAD= ' , MTOTSENDOBSAD,&    
 & ' MAXRECVOBS   = ' , MAXRECVOBS,&
 & ' MAXSENDOBSAD = ' , MAXSENDOBSAD  

DO JTSLOT = 1,NACTIM
  MAPSENDOBS(JTSLOT) = SUM(NOBSSEND(:,JTSLOT))
  MAPRECVOBSAD(JTSLOT) = SUM(NOBSRECVAD(:,JTSLOT))
ENDDO

!*       2.2.2 ALLOCATIONS

ALLOCATE(RLATSEND(MTOTSENDOBS))
IF(LLP)WRITE(IU,9) 'RLATSEND ',SIZE(RLATSEND ),SHAPE(RLATSEND )
ALLOCATE(RLONSEND(MTOTSENDOBS))
IF(LLP)WRITE(IU,9) 'RLONSEND ',SIZE(RLONSEND ),SHAPE(RLONSEND )
ALLOCATE(NTYPSEND(MTOTSENDOBS))
IF(LLP)WRITE(IU,9) 'NTYPSEND ',SIZE(NTYPSEND ),SHAPE(NTYPSEND )
ALLOCATE(NCHSEND(MTOTSENDOBS))
IF(LLP)WRITE(IU,9) 'NCHSEND  ',SIZE(NCHSEND  ),SHAPE(NCHSEND  )
ALLOCATE(NRETSEND(MTOTSENDOBS))
IF(LLP)WRITE(IU,9) 'NRETSEND ',SIZE(NRETSEND ),SHAPE(NRETSEND )

ALLOCATE(RLATRECVAD(MTOTRECVOBSAD))
IF(LLP)WRITE(IU,9) 'RLATRECVAD',SIZE(RLATRECVAD),SHAPE(RLATRECVAD)
ALLOCATE(RLONRECVAD(MTOTRECVOBSAD))
IF(LLP)WRITE(IU,9) 'RLONRECVAD',SIZE(RLONRECVAD),SHAPE(RLONRECVAD)
ALLOCATE(NLOCRECV(NOBPROF))
IF(LLP)WRITE(IU,9) 'NLOCRECV ',SIZE(NLOCRECV ),SHAPE(NLOCRECV)
ALLOCATE(NLOCPROF(NOBPROF))
IF(LLP)WRITE(IU,9) 'NLOCPROF ',SIZE(NLOCPROF ),SHAPE(NLOCPROF)
ALLOCATE(NLOCSENDAD(MTOTSENDOBSAD))
IF(LLP)WRITE(IU,9) 'NLOCSENDAD',SIZE(NLOCSENDAD),SHAPE(NLOCSENDAD)
ALLOCATE(NLOCPROFAD(MTOTSENDOBSAD))
IF(LLP)WRITE(IU,9) 'NLOCPROFAD',SIZE(NLOCPROFAD),SHAPE(NLOCPROFAD)
ALLOCATE(IUSEQAD(MTOTRECVOBSAD))
IF(LLP)WRITE(IU,9) 'IUSEQAD',SIZE(IUSEQAD),SHAPE(IUSEQAD)
ALLOCATE(IUSEQADPROF(MTOTRECVOBSAD))
IF(LLP)WRITE(IU,9) 'IUSEQAD',SIZE(IUSEQADPROF),SHAPE(IUSEQADPROF)
ALLOCATE(NGLOBKEYAD(MTOTRECVOBSAD))
IF(LLP)WRITE(IU,9) 'NGLOBKEYAD',SIZE(NGLOBKEYAD),SHAPE(NGLOBKEYAD)
ALLOCATE(NTYPRECVAD(MTOTRECVOBSAD))
IF(LLP)WRITE(IU,9) 'NTYPRECVAD',SIZE(NTYPRECVAD),SHAPE(NTYPRECVAD)

!*       2.2.3 COMPUTE START ADRESSES

IOFFS = 0
IOFFRAD = 0
DO JTSLOT = 1,NACTIM
  DO JROC = 1,NPROC
    NSTASEND(JROC,JTSLOT) = IOFFS
    IOFFS = IOFFS+NOBSSEND(JROC,JTSLOT)
    NSTARECVAD(JROC,JTSLOT) = IOFFRAD
    IOFFRAD = IOFFRAD+NOBSRECVAD(JROC,JTSLOT)
  ENDDO
ENDDO
CALL GSTATS(1877,1)

!*       2.2.3 SEND TO ALL OTHER PROCESSORS THE TABLES THEY NEED TO COMPUTE
!              AND SEND ME THE PROFILES I NEED

CALL GSTATS(691,0)
DO JROC=1,NPROC-1
  ISEND = MOD(MYPROC+JROC-1,NPROC)+1
! Fill buffers
  ILEN  = SUM(NOBSRECV(ISEND,:))
  ILENA = SUM(NOBSSENDAD(ISEND,:))
  ALLOCATE(ZBUFS2(2*ILEN+2*ILENA))
  ALLOCATE(IBUFS2(3*ILEN+3*ILENA))
  IPTZ = 0
  IPTI = 0
  DO JTSLOT = 1,NACTIM
!   Direct
    IOFFG = ISTAPROFS(JTSLOT)
    DO JOBS = 1,ITSLTPROF(JTSLOT)
      IPROC = IPROCPROF(IOFFG+JOBS)
      IF (IPROC == ISEND) THEN
        IOBS = IOFFG+JOBS
        IPTZ = IPTZ+1
        ZBUFS2(IPTZ) = ZLATOBS2(IOBS)
        IPTZ = IPTZ+1
        ZBUFS2(IPTZ) = ZLONOBS2(IOBS)
        IOBSPO = IOBSPROF(IOBS)
        IOBSTYPE= ROBSU(IOBSPO,MDBOTP)
        ICDTYPE = ROBSU(IOBSPO,MDB_CODETYPE_AT_HDR)
        IGRP    = ROBSU(IOBSPO,MDB_AREATYPE_AT_HDR)
        IPTI = IPTI+1
        IBUFS2(IPTI) = IGRP*100 + IOBSTYPE
        IPTI = IPTI+1
        IBUFS2(IPTI) = ICDTYPE
        ICDRET = ROBSU(IOBSPO,MDB_RETRTYPE_AT_HDR)
        IPTI = IPTI+1
        IBUFS2(IPTI) = ICDRET
      ENDIF
    ENDDO
!   Adjoint
    IOFFG = ISTAPROFSAD(JTSLOT)
    DO JOBS = 1,ITSLTPROFAD(JTSLOT)
      IPROC = IPROCPROFAD(IOFFG+JOBS)
      IF (IPROC == ISEND) THEN
        IOBS = IPROFAD(IOFFG+JOBS)
        IPTZ = IPTZ+1
        ZBUFS2(IPTZ) = ZLATOBS2(IOBS)
        IPTZ = IPTZ+1
        ZBUFS2(IPTZ) = ZLONOBS2(IOBS)
        IOBSPO = IOBSPROF(IOBS)
        IOBSTYPE = ROBSU(IOBSPO,MDBOTP)
        IGRP     = ROBSU(IOBSPO,MDB_AREATYPE_AT_HDR)
        IPTI = IPTI+1
        IBUFS2(IPTI) = IGRP*100 + IOBSTYPE
        IPTI = IPTI+1
        IBUFS2(IPTI) = ROBSU(IOBSPO,MDBONM)
        IPTI = IPTI+1
        IBUFS2(IPTI) = IPROFNUM(IOBS)
      ENDIF
    ENDDO
  ENDDO
  IF(IPTZ /= SIZE(ZBUFS2)) THEN
    WRITE(NULERR,*) 'IPTZ /= SIZE(ZBUFS2) ',IPTZ,SIZE(ZBUFS2)
    CALL ABOR1('MKGLOBSTAB:IPTZ /= SIZE(ZBUFS2')
  ENDIF
  IF(IPTI /= SIZE(IBUFS2)) THEN
    WRITE(NULERR,*) 'IPTI /= SIZE(IBUFS2) ',IPTI,SIZE(IBUFS2)
    CALL ABOR1('MKGLOBSTAB:IPTI /= SIZE(IBUFS2')
  ENDIF
! Exchange messages
  ITAG  = 9991
  CALL MPL_SEND(ZBUFS2,KDEST=NPRCIDS(ISEND),KTAG=ITAG, &
   & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQZ, &
   & CDSTRING='MKGLOBSTAB:')  
  ITAG  = 9992
  CALL MPL_SEND(IBUFS2,KDEST=NPRCIDS(ISEND),KTAG=ITAG, &
   & KMP_TYPE=JP_NON_BLOCKING_STANDARD,KREQUEST=ISENDREQI, &
   & CDSTRING='MKGLOBSTAB:')  

  IRECV = MOD(-JROC-1+MYPROC+NPROC,NPROC)+1
  ILEN  = SUM(NOBSSEND(IRECV,:))
  ILENA = SUM(NOBSRECVAD(IRECV,:))
  ALLOCATE(ZBUFR2(2*ILEN+2*ILENA))
  ALLOCATE(IBUFR2(3*ILEN+3*ILENA))
  ITAG  = 9991
  CALL MPL_RECV(ZBUFR2,KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, &
   & KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=IOUNT,CDSTRING='MKGLOBSTAB:')  
  ITAG  = 9992
  CALL MPL_RECV(IBUFR2,KSOURCE=NPRCIDS(IRECV),KTAG=ITAG, &
   & KMP_TYPE=JP_BLOCKING_STANDARD,KOUNT=IOUNT,CDSTRING='MKGLOBSTAB:')  
  CALL MPL_WAIT(ZBUFS2,KREQUEST=ISENDREQZ,CDSTRING='MKGLOBSTAB:')
  CALL MPL_WAIT(IBUFS2,KREQUEST=ISENDREQI,CDSTRING='MKGLOBSTAB:')
! Unpack recieved data
  IPTZ = 0
  IPTI = 0
  DO JTSLOT = 1,NACTIM
! Direct
    IOFF = NSTASEND(IRECV,JTSLOT)
    DO JOBS=1,NOBSSEND(IRECV,JTSLOT)
      IPTZ = IPTZ+1
      RLATSEND(IOFF+JOBS) = ZBUFR2(IPTZ)
      IPTZ = IPTZ+1
      RLONSEND(IOFF+JOBS) = ZBUFR2(IPTZ)
      IPTI = IPTI+1
      NTYPSEND(IOFF+JOBS) = IBUFR2(IPTI)
      IPTI = IPTI+1
      NCHSEND(IOFF+JOBS)  = IBUFR2(IPTI)
      IPTI = IPTI+1
      NRETSEND(IOFF+JOBS) = IBUFR2(IPTI)
    ENDDO
! Adjoint
    IOFF = NSTARECVAD(IRECV,JTSLOT)
    DO JOBS=1,NOBSRECVAD(IRECV,JTSLOT)
      IPTZ = IPTZ+1
      RLATRECVAD(IOFF+JOBS) = ZBUFR2(IPTZ)
      IPTZ = IPTZ+1
      RLONRECVAD(IOFF+JOBS) = ZBUFR2(IPTZ)
      IPTI = IPTI+1
      NTYPRECVAD(IOFF+JOBS) = IBUFR2(IPTI)
      IPTI = IPTI+1
      IUSEQAD(IOFF+JOBS) = IBUFR2(IPTI)
      IPTI = IPTI+1
      IUSEQADPROF(IOFF+JOBS) = IBUFR2(IPTI)
    ENDDO
  ENDDO

  IF(IPTZ /= SIZE(ZBUFR2)) THEN
    WRITE(NULERR,*) 'IPTZ /= SIZE(ZBUFR2) ',IPTZ,SIZE(ZBUFR2)
    CALL ABOR1('MKGLOBSTAB:IPTZ /= SIZE(ZBUFR2)')
  ENDIF
  IF(IPTI /= SIZE(IBUFR2)) THEN
    WRITE(NULERR,*) 'IPTI /= SIZE(IBUFR2) ',IPTI,SIZE(IBUFR2)
    CALL ABOR1('MKGLOBSTAB:IPTI /= SIZE(IBUFR2)')
  ENDIF
  DEALLOCATE(ZBUFS2)
  DEALLOCATE(IBUFS2)
  DEALLOCATE(ZBUFR2)
  DEALLOCATE(IBUFR2)
ENDDO ! End of loop over processors
CALL GSTATS(691,1)
CALL GSTATS(1877,0)
! "SEND" TO MYSELF
DO JTSLOT = 1,NACTIM
! Forward
  IOFFG = ISTAPROFS(JTSLOT)
  IOFF = NSTASEND(MYPROC,JTSLOT)
  ICOUNT = 0
  DO JOBS = 1,ITSLTPROF(JTSLOT)
    IPROC = IPROCPROF(IOFFG+JOBS)
    IF (IPROC == MYPROC) THEN
      ICOUNT = ICOUNT+1
      IOBS = IOFFG+JOBS
      RLATSEND(IOFF+ICOUNT) = ZLATOBS2(IOBS)
      RLONSEND(IOFF+ICOUNT) = ZLONOBS2(IOBS)
      IOBSPO = IOBSPROF(IOBS)
      IOBSTYPE= ROBSU(IOBSPO,MDBOTP)
      ICDTYPE = ROBSU(IOBSPO,MDB_CODETYPE_AT_HDR)
      IGRP    = ROBSU(IOBSPO,MDB_AREATYPE_AT_HDR)
      NTYPSEND(IOFF+ICOUNT)= IGRP*100 + IOBSTYPE
      NCHSEND(IOFF+ICOUNT) = ICDTYPE
      ICDRET = ROBSU(IOBSPO,MDB_RETRTYPE_AT_HDR)
      NRETSEND(IOFF+ICOUNT) = ICDRET
    ENDIF
  ENDDO
! Adjoint
  IOFFG = ISTAPROFSAD(JTSLOT)
  IOFF = NSTARECVAD(MYPROC,JTSLOT)
  ICOUNT = 0
  DO JOBS = 1,ITSLTPROFAD(JTSLOT)
    IPROC = IPROCPROFAD(IOFFG+JOBS)
    IF (IPROC == MYPROC) THEN
      ICOUNT = ICOUNT+1
      IOBS = IPROFAD(IOFFG+JOBS)
      RLATRECVAD(IOFF+ICOUNT) = ZLATOBS2(IOBS)
      RLONRECVAD(IOFF+ICOUNT) = ZLONOBS2(IOBS)
      IOBSPO = IOBSPROF(IOBS)
      IOBSTYPE= ROBSU(IOBSPO,MDBOTP)
      ICDTYPE = ROBSU(IOBSPO,MDB_CODETYPE_AT_HDR)
      IGRP    = ROBSU(IOBSPO,MDB_AREATYPE_AT_HDR)
      NTYPRECVAD(IOFF+ICOUNT)= IGRP*100 + IOBSTYPE
      IUSEQAD(IOFF+ICOUNT) = ROBSU(IOBSPO,MDBONM)
      IUSEQADPROF(IOFF+ICOUNT) = IPROFNUM(IOBS)
    ENDIF
  ENDDO
ENDDO

! Local position of profiles recieved
DO JTSLOT = 1,NACTIM
  IOFFG = ISTAPROFS(JTSLOT)
  ICOUNTP(:) = 0
  DO JOBS = 1,ITSLTPROF(JTSLOT)
    IPROC = IPROCPROF(IOFFG+JOBS)
    ICOUNTP(IPROC)=ICOUNTP(IPROC)+1
    IOBS = IOFFG+JOBS
    IOBSPO = IOBSPROF(IOBS)
    IOFF = NSTARECV(IPROC,JTSLOT)
    NLOCRECV(IOFF+ICOUNTP(IPROC)) = IOBSPO-NTSLPT(JTSLOT)
    NLOCPROF(IOFF+ICOUNTP(IPROC)) = IPROFNUM(IOBS)
  ENDDO
ENDDO
! Local position of profiles recieved (adjoint)
DO JTSLOT = 1,NACTIM
  IOFFG = ISTAPROFSAD(JTSLOT)
  ICOUNTP(:) = 0
  DO JOBS = 1,ITSLTPROFAD(JTSLOT)
    IOBS  = IPROFAD(IOFFG+JOBS)
    IPROC = IPROCPROFAD(IOFFG+JOBS)
    ICOUNTP(IPROC)=ICOUNTP(IPROC)+1
    IOBSPO = IOBSPROF(IOBS)
    IOFF = NSTASENDAD(IPROC,JTSLOT)
    NLOCSENDAD(IOFF+ICOUNTP(IPROC)) = IOBSPO-NTSLPT(JTSLOT)
    NLOCPROFAD(IOFF+ICOUNTP(IPROC)) = IPROFNUM(IOBS)
  ENDDO
ENDDO

DEALLOCATE(ZLATOBS)
DEALLOCATE(ZLONOBS)
DEALLOCATE(ZLATOBS2)
DEALLOCATE(ZLONOBS2)
DEALLOCATE(IPROCPROF)
IF (ALLOCATED(IPROCPROFAD)) DEALLOCATE(IPROCPROFAD)
IF (ALLOCATED(IPROFAD))     DEALLOCATE(IPROFAD)
CALL GSTATS(1877,1)

!     ------------------------------------------------------------------
!*       3.    CUMPUTE GLOBAL UNIQUE SEQUENCE NUMBER INDEX
!              -------------------------------------------

IF(LLTOVSCV) THEN
  ALLOCATE(NVATOVINDX(NVATOVLENG))
  IF(LLP)WRITE(IU,9) 'NVATOVINDX',SIZE(NVATOVINDX),SHAPE(NVATOVINDX)
  ALLOCATE(ITOVINDX(NOBTOTG))
  ALLOCATE(IPROCOBS(NOBTOTG))
  ALLOCATE(NUSEQIND(NOBTOTG))
  IF(LLP)WRITE(IU,9) 'NUSEQIND ',SIZE(NUSEQIND ),SHAPE(NUSEQIND )
  ALLOCATE(NUSEQOBS(NOBTOTG))
  IF(LLP)WRITE(IU,9) 'NUSEQOBS ',SIZE(NUSEQOBS ),SHAPE(NUSEQOBS )
  ALLOCATE(NSTAGLOBS(NPROC,NACTIM))
  IF(LLP)WRITE(IU,9) 'NSTAGLOBS',SIZE(NSTAGLOBS),SHAPE(NSTAGLOBS)


!*       3.0   START ADRESSES IN GLOBAL TABLES

  IOFF = 0
  DO JTSLOT = 1,NACTIM
    DO JROC = 1,NPROC
      NSTAGLOBS(JROC,JTSLOT) = IOFF
      IOFF = IOFF+NTSLTOBP(JROC,JTSLOT)
    ENDDO
  ENDDO
  WRITE(NULOUT,'(A,/(10I8))') 'NSTAGLOBS = ',NSTAGLOBS

  DO JTSLOT = 1,NACTIM
    IOFF = NSTAGLOBS(MYPROC,JTSLOT)
    IOBSPO = NTSLPT(JTSLOT)
    DO JOBS = 1,NTSLTOBP(MYPROC,JTSLOT)
      IOBSPO = IOBSPO + 1
      IOBSTYPE= ROBSU(IOBSPO,MDBOTP)
      ICDTYPE = ROBSU(IOBSPO,MDB_CODETYPE_AT_HDR)
      IPROCOBS(IOFF+JOBS) = MYPROC
      NUSEQOBS(IOFF+JOBS) = ROBSU(IOBSPO,MDBONM)

! Fill the constant arrays, related to the TOVS control variable.
! They are BG=background, ER=std of error in bg and X5=trajectory in TL.
      IF(LLTOVSCV .AND. IOBSTYPE == NSATEM) THEN
        IF(ICDTYPE == NGTHRB) THEN
          ITOV=ROBSU(IOBSPO,MDB_MAPOMM_AT_INDEX)
          TOVSCVBG(ITOV,1)=SATPRED(MLNKH2B(IOBSPO),MDB1BCP3A)
          TOVSCVER(ITOV,1)=SATPRED(MLNKH2B(IOBSPO),MDB1BCP13A)
          TOVSCVX5(ITOV,1)=SATPRED(MLNKH2B(IOBSPO),MDB1BCPTS1(NUPTRA+1))
          IF(LCLDSINK) THEN
            TOVSCVBG(ITOV,2)=SATHDR(MLNKH2B(IOBSPO),MDB_CTOPBG_AT_CLOUD_SINK) 
            TOVSCVER(ITOV,2)=SATHDR(MLNKH2B(IOBSPO),MDB_CTOPER_AT_CLOUD_SINK) 
            TOVSCVX5(ITOV,2)=SATHDR(MLNKH2B(IOBSPO),MDB_CTOP_AT_CLOUD_SINK(NUPTRA+1))
            TOVSCVBG(ITOV,3)=SATHDR(MLNKH2B(IOBSPO),MDB_CAMTBG_AT_CLOUD_SINK)
            TOVSCVER(ITOV,3)=SATHDR(MLNKH2B(IOBSPO),MDB_CAMTER_AT_CLOUD_SINK)
            TOVSCVX5(ITOV,3)=SATHDR(MLNKH2B(IOBSPO),MDB_CAMT_AT_CLOUD_SINK(NUPTRA+1))
          ENDIF
          IF(LCO2) THEN
            TOVSCVBG(ITOV,2)=ROBHDR(MLNKH2B(IOBSPO),MDB_CO2BG_S_AT_CO2_SINK)
            TOVSCVER(ITOV,2)=ROBHDR(MLNKH2B(IOBSPO),MDB_CO2ER_S_AT_CO2_SINK)
            TOVSCVX5(ITOV,2)=ROBHDR(MLNKH2B(IOBSPO),MDB_CO2_S_AT_CO2_SINK(NUPTRA+1))
            TOVSCVBG(ITOV,3)=ROBHDR(MLNKH2B(IOBSPO),MDB_CO2BG_T_AT_CO2_SINK)
            TOVSCVER(ITOV,3)=ROBHDR(MLNKH2B(IOBSPO),MDB_CO2ER_T_AT_CO2_SINK)
            TOVSCVX5(ITOV,3)=ROBHDR(MLNKH2B(IOBSPO),MDB_CO2_T_AT_CO2_SINK(NUPTRA+1))
          ENDIF
        ENDIF
      ENDIF
    ENDDO
  ENDDO

!*       3.2   EXCHANGE INFORMATION TO BUILD GLOBAL VIEW

  IF (NPROC > 1) THEN
    ILEN  = 2*NOBTOT
    ALLOCATE(IBUFS(ILEN))
    IRECVCOUNTS(:)=2*NOBTOTP(:)

    IOBS = 0
    DO JTSLOT = 1,NACTIM
      IOFF = NSTAGLOBS(MYPROC,JTSLOT)
!OCL NOVREC
      DO JOBS = 1,NTSLTOBP(MYPROC,JTSLOT)
        IOBS = IOBS+1
        IBUFS(IOBS         ) = NUSEQOBS(IOFF+JOBS)
        IBUFS(IOBS+1*NOBTOT) = IPROCOBS(IOFF+JOBS)
      ENDDO
    ENDDO
    
    IBUFLEN=SUM(IRECVCOUNTS)
    ALLOCATE(IBUFR(IBUFLEN))
    CALL GSTATS(691,0)
    CALL MPL_ALLGATHERV(IBUFS(1:ILEN),IBUFR,IRECVCOUNTS,&
      & CDSTRING='MKGLOBSTAB 2')  
    CALL GSTATS(691,1)
    DEALLOCATE(IBUFS)

    IOFFZ = 0
    IOFFI = 0
    CALL GSTATS(1877,0)
    DO JROC=1,NPROC
      IOBS = 0
      IOBTOT = NOBTOTP(JROC )
      DO JTSLOT = 1,NACTIM
        IOFF = NSTAGLOBS(JROC,JTSLOT)
        DO JOBS = 1,NTSLTOBP(JROC,JTSLOT)
          IOBS = IOBS+1
          NUSEQOBS(IOFF+JOBS) = IBUFR(IOFFI+IOBS+0*IOBTOT)
          IPROCOBS(IOFF+JOBS) = IBUFR(IOFFI+IOBS+1*IOBTOT)
        ENDDO
      ENDDO
      IF (IOBTOT /= IOBS) THEN
        WRITE(NULERR,'(A,2I8)')' MKGLOBSTAB: IOBTOT /= IOBS ',IOBTOT,IOBS
        CALL ABOR1('MKGLOBSTAB: ERROR IN BUILDING GLOBAL VIEW')
      ENDIF
      IOFFI = IOFFI+IOBTOT*2
    ENDDO
    CALL GSTATS(1877,1)
    DEALLOCATE(IBUFR)
  ENDIF
!*       3.3   FIND SORTING INDEX, BY CMA UNIQUE SEQUENCE NUMBER
!              USE TO MAKE THE SUMMATION OF JO-CONTRIBUTIONS REPRODUCIBLE.
!              ALSO DETERMINE ORDER OF TOVS CONTROL VECTOR.

  CALL GSTATS(1957,0)
  IF (NOBTOTG > 0) THEN
    CALL KEYSORT(IRET,NUSEQOBS,NOBTOTG,INDEX=NUSEQIND,INIT=.TRUE.)
    IF (IRET /= NOBTOTG) THEN
      WRITE(NULERR,'(A,2I8)')' MKGLOBSTAB:  KEYSORT#1 ERROR : IRET /= NOBTOTG ',&
        & IRET, NOBTOTG  
      CALL ABOR1('MKGLOBSTAB: KEYSORT#1 ERROR : IRET /= NOBTOTG')
    ENDIF

! The TOVS control variable has to appear sorted by 'CMA global sequence
! number' in the control vector (YVAZX), for reproducible results.
! NVATOVINDX is the sorting index, to be used in dot_product_ctlvec

    
    ITOVINDX(:)=0
    ITOVG=0
    DO JROC = 1,NPROC
      DO JOBS = 1,NOBTOTG
        IF(IPROCOBS(JOBS) /= JROC) CYCLE
        ITOVG=ITOVG+1
        ITOVINDX(JOBS)=ITOVG
      ENDDO
    ENDDO
    
    ITOVGS=0
    DO JSQN = 1,NOBTOTG
      IOBS=NUSEQIND(JSQN)
      ITOVGS=ITOVGS+1
      ITOVG=ITOVINDX(IOBS)
      IF(ITOVG==0)THEN
        WRITE(NULOUT,'("MKGLOBSTAB:ITOVG==0 INVALID")')
        CALL ABOR1('MKGLOBSTAB:ITOVG==0 INVALID')
      ENDIF
      NVATOVINDX(ITOVGS)=ITOVG
    ENDDO
  ENDIF
  CALL GSTATS(1957,1)

  DEALLOCATE(NSTAGLOBS)
  DEALLOCATE(NUSEQOBS)
  DEALLOCATE(NUSEQIND)
  DEALLOCATE(IPROCOBS)
  DEALLOCATE(ITOVINDX)
ENDIF


!     ------------------------------------------------------------------

!*       4.    SORT RECIEVED PROFILES BY UNIQUE SEQUENCE NUMBER TO ENSURE 
!              CONTRIBUTIONS ADDED IN REPRODUCIBLE MANNER IN ADJOINT OF 
!              INTERPOLATION
!              ----------------------------------------------------------------------- 


IF(.NOT.((LELAM.AND.LCANARI) .OR. (NCONF == 1.OR.NCONF == 302))) THEN
  ALLOCATE(ISORTTBLAD(MTOTRECVOBSAD,4))
  IF(LLP)WRITE(IU,9) 'ISORTTBLAD',SIZE(ISORTTBLAD),SHAPE(ISORTTBLAD)

!       4.1 Build sorting array

  ICOUNTPT(:,:) = 0
  DO JTSLOT = 1,NACTIM
    DO JROC = 1,NPROC
      IOFF = NSTARECVAD(JROC,JTSLOT)
      DO JOBS = 1,NOBSRECVAD(JROC,JTSLOT)
        ICOUNTPT(JROC,JTSLOT) = ICOUNTPT(JROC,JTSLOT)+1
        IOFF = NSTARECVAD(JROC,JTSLOT)+ICOUNTPT(JROC,JTSLOT)
        ISORTTBLAD(IOFF,1) = ICOUNTPT(JROC,JTSLOT)
        ISORTTBLAD(IOFF,2) = JROC
        ISORTTBLAD(IOFF,3) = IUSEQAD(IOFF)
        ISORTTBLAD(IOFF,4) = IUSEQADPROF(IOFF)
      ENDDO
    ENDDO
  ENDDO

!*       4.2 SORT BY UNIQUE SEQUENCE NUMBER FOR ADJOINT


  DO JTSLOT = 1,NACTIM
    INOBS = MAPRECVOBSAD(JTSLOT)
    IOFFTS = NSTARECVAD(1,JTSLOT)
    ISTA  = IOFFTS+1
    IF (INOBS > 0) THEN
      CALL KEYSORT(IRET,ISORTTBLAD(ISTA:ISTA+INOBS-1,:),INOBS,&
       & MULTIKEY=(/3,4/))
      IF (IRET /= INOBS) THEN
        WRITE(NULERR,'(A,2I8,A,I5)') &
         & ' MKGLOBSTAB:  KEYSORT#2 ERROR : IRET /= INOBS ',&
         & IRET, INOBS, '; JTSLOT, NACTIM=',JTSLOT, NACTIM  
        CALL ABOR1('MKGLOBSTAB: KEYSORT#2 ERROR : IRET /= INOBS')
      ENDIF
      DO JOBS = 1,INOBS
        IOFF = NSTARECVAD(ISORTTBLAD(ISTA+JOBS-1,2),JTSLOT)
        NGLOBKEYAD(IOFF+ISORTTBLAD(ISTA+JOBS-1,1)) = JOBS
      ENDDO
    ENDIF
  ENDDO
  DEALLOCATE(ISORTTBLAD)
  IF(LLP)WRITE(IU,19) 'ISORTTBLAD'
ENDIF
IF(LECMWF) THEN
  LPREMPOBS = .TRUE.
ELSEIF(NCONF == 131) THEN
  LPREMPOBS = .TRUE.
ELSE
  LPREMPOBS = .FALSE.
ENDIF
!     ------------------------------------------------------------------
!*       5.  PRINTS

WRITE(NULOUT,*) 'LPREMPOBS =',LPREMPOBS
DO JTSLOT = 1,NACTIM
  WRITE(NULOUT,'(A,I6)') ' TIMESLOT NO ',JTSLOT
  WRITE(NULOUT,'(A,/(10I8))') ' NSTASEND= ',NSTASEND(:,JTSLOT)
  WRITE(NULOUT,'(A,/(10I8))') ' NSTARECV= ',NSTARECV(:,JTSLOT)
  WRITE(NULOUT,'(A,/(10I8))') ' NOBSSEND= ',NOBSSEND(:,JTSLOT)
  WRITE(NULOUT,'(A,/(10I8))') ' NOBSRECV= ',NOBSRECV(:,JTSLOT)
  IF(NCONF /= 1 .AND. NCONF /= 302) THEN
    WRITE(NULOUT,'(A,/(10I8))') ' NSTASENDAD= ',NSTASENDAD(:,JTSLOT)
    WRITE(NULOUT,'(A,/(10I8))') ' NSTARECVAD= ',NSTARECVAD(:,JTSLOT)
    WRITE(NULOUT,'(A,/(10I8))') ' NOBSSENDAD= ',NOBSSENDAD(:,JTSLOT)
    WRITE(NULOUT,'(A,/(10I8))') ' NOBSRECVAD= ',NOBSRECVAD(:,JTSLOT)
  ENDIF
ENDDO

!     ------------------------------------------------------------------
9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)
19 FORMAT(1X,'ARRAY ',A10,' DEALLOCATED ')

CALL GSTATS(1783,0)
CALL PUTDB('MKGLOBSTAB', 0, IRETKODE, INFO, 0,ZINFO,0)
CALL GSTATS(1783,1)

IF (LHOOK) CALL DR_HOOK('MKGLOBSTAB',1,ZHOOK_HANDLE)
END SUBROUTINE MKGLOBSTAB
