SUBROUTINE SUECRADI !**** *SUECRADI* - INITIALIZE DATA STRUCTURES FOR RADIATION INTERPOLATION ! PURPOSE. ! -------- ! INITIALIZE DATA STRUCTURES FOR RADIATION INTERPOLATION !** INTERFACE. ! ---------- ! CALL *SUECRADI* FROM *SUECRAD* ! -------- ------- ! EXPLICIT ARGUMENTS : ! -------------------- ! NONE ! IMPLICIT ARGUMENTS : ! -------------------- ! METHOD. ! ------- ! SEE DOCUMENTATION ! EXTERNALS. ! ---------- ! NONE ! REFERENCE. ! ---------- ! ECMWF Research Department documentation of the IFS ! AUTHOR. ! ------- ! GEORGE MOZDZYNSKI 95-03-13 ! MODIFICATIONS. ! -------------- ! 980317: JJMorcrette clean-up (NRAD, NFLUX) ! 990907: JJMorcrette clean-up RRTM ! 010129: JJMorcrette clean-up LERAD1H, NLNGR1H ! 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 : NPRGPEW ,NPRINTLEV,LALLOPR USE YOMLUN , ONLY : NULOUT USE YOMGEM , ONLY : NLOENG USE YOERAD , ONLY : & & NRINT USE YOMMP , ONLY : 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 INTEGER(KIND=JPIM) :: ILWA (2*NPRGPEW) INTEGER(KIND=JPIM) :: ILWB (2*NPRGPEW) INTEGER(KIND=JPIM) :: ILWBI(2*NPRGPEW) INTEGER(KIND=JPIM) :: ILEA (2*NPRGPEW) INTEGER(KIND=JPIM) :: ILEB (2*NPRGPEW) INTEGER(KIND=JPIM) :: ILEBI(2*NPRGPEW) INTEGER(KIND=JPIM) :: ISTA(NDGENL,2*NPRGPEW) INTEGER(KIND=JPIM) :: IONL(NDGENL,2*NPRGPEW) CHARACTER (LEN = 14) :: CLDBG INTEGER(KIND=JPIM) :: IAO, IAOFF, IB, IB1, IB2, IB3, IB4, IB5,& & IB6, ICNEED, ICTAKE, IGL, IJBXBOFF, & & IJBXSETA, ILE, ILONS, ILW, IMAX, IMAXC, & & IMAXT, IOTHBOFF, IOTHSETA, IPROCB, IRINT, & & IU, IUNIT, JA, JB, JBE, JBW, JBX, JF, JGL, & & JGLGLO, JL LOGICAL :: LLMYSETAISWEST, LLP REAL(KIND=JPRB) :: ZHOOK_HANDLE #include "abor1.intfb.h" ! ---------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('SUECRADI',0,ZHOOK_HANDLE) LLP = NPRINTLEV >= 1.OR. LALLOPR IU = NULOUT ALLOCATE(NRIRINT (NDGSAG:NDGENG)) IF(LLP)WRITE(IU,9) 'NRIRINT ',SIZE(NRIRINT),SHAPE(NRIRINT) ALLOCATE(NRIMAX (NDGSAG:NDGENG,2*NPRGPEW)) IF(LLP)WRITE(IU,9) 'NRIMAX ',SIZE(NRIMAX),SHAPE(NRIMAX) ALLOCATE(NRFRSTOFF(NDGSAG:NDGENG,2*NPRGPEW)) IF(LLP)WRITE(IU,9) 'NRFRSTOFF ',SIZE(NRFRSTOFF),SHAPE(NRFRSTOFF) ALLOCATE(NRLASTOFF(NDGSAG:NDGENG,2*NPRGPEW)) IF(LLP)WRITE(IU,9) 'NRLASTOFF ',SIZE(NRLASTOFF),SHAPE(NRLASTOFF) ALLOCATE(NRCNEEDW (NDGSAG:NDGENG,2*NPRGPEW)) IF(LLP)WRITE(IU,9) 'NRCNEEDW ',SIZE(NRCNEEDW),SHAPE(NRCNEEDW) ALLOCATE(NRCNEEDE (NDGSAG:NDGENG,2*NPRGPEW)) IF(LLP)WRITE(IU,9) 'NRCNEEDE ',SIZE(NRCNEEDE),SHAPE(NRCNEEDE) ALLOCATE(NRCSNDW (NDGSAG:NDGENG,NPRGPEW,-1:1)) IF(LLP)WRITE(IU,9) 'NRCSNDW ',SIZE(NRCSNDW),SHAPE(NRCSNDW) ALLOCATE(NRCSNDE (NDGSAG:NDGENG,NPRGPEW,-1:1)) IF(LLP)WRITE(IU,9) 'NRCSNDE ',SIZE(NRCSNDE),SHAPE(NRCSNDE) ALLOCATE(NRCRCVW (NDGSAG:NDGENG,NPRGPEW,-1:1)) IF(LLP)WRITE(IU,9) 'NRCRCVW ',SIZE(NRCRCVW),SHAPE(NRCRCVW) ALLOCATE(NRCRCVE (NDGSAG:NDGENG,NPRGPEW,-1:1)) IF(LLP)WRITE(IU,9) 'NRCRCVE ',SIZE(NRCRCVE),SHAPE(NRCRCVE) ALLOCATE(NRCSNDT (NPRGPEW,-1:1)) IF(LLP)WRITE(IU,9) 'NRCSNDT ',SIZE(NRCSNDT),SHAPE(NRCSNDT) ALLOCATE(NRCRCVT (NPRGPEW,-1:1)) IF(LLP)WRITE(IU,9) 'NRCRCVT ',SIZE(NRCRCVT),SHAPE(NRCRCVT) ALLOCATE(NRCRCVWO (NDGSAG:NDGENG,NPRGPEW,-1:1)) IF(LLP)WRITE(IU,9) 'NRCRCVWO ',SIZE(NRCRCVWO),SHAPE(NRCRCVWO) ALLOCATE(NRCRCVEO (NDGSAG:NDGENG,NPRGPEW,-1:1)) IF(LLP)WRITE(IU,9) 'NRCRCVEO ',SIZE(NRCRCVEO),SHAPE(NRCRCVEO) 9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8) ! INITIALISE GENERAL DATA STRUCTURES REQUIRED FOR RADIATION INTERPOLATION DO JGL=NDGSAG,NDGENG NRIRINT(JGL)=0 ENDDO DO JB=1,2*NPRGPEW 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,NPRGPEW 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,NPRGPEW NRCSNDT(JB,JA)=0 NRCRCVT(JB,JA)=0 ENDDO ENDDO DO JB=1,2*NPRGPEW DO JGL=1,NDGENL ISTA(JGL,JB)=0 IONL(JGL,JB)=0 ENDDO ENDDO DO JB=1,NPRGPEW 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,NPRGPEW IF( NSTA(NPTRFRSTLAT(MY_REGION_NS),JB) == 1 )THEN LLMYSETAISWEST=.TRUE. ENDIF ENDDO IF( LLMYSETAISWEST )THEN DO JB=1,NPRGPEW IGL=NPTRFRSTLAT(MY_REGION_NS+1) ISTA(1,JB+NPRGPEW)=NSTA(IGL,JB) IONL(1,JB+NPRGPEW)=NONL(IGL,JB) ENDDO ELSE DO JB=1,NPRGPEW IGL=NPTRFRSTLAT(MY_REGION_NS)-1 ISTA(1,JB+NPRGPEW)=NSTA(IGL,JB) IONL(1,JB+NPRGPEW)=NONL(IGL,JB) ENDDO ENDIF ENDIF IF( LSPLITLAT(NLSTLAT(MY_REGION_NS)) )THEN LLMYSETAISWEST=.FALSE. DO JB=1,NPRGPEW IF( NSTA(NPTRLSTLAT(MY_REGION_NS),JB) == 1 )THEN LLMYSETAISWEST=.TRUE. ENDIF ENDDO IF( LLMYSETAISWEST )THEN DO JB=1,NPRGPEW IGL=NPTRFRSTLAT(MY_REGION_NS+1) ISTA(NDGENL,JB+NPRGPEW)=NSTA(IGL,JB) IONL(NDGENL,JB+NPRGPEW)=NONL(IGL,JB) ENDDO ELSE DO JB=1,NPRGPEW IGL=NPTRFRSTLAT(MY_REGION_NS)-1 ISTA(NDGENL,JB+NPRGPEW)=NSTA(IGL,JB) IONL(NDGENL,JB+NPRGPEW)=NONL(IGL,JB) ENDDO ENDIF ENDIF IMAXC=NDLON/NRINT+6 IMAXC=IMAXC+(1-MOD(IMAXC,2)) 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 ! LOOP OVER OUR PARTITION LATITUDES, TO INITIALISE SIMPLE ITEMS IMAXT=0 DO JGL=1,NDGENL JGLGLO=NFRSTLAT(MY_REGION_NS)+JGL-1 ILONS=NLOENG(JGLGLO) IRINT=1 DO JF=1,NRINT IF( MOD(ILONS,JF) == 0.AND.ILONS/JF <= IMAXC )THEN IRINT=JF EXIT ENDIF ENDDO 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*NPRGPEW ELSE IPROCB=NPRGPEW ENDIF DO JB=1,IPROCB IF( IONL(JGL,JB) == 0 ) CYCLE 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 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 ! 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 ) CYCLE 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*NPRGPEW ELSE IPROCB=NPRGPEW 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,NPRGPEW IF( ISTA(JGL,JB) == 1 )THEN IAOFF=1 EXIT ENDIF ENDDO IF( JBX <= NPRGPEW )THEN IJBXSETA=MY_REGION_NS IOTHSETA=MY_REGION_NS+IAOFF IJBXBOFF=0 IOTHBOFF=NPRGPEW ELSE IJBXSETA=MY_REGION_NS+IAOFF IOTHSETA=MY_REGION_NS IJBXBOFF=NPRGPEW IOTHBOFF=0 ENDIF ! INITIALISE WEST LIST, SPLIT LAT IF( JBX <= NPRGPEW )THEN IB1=JBX-1 IB2=1 IB3=2*NPRGPEW IB4=NPRGPEW+1 IB5=NPRGPEW IB6=JBX ELSE IB1=JBX-1 IB2=NPRGPEW+1 IB3=NPRGPEW IB4=1 IB5=2*NPRGPEW 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 <= NPRGPEW )THEN IB1=JBX+1 IB2=NPRGPEW IB3=NPRGPEW+1 IB4=2*NPRGPEW IB5=1 IB6=JBX ELSE IB1=JBX+1 IB2=2*NPRGPEW IB3=1 IB4=NPRGPEW IB5=NPRGPEW+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=NPRGPEW,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,NPRGPEW 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*NPRGPEW .OR. ILE > 2*NPRGPEW )THEN WRITE(NULOUT,'("SUECRAD: ILW > 2*NPRGPEW .OR. ",& & "ILE > 2*NPRGPEW, ILW=",I6," ILE=",I6)') ILW,ILE CALL ABOR1('SUECRADI:ILW/E > 2*NPRGPEW') 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 ) EXIT ! 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 <= NPRGPEW )THEN IB =JBX IAO=0 ELSE IB =JBX-NPRGPEW 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 ICNEED=NRCNEEDE(JGL,JBX) DO JBE=1,ILE IF( ICNEED == 0 ) EXIT ! 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 <= NPRGPEW )THEN IB =JBX IAO=0 ELSE IB =JBX-NPRGPEW 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 ENDDO ! END OF JBX LOOP OVER PARTITIONS 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,NPRGPEW 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,NPRGPEW 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 ! ------------------------------------------------------------------ IF (LHOOK) CALL DR_HOOK('SUECRADI',1,ZHOOK_HANDLE) END SUBROUTINE SUECRADI