!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,'("SUECRAD: ILW > 2*N_REGIONS_EW .OR. ",& & "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