suecradi15.F90

Go to the documentation of this file.

!OPTIONS XOPT(NOEVAL)
SUBROUTINE suecradi15

!**** *SUECRADI15* - INITIALIZE DATA STRUCTURES FOR RADIATION INTERPOL.
!****                FROZEN VERSION (CYCLE 15) OF SUECRADI

!     PURPOSE.
!     --------
!           INITIALIZE DATA STRUCTURES FOR RADIATION INTERPOLATION

!**   INTERFACE.
!     ----------
!        CALL *SUECRADI15* FROM *SUECRAD15*
!              ----------        ---------

!        EXPLICIT ARGUMENTS :
!        --------------------
!        NONE

!        IMPLICIT ARGUMENTS :
!        --------------------

!     METHOD.
!     -------
!        SEE DOCUMENTATION

!     EXTERNALS.
!     ----------
!        NONE

!     REFERENCE.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     AUTHOR.
!     -------
!        96-11: Ph. Dandin. Meteo-France
!        ORIGINAL BY GEORGE MOZDZYNSKI 95-03-13

!     MODIFICATIONS.
!     --------------
!        M.Hamrud      01-Oct-2003 CY28 Cleaning

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

USE parkind1  ,ONLY : jpim     ,jprb
USE yomhook   ,ONLY : lhook,   dr_hook

USE parrint  , ONLY : jpradcw  ,jpradce
USE yomdim   , ONLY : ndgsag   ,ndgsal   ,ndgeng   ,ndgenl   ,ndlon
USE yomct0   , ONLY : n_regions_ns    ,n_regions_ew
USE yomlun   , ONLY : nulout
USE yomgem   , ONLY : nloen    ,nloeng
USE yomrad15 , ONLY : naer15   ,nflux15  ,nmode15  ,nrad15   ,&
 & nradfr15 ,nradpfr15,nradpla15,nrint15  ,novlp15  ,&
 & nrproma15,nradf2c15,nradc2f15,lerad6h15,leradhs15 ,&
 & lradaer15,lnewaer15
USE yommp    , ONLY : lsplit   ,my_region_ns   ,my_region_ew   ,nsta     ,&
 & nonl     ,nptrfrstlat,nptrlstlat,nfrstlat ,nlstlat  ,&
 & lsplitlat  
USE yomprad  , ONLY : lodbgradi,lodbgradl,nrirint  ,nrfrstoff,&
 & nrlastoff,nrimax   ,nrimaxt  ,nrcneedw ,nrcneede ,&
 & nrcsndw  ,nrcsnde  ,nrcrcvw  ,nrcrcve  ,nrcsndt  ,&
 & nrcrcvt  ,nrcrcvwo ,nrcrcveo  

IMPLICIT NONE

#include "namrad15.h"

INTEGER(KIND=JPIM) :: ILWA (2*n_regions_ew)
INTEGER(KIND=JPIM) :: ILWB (2*n_regions_ew)
INTEGER(KIND=JPIM) :: ILWBI(2*n_regions_ew)
INTEGER(KIND=JPIM) :: ILEA (2*n_regions_ew)
INTEGER(KIND=JPIM) :: ILEB (2*n_regions_ew)
INTEGER(KIND=JPIM) :: ILEBI(2*n_regions_ew)
INTEGER(KIND=JPIM) :: ISTA(ndgenl,2*n_regions_ew)
INTEGER(KIND=JPIM) :: IONL(ndgenl,2*n_regions_ew)
CHARACTER (LEN = 14) ::  CLDBG

INTEGER(KIND=JPIM) :: IAO, IAOFF, IB, IB1, IB2, IB3, IB4, IB5,&
 & IB6, ICNEED, ICTAKE, IGL, IJBXBOFF, IJBXSETA, &
 & ILE, ILEN, ILONS, ILW, IMAX, IMAXC, IMAXT, &
 & IOTHBOFF, IOTHSETA, IPROCB, IRINT, IUNIT, &
 & JA, JB, JBE, JBW, JBX, JF, JGL, JGLGLO, JL  

LOGICAL :: LLMESS, LLMYSETAISWEST
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

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

IF (lhook) CALL dr_hook('SUECRADI15',0,zhook_handle)
llmess=.false.
iunit=0
ALLOCATE(nrirint(ndgsag:ndgeng))
WRITE(nulout,9990) 'NRIRINT  ',SIZE(nrirint),shape(nrirint)
ALLOCATE(nrimax(ndgsag:ndgeng,2*n_regions_ew))
WRITE(nulout,9990) 'NRIMAX',SIZE(nrimax),shape(nrimax)
IF( llmess )THEN
  ALLOCATE(nrfrstoff(ndgsag:ndgeng,2*n_regions_ew))
  WRITE(nulout,9990) 'NRFRSTOFF',SIZE(nrfrstoff),shape(nrfrstoff)
  ALLOCATE(nrlastoff(ndgsag:ndgeng,2*n_regions_ew))
  WRITE(nulout,9990) 'NRLASTOFF',SIZE(nrlastoff),shape(nrlastoff)
  ALLOCATE(nrimax(ndgsag:ndgeng,2*n_regions_ew))
  WRITE(nulout,9990) 'NRIMAX',SIZE(nrimax),shape(nrimax)
  ALLOCATE(nrcneedw(ndgsag:ndgeng,2*n_regions_ew))
  WRITE(nulout,9990) 'NRCNEEDW',SIZE(nrcneedw),shape(nrcneedw)
  ALLOCATE(nrcneede(ndgsag:ndgeng,2*n_regions_ew))
  WRITE(nulout,9990) 'NRCNEEDE',SIZE(nrcneede),shape(nrcneede)
  ALLOCATE(nrcsndw(ndgsag:ndgeng,n_regions_ew,-1:1))
  WRITE(nulout,9990) 'NRCSNDW',SIZE(nrcsndw),shape(nrcsndw)
  ALLOCATE(nrcsnde(ndgsag:ndgeng,n_regions_ew,-1:1))
  WRITE(nulout,9990) 'NRCSNDE',SIZE(nrcsnde),shape(nrcsnde)
  ALLOCATE(nrcrcvw(ndgsag:ndgeng,n_regions_ew,-1:1))
  WRITE(nulout,9990) 'NRCRCVW',SIZE(nrcrcvw),shape(nrcrcvw)
  ALLOCATE(nrcrcve(ndgsag:ndgeng,n_regions_ew,-1:1))
  WRITE(nulout,9990) 'NRCRCVE',SIZE(nrcrcve),shape(nrcrcve)
  ALLOCATE(nrcsndt(n_regions_ew,-1:1))
  WRITE(nulout,9990) 'NRCSNDT',SIZE(nrcsndt),shape(nrcsndt)
  ALLOCATE(nrcrcvt(n_regions_ew,-1:1))
  WRITE(nulout,9990) 'NRCRCVT',SIZE(nrcrcvt),shape(nrcrcvt)
  ALLOCATE(nrcrcvwo(ndgsag:ndgeng,n_regions_ew,-1:1))
  WRITE(nulout,9990) 'NRCRCVWO',SIZE(nrcrcvwo),shape(nrcrcvwo)
  ALLOCATE(nrcrcveo(ndgsag:ndgeng,n_regions_ew,-1:1))
  WRITE(nulout,9990) 'NRCRCVEO',SIZE(nrcrcveo),shape(nrcrcveo)
ENDIF
9990 FORMAT(1x,'ARRAY ',a10,' ALLOCATED ',8i8)

IF( llmess )THEN

  IF( nrint15 > 1.AND. (nradf2c15 == 1.OR. nradc2f15 == 1))THEN
    IF( lsplit .AND. n_regions_ns > 1 )THEN
      WRITE(nulout,'("SUECRAD: FFT INTERPOLATION UNSUPPORTED",&
       & " WITH LSPLIT")')  
      CALL abor1('FFT INTERPOLATION UNSUPPORTED WITH LSPLIT')
    ENDIF
    IF( n_regions_ew > 1 )THEN
      WRITE(nulout,'("SUECRAD: FFT INTERPOLATION UNSUPPORTED",&
       & " WITH N_REGIONS_EW > 1")')  
      CALL abor1('FFT INTERPOLATION UNSUPPORTED WITH N_REGIONS_EW > 1')
    ENDIF
  ENDIF

! INITIALISE GENERAL DATA STRUCTURES REQUIRED FOR RAD. INTERPOLATION

  DO jgl=ndgsag,ndgeng
    nrirint(jgl)=0
  ENDDO
  DO jb=1,2*n_regions_ew
    DO jgl=ndgsag,ndgeng
      nrfrstoff(jgl,jb)=0
      nrlastoff(jgl,jb)=0
      nrimax(jgl,jb)=0
      nrcneedw(jgl,jb)=0
      nrcneede(jgl,jb)=0
    ENDDO
  ENDDO
  nrimaxt=0
  DO ja=-1,1
    DO jb=1,n_regions_ew
      DO jgl=ndgsag,ndgeng
        nrcsndw(jgl,jb,ja)=0
        nrcsnde(jgl,jb,ja)=0
        nrcrcvw(jgl,jb,ja)=0
        nrcrcve(jgl,jb,ja)=0
        nrcrcvwo(jgl,jb,ja)=0
        nrcrcveo(jgl,jb,ja)=0
      ENDDO
    ENDDO
  ENDDO
  DO ja=-1,1
    DO jb=1,n_regions_ew
      nrcsndt(jb,ja)=0
      nrcrcvt(jb,ja)=0
    ENDDO
  ENDDO

  DO jb=1,2*n_regions_ew
    DO jgl=1,ndgenl
      ista(jgl,jb)=0
      ionl(jgl,jb)=0
    ENDDO
  ENDDO
  DO jb=1,n_regions_ew
    DO jgl=1,ndgenl
      igl=nptrfrstlat(my_region_ns)-1+jgl
      ista(jgl,jb)=nsta(igl,jb)
      ionl(jgl,jb)=nonl(igl,jb)
    ENDDO
  ENDDO
  IF( lsplitlat(nfrstlat(my_region_ns)) )THEN
    llmysetaiswest=.false.
    DO jb=1,n_regions_ew
      IF( nsta(nptrfrstlat(my_region_ns),jb) == 1 )THEN
        llmysetaiswest=.true.
      ENDIF
    ENDDO
    IF( llmysetaiswest )THEN
      DO jb=1,n_regions_ew
        igl=nptrfrstlat(my_region_ns+1)
        ista(1,jb+n_regions_ew)=nsta(igl,jb)
        ionl(1,jb+n_regions_ew)=nonl(igl,jb)
      ENDDO
    ELSE
      DO jb=1,n_regions_ew
        igl=nptrfrstlat(my_region_ns)-1
        ista(1,jb+n_regions_ew)=nsta(igl,jb)
        ionl(1,jb+n_regions_ew)=nonl(igl,jb)
      ENDDO
    ENDIF
  ENDIF
  IF( lsplitlat(nlstlat(my_region_ns)) )THEN
    llmysetaiswest=.false.
    DO jb=1,n_regions_ew
      IF( nsta(nptrlstlat(my_region_ns),jb) == 1 )THEN
        llmysetaiswest=.true.
      ENDIF
    ENDDO
    IF( llmysetaiswest )THEN
      DO jb=1,n_regions_ew
        igl=nptrfrstlat(my_region_ns+1)
        ista(ndgenl,jb+n_regions_ew)=nsta(igl,jb)
        ionl(ndgenl,jb+n_regions_ew)=nonl(igl,jb)
      ENDDO
    ELSE
      DO jb=1,n_regions_ew
        igl=nptrfrstlat(my_region_ns)-1
        ista(ndgenl,jb+n_regions_ew)=nsta(igl,jb)
        ionl(ndgenl,jb+n_regions_ew)=nonl(igl,jb)
      ENDDO
    ENDIF
  ENDIF

ELSE

  ilen=ndgeng-ndgsag+1
  DO jgl=ndgsag,ndgeng
    nrirint(jgl)=0
    nrimax(jgl,1)=0
  ENDDO

ENDIF

imaxc=ndlon/nrint15+6
imaxc=imaxc+(1-mod(imaxc,2))

IF( llmess )THEN
  IF( lodbgradi )THEN
    iunit=10
    WRITE(cldbg,'("debug_a",I3.3,"b",I3.3)')my_region_ns,my_region_ew
    OPEN(unit=iunit,file=cldbg)
    WRITE(iunit,'("SUECRADI: MY_REGION_NS=",I4," MY_REGION_EW=",I4)')my_region_ns,my_region_ew
    WRITE(iunit,'("SUECRADI: NDGSAL=",I4," NDGENL=",I4)') ndgsal,ndgenl
    WRITE(iunit,'("SUECRADI: ")')
  ENDIF
ENDIF

! LOOP OVER OUR PARTITION LATITUDES, TO INITIALISE SIMPLE ITEMS

IF( llmess )THEN

  imaxt=0

  DO jgl=1,ndgenl

    jglglo=nfrstlat(my_region_ns)+jgl-1
    ilons=nloeng(jglglo)

    irint=1
    DO jf=1,nrint15
      IF( mod(ilons,jf) == 0.AND.ilons/jf <= imaxc )THEN
        irint=jf
        GO TO 220
      ENDIF
    ENDDO
    220 CONTINUE
    nrirint(jgl)=irint

    IF( lodbgradi )THEN
      WRITE(iunit,'("SUECRADI: JGLGLO=",I4," JGL=",I4,&
       & " NLOENG=",I4," NRIRINT=",I1," LSPLITLAT=",L2)')&
       & jglglo,jgl,nloeng(jglglo),nrirint(jgl),lsplitlat(jglglo)  
    ENDIF

    IF( lsplitlat(jglglo) )THEN
      iprocb=2*n_regions_ew
    ELSE
      iprocb=n_regions_ew
    ENDIF

    DO jb=1,iprocb
      IF( ionl(jgl,jb) == 0 ) GOTO 250
      nrfrstoff(jgl,jb)=mod(irint-mod(ista(jgl,jb)-1,irint),irint)
      nrlastoff(jgl,jb)=&
       & mod(irint-mod(ista(jgl,jb)+ionl(jgl,jb)-2,irint),&
       & irint)  
      imax=0
      DO jl=1+nrfrstoff(jgl,jb),ionl(jgl,jb),irint
        imax=imax+1
      ENDDO
      nrimax(jgl,jb)=imax
      IF( nrfrstoff(jgl,jb) == 0 )THEN
        nrcneedw(jgl,jb)=jpradcw-1
      ELSE
        nrcneedw(jgl,jb)=jpradcw
      ENDIF
      IF( nrlastoff(jgl,jb) == 0 )THEN
        nrcneede(jgl,jb)=jpradce-1
      ELSE
        nrcneede(jgl,jb)=jpradce
      ENDIF
      IF( lodbgradi )THEN
        WRITE(iunit,'("SUECRADI: JB=",I4," ISTA=",I4,&
         & " IONL=",I4," NRFRSTOFF=",I1," NRIMAX=",I3,&
         & " NRLASTOFF=",I1," CNEEDW=",I1," CNEEDE=",I1)')&
         & jb,ista(jgl,jb),ionl(jgl,jb),nrfrstoff(jgl,jb),&
         & nrimax(jgl,jb),nrlastoff(jgl,jb),&
         & nrcneedw(jgl,jb),nrcneede(jgl,jb)  
      ENDIF
      250 continue
    ENDDO

    IF( lodbgradi )THEN
      WRITE(iunit,'("SUECRADI: ")')
    ENDIF

    imaxt=imaxt+nrimax(jgl,my_region_ew)

  ENDDO

  nrimaxt=imaxt
  IF( lodbgradi )THEN
    WRITE(iunit,'("SUECRADI: NRIMAXT=",I6)') nrimaxt
  ENDIF

ELSE

  DO jgl=ndgsag,ndgeng

    ilons=nloen(jgl)

    irint=1
    DO jf=1,nrint15
      IF( mod(ilons,jf) == 0.AND.ilons/jf <= imaxc )THEN
        irint=jf
        GO TO 221
      ENDIF
    ENDDO
    221 CONTINUE

    nrirint(jgl)=irint
    nrimax(jgl,1)=ilons/irint

  ENDDO

ENDIF

IF( llmess )THEN

! NOW LOOP OVER OUR PARTITION LATITUDES, TO DETERMINE SEND AND RECEIVE
! INFORMATION

  DO jgl=1,ndgenl

! TEST IF WE HAVE ANY FINE POINTS
! IF WE HAVEN'T, THEN WE DON'T HAVE TO SEND OR RECEIVE ANYTHING

    IF( ionl(jgl,my_region_ew) == 0 ) GOTO 700
    jglglo=nfrstlat(my_region_ns)+jgl-1

! TEST IF CURRENT LATITUDE IS SPLIT ACROSS SET A's
! TO SET IPROCB TO THE MAXIMUM NUMBER OF SETB's WE MUST CONSIDER IN
! THE FOLLOWING CODE FOR THIS LATITUDE

    IF( lsplitlat(jglglo) )THEN
      iprocb=2*n_regions_ew
    ELSE
      iprocb=n_regions_ew
    ENDIF

! NOW CONSIDER EACH PARTITION (ON THIS LATITUDE) IN TURN TO SEE WHO
! WILL BE SENDING TO AND RECEIVING FROM IT, AND OBVIOUSLY NOTING
! PERTINENT INFO IF OUR PARTITION IS SENDING OR RECEIVING

    DO jbx=1,iprocb

! LET'S START BY BUILDING UP A LIST OF WESTERLY AND EASTERLY PARTITIONS
! CONTAINING ONE OR MORE FINE POINTS, SO THAT WE CAN SUBSEQUENTLY IGNORE
! ISSUES ABOUT WHETHER THIS IS A SPLIT LATITUDE AND THAT THE EARTH IS
! ROUND. ALSO THE PARTITION BEING CONSIDERED (JBX) ALWAYS APPEARS AT THE
! END OF EACH OF THESE LISTS, BECAUSE JBX MAY NEED TO 'LOGICALLY'
! SEND/RECEIVE COURSE POINTS TO/FROM ITS OWN PARTITION FOR THIS LATITUDE

      ilw=0
      ile=0
      IF( lsplitlat(jglglo) )THEN

! DETERMINE WHETHER THE SET A SHARING THIS LATITUDE IS (ABOVE,LEFT) OR
! (BELOW,RIGHT). WE DETERMINE THIS BY TESTING IF ANY SETB ON THIS
! LATITUDE
! STARTS AT 1.

        iaoff=-1
        DO jb=1,n_regions_ew
          IF( ista(jgl,jb) == 1 )THEN
            iaoff=1
            GOTO 411
          ENDIF
        ENDDO
        411 CONTINUE
        IF( jbx <= n_regions_ew )THEN
          ijbxseta=my_region_ns
          iothseta=my_region_ns+iaoff
          ijbxboff=0
          iothboff=n_regions_ew
        ELSE
          ijbxseta=my_region_ns+iaoff
          iothseta=my_region_ns
          ijbxboff=n_regions_ew
          iothboff=0
        ENDIF
! INITIALISE WEST LIST, SPLIT LAT
        IF( jbx <= n_regions_ew )THEN
          ib1=jbx-1
          ib2=1
          ib3=2*n_regions_ew
          ib4=n_regions_ew+1
          ib5=n_regions_ew
          ib6=jbx
        ELSE
          ib1=jbx-1
          ib2=n_regions_ew+1
          ib3=n_regions_ew
          ib4=1
          ib5=2*n_regions_ew
          ib6=jbx
        ENDIF
        DO jb=ib1,ib2,-1
          IF( ionl(jgl,jb) > 0 )THEN
            ilw=ilw+1
            ilwa(ilw)=ijbxseta
            ilwb(ilw)=jb-ijbxboff
            ilwbi(ilw)=jb
          ENDIF
        ENDDO
        DO jb=ib3,ib4,-1
          IF( ionl(jgl,jb) > 0 )THEN
            ilw=ilw+1
            ilwa(ilw)=iothseta
            ilwb(ilw)=jb-iothboff
            ilwbi(ilw)=jb
          ENDIF
        ENDDO
        DO jb=ib5,ib6,-1
          IF( ionl(jgl,jb) > 0 )THEN
            ilw=ilw+1
            ilwa(ilw)=ijbxseta
            ilwb(ilw)=jb-ijbxboff
            ilwbi(ilw)=jb
          ENDIF
        ENDDO
! INITIALISE EAST LIST, SPLIT LAT
        IF( jbx <= n_regions_ew )THEN
          ib1=jbx+1
          ib2=n_regions_ew
          ib3=n_regions_ew+1
          ib4=2*n_regions_ew
          ib5=1
          ib6=jbx
        ELSE
          ib1=jbx+1
          ib2=2*n_regions_ew
          ib3=1
          ib4=n_regions_ew
          ib5=n_regions_ew+1
          ib6=jbx
        ENDIF
        DO jb=ib1,ib2
          IF( ionl(jgl,jb) > 0 )THEN
            ile=ile+1
            ilea(ile)=ijbxseta
            ileb(ile)=jb-ijbxboff
            ilebi(ile)=jb
          ENDIF
        ENDDO
        DO jb=ib3,ib4
          IF( ionl(jgl,jb) > 0 )THEN
            ile=ile+1
            ilea(ile)=iothseta
            ileb(ile)=jb-iothboff
            ilebi(ile)=jb
          ENDIF
        ENDDO
        DO jb=ib5,ib6
          IF( ionl(jgl,jb) > 0 )THEN
            ile=ile+1
            ilea(ile)=ijbxseta
            ileb(ile)=jb-ijbxboff
            ilebi(ile)=jb
          ENDIF
        ENDDO
      ELSE
        iaoff=0
! INITIALISE WEST LIST, NOT SPLIT LAT
        DO jb=jbx-1,1,-1
          IF( ionl(jgl,jb) > 0 )THEN
            ilw=ilw+1
            ilwa(ilw)=my_region_ns
            ilwb(ilw)=jb
            ilwbi(ilw)=jb
          ENDIF
        ENDDO
        DO jb=n_regions_ew,jbx,-1
          IF( ionl(jgl,jb) > 0 )THEN
            ilw=ilw+1
            ilwa(ilw)=my_region_ns
            ilwb(ilw)=jb
            ilwbi(ilw)=jb
          ENDIF
        ENDDO
! INITIALISE EAST LIST, NOT SPLIT LAT
        DO jb=jbx+1,n_regions_ew
          IF( ionl(jgl,jb) > 0 )THEN
            ile=ile+1
            ilea(ile)=my_region_ns
            ileb(ile)=jb
            ilebi(ile)=jb
          ENDIF
        ENDDO
        DO jb=1,jbx
          IF( ionl(jgl,jb) > 0 )THEN
            ile=ile+1
            ilea(ile)=my_region_ns
            ileb(ile)=jb
            ilebi(ile)=jb
          ENDIF
        ENDDO
      ENDIF
      IF( ilw > 2*n_regions_ew .OR. ile > 2*n_regions_ew )THEN
        WRITE(nulout,.OR.'("SUECRAD: ILW > 2*N_REGIONS_EW  ",&
         & "ILE > 2*N_REGIONS_EW, ILW=",I6," ILE=",I6)') ilw,ile  
        CALL abor1('SUECRADI:ILW/E > 2*N_REGIONS_EW')
      ENDIF

! DETERMINE FOR PARTITION JBX THOSE PARTITIONS THAT IT HAS TO RECEIVE
! COURSE POINTS FROM.
! DO THIS BY SEARCHING DOWN THE WESTERN LIST OF PARTITIONS FIRST AND
! THEN FOR THE EASTERN LIST OF PARTITIONS.
! THE SEND AND RECEIVE INFO FOR THIS (MY_REGION_NS,MY_REGION_EW) IS DETERMINED BY
! SIMPLY NOTING WHETHER (MY_REGION_NS,MY_REGION_EW) IS A SENDER OR RECEIVER IN THE
! ABOVE LIST SEARCH PROCESS.

      icneed=nrcneedw(jgl,jbx)

      DO jbw=1,ilw
        IF( icneed == 0 ) GOTO 541

! DOES THIS PARTITION HAVE ANY COURSE POINTS

        IF( nrimax(jgl,ilwbi(jbw)) > 0 )THEN

! YES, IT DOES
! THEN TEST IF IT HAS ENOUGH TO SATISFY OUR NEED

          IF( nrimax(jgl,ilwbi(jbw)) >= icneed )THEN
            ictake=icneed
          ELSE
            ictake=nrimax(jgl,ilwbi(jbw))
          ENDIF
          IF( my_region_ns == ilwa(jbw).AND.my_region_ew == ilwb(jbw) )THEN
! WE (MY_REGION_NS,MY_REGION_EW) ARE THE SENDER (SENDING EAST COURSE POINTS)
            IF( jbx <= n_regions_ew )THEN
              ib =jbx
              iao=0
            ELSE
              ib =jbx-n_regions_ew
              iao=iaoff
            ENDIF
            nrcsnde(jgl,ib,iao)=ictake
            nrcsndt(ib,iao)=nrcsndt(ib,iao)+ictake
          ENDIF
          IF( jbx == my_region_ew )THEN
! WE (MY_REGION_NS,MY_REGION_EW) ARE THE RECEIVER
            ib =ilwb(jbw)
            iao=ilwa(jbw)-my_region_ns
            nrcrcvw(jgl,ib,iao)=ictake
            nrcrcvwo(jgl,ib,iao)=icneed-ictake
            nrcrcvt(ib,iao)=nrcrcvt(ib,iao)+ictake
          ENDIF
          icneed=icneed-ictake
        ENDIF
      ENDDO

      541 CONTINUE

      icneed=nrcneede(jgl,jbx)

      DO jbe=1,ile
        IF( icneed == 0 ) GOTO 551

! DOES THIS PARTITION HAVE ANY COURSE POINTS

        IF( nrimax(jgl,ilebi(jbe)) > 0 )THEN

! YES, IT DOES
! THEN TEST IF IT HAS ENOUGH TO SATISFY OUR NEED

          IF( nrimax(jgl,ilebi(jbe)) >= icneed )THEN
            ictake=icneed
          ELSE
            ictake=nrimax(jgl,ilebi(jbe))
          ENDIF
          IF( my_region_ns == ilea(jbe).AND.my_region_ew == ileb(jbe) )THEN
! WE (MY_REGION_NS,MY_REGION_EW) ARE THE SENDER (SENDING WEST COURSE POINTS)
            IF( jbx <= n_regions_ew )THEN
              ib =jbx
              iao=0
            ELSE
              ib =jbx-n_regions_ew
              iao=iaoff
            ENDIF
            nrcsndw(jgl,ib,iao)=ictake
            nrcsndt(ib,iao)=nrcsndt(ib,iao)+ictake
          ENDIF
          IF( jbx == my_region_ew )THEN
! WE (MY_REGION_NS,MY_REGION_EW) ARE THE RECEIVER
            ib =ileb(jbe)
            iao=ilea(jbe)-my_region_ns
            nrcrcve(jgl,ib,iao)=ictake
            nrcrcveo(jgl,ib,iao)=nrcneedw(jgl,jbx)+nrcneede(jgl,jbx)-icneed
            nrcrcvt(ib,iao)=nrcrcvt(ib,iao)+ictake
          ENDIF
          icneed=icneed-ictake
        ENDIF
      ENDDO

      551 CONTINUE

    ENDDO

! END OF JBX LOOP OVER PARTITIONS

    700 continue
  ENDDO

! END OF JGL LOOP OVER LATITUDES

! WRITE OUT SEND/RECEIVE TABLES IF DEBUGGING

  IF( lodbgradi )THEN
    DO ja=-1,1
      WRITE(iunit,'("SUECRADI: ")')
      DO jb=1,n_regions_ew
        IF( nrcsndt(jb,ja) > 0.OR. nrcrcvt(jb,ja) > 0 )THEN
          WRITE(iunit,'("SUECRADI: SETA=",I4," SETB=",I4,&
           & " NRCSNDT=",I6," NRCRCVT=",I6)')&
           & ja+my_region_ns,jb,nrcsndt(jb,ja),nrcrcvt(jb,ja)  
        ENDIF
      ENDDO
    ENDDO

    WRITE(iunit,'("SUECRADI: ")')

    DO ja=-1,1
      WRITE(iunit,'("SUECRADI: ")')
      DO jb=1,n_regions_ew
        DO jgl=1,ndgenl
          jglglo=nfrstlat(my_region_ns)+jgl-1
          IF( nrcsndw(jgl,jb,ja) > 0.OR.&
             & nrcsnde(jgl,jb,ja) > 0.OR.&
             & nrcrcvw(jgl,jb,ja) > 0.OR.&
             & nrcrcve(jgl,jb,ja) > 0 )THEN  
            WRITE(iunit,'("SUECRADI: JGLGLO=",I4," JGL=",I4,&
             & " SETA=",I4," SETB=",I4,&
             & " CSNDW=",I6," CSNDE=",I6,&
             & " CRCVW=",I6," CRCVE=",I6,&
             & " CRCVWO=",I1," CRCVEO=",I1)')&
             & jglglo,jgl,ja+my_region_ns,jb,&
             & nrcsndw(jgl,jb,ja),nrcsnde(jgl,jb,ja),&
             & nrcrcvw(jgl,jb,ja),nrcrcve(jgl,jb,ja),&
             & nrcrcvwo(jgl,jb,ja),nrcrcveo(jgl,jb,ja)  
          ENDIF
        ENDDO
      ENDDO
    ENDDO
    IF( .NOT.lodbgradl )THEN
      CLOSE(unit=iunit)
    ENDIF
  ENDIF

ENDIF

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

IF (lhook) CALL dr_hook('SUECRADI15',1,zhook_handle)
END SUBROUTINE suecradi15