source: LMDZ6/branches/SETHET_DECOUPLE/libf/phylmd/rrtm/suecradi.F90 @ 5441

Last change on this file since 5441 was 1990, checked in by Laurent Fairhead, 11 years ago

Corrections à la version r1989 pour permettre la compilation avec RRTM
Inclusion de la licence CeCILL_V2 pour RRTM

Changes to revision r1989 to enable RRTM code compilation
RRTM part put under CeCILL_V2 licence
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 16.6 KB
Line 
1SUBROUTINE SUECRADI
2
3!**** *SUECRADI*   - INITIALIZE DATA STRUCTURES FOR RADIATION INTERPOLATION
4
5!     PURPOSE.
6!     --------
7!           INITIALIZE DATA STRUCTURES FOR RADIATION INTERPOLATION
8
9!**   INTERFACE.
10!     ----------
11!        CALL *SUECRADI* FROM *SUECRAD*
12!              --------        -------
13
14!        EXPLICIT ARGUMENTS :
15!        --------------------
16!        NONE
17
18!        IMPLICIT ARGUMENTS :
19!        --------------------
20
21!     METHOD.
22!     -------
23!        SEE DOCUMENTATION
24
25!     EXTERNALS.
26!     ----------
27!        NONE
28
29!     REFERENCE.
30!     ----------
31!        ECMWF Research Department documentation of the IFS
32
33!     AUTHOR.
34!     -------
35!        GEORGE MOZDZYNSKI 95-03-13
36
37!     MODIFICATIONS.
38!     --------------
39!        980317: JJMorcrette clean-up (NRAD, NFLUX)
40!        990907: JJMorcrette clean-up RRTM
41!        010129: JJMorcrette clean-up LERAD1H, NLNGR1H
42!        M.Hamrud      01-Oct-2003 CY28 Cleaning
43!     ------------------------------------------------------------------
44
45USE PARKIND1  ,ONLY : JPIM     ,JPRB
46USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
47
48USE PARRINT  , ONLY : JPRADCW  ,JPRADCE
49USE YOMDIM   , ONLY : NDGSAG   ,NDGSAL   ,NDGENG   ,NDGENL   ,NDLON
50USE YOMCT0   , ONLY :   NPRGPEW  ,NPRINTLEV,LALLOPR
51USE YOMLUN   , ONLY : NULOUT
52USE YOMGEM   , ONLY : NLOENG
53USE YOERAD   , ONLY :      &
54 & NRINT     
55USE YOMMP    , ONLY :    MY_REGION_NS   ,MY_REGION_EW   ,NSTA     ,&
56 & NONL     ,NPTRFRSTLAT,NPTRLSTLAT,NFRSTLAT ,NLSTLAT  ,&
57 & LSPLITLAT 
58USE YOMPRAD  , ONLY : LODBGRADI,LODBGRADL,NRIRINT  ,NRFRSTOFF,&
59 & NRLASTOFF,NRIMAX   ,NRIMAXT  ,NRCNEEDW ,NRCNEEDE ,&
60 & NRCSNDW  ,NRCSNDE  ,NRCRCVW  ,NRCRCVE  ,NRCSNDT  ,&
61 & NRCRCVT  ,NRCRCVWO ,NRCRCVEO 
62
63IMPLICIT NONE
64
65INTEGER(KIND=JPIM) :: ILWA (2*NPRGPEW)
66INTEGER(KIND=JPIM) :: ILWB (2*NPRGPEW)
67INTEGER(KIND=JPIM) :: ILWBI(2*NPRGPEW)
68INTEGER(KIND=JPIM) :: ILEA (2*NPRGPEW)
69INTEGER(KIND=JPIM) :: ILEB (2*NPRGPEW)
70INTEGER(KIND=JPIM) :: ILEBI(2*NPRGPEW)
71INTEGER(KIND=JPIM) :: ISTA(NDGENL,2*NPRGPEW)
72INTEGER(KIND=JPIM) :: IONL(NDGENL,2*NPRGPEW)
73CHARACTER (LEN = 14) ::  CLDBG
74
75INTEGER(KIND=JPIM) :: IAO, IAOFF, IB, IB1, IB2, IB3, IB4, IB5,&
76 & IB6, ICNEED, ICTAKE, IGL, IJBXBOFF, &
77 & IJBXSETA, ILE, ILONS, ILW, IMAX, IMAXC, &
78 & IMAXT, IOTHBOFF, IOTHSETA, IPROCB, IRINT, &
79 & IU, IUNIT, JA, JB, JBE, JBW, JBX, JF, JGL, &
80 & JGLGLO, JL 
81
82LOGICAL :: LLMYSETAISWEST, LLP
83REAL(KIND=JPRB) :: ZHOOK_HANDLE
84
85#include "abor1.intfb.h"
86
87!      ----------------------------------------------------------------
88
89IF (LHOOK) CALL DR_HOOK('SUECRADI',0,ZHOOK_HANDLE)
90LLP = NPRINTLEV >= 1.OR. LALLOPR
91IU = NULOUT
92ALLOCATE(NRIRINT  (NDGSAG:NDGENG))
93IF(LLP)WRITE(IU,9) 'NRIRINT   ',SIZE(NRIRINT),SHAPE(NRIRINT)
94ALLOCATE(NRIMAX   (NDGSAG:NDGENG,2*NPRGPEW))
95IF(LLP)WRITE(IU,9) 'NRIMAX    ',SIZE(NRIMAX),SHAPE(NRIMAX)
96ALLOCATE(NRFRSTOFF(NDGSAG:NDGENG,2*NPRGPEW))
97IF(LLP)WRITE(IU,9) 'NRFRSTOFF ',SIZE(NRFRSTOFF),SHAPE(NRFRSTOFF)
98ALLOCATE(NRLASTOFF(NDGSAG:NDGENG,2*NPRGPEW))
99IF(LLP)WRITE(IU,9) 'NRLASTOFF ',SIZE(NRLASTOFF),SHAPE(NRLASTOFF)
100ALLOCATE(NRCNEEDW (NDGSAG:NDGENG,2*NPRGPEW))
101IF(LLP)WRITE(IU,9) 'NRCNEEDW  ',SIZE(NRCNEEDW),SHAPE(NRCNEEDW)
102ALLOCATE(NRCNEEDE (NDGSAG:NDGENG,2*NPRGPEW))
103IF(LLP)WRITE(IU,9) 'NRCNEEDE  ',SIZE(NRCNEEDE),SHAPE(NRCNEEDE)
104ALLOCATE(NRCSNDW  (NDGSAG:NDGENG,NPRGPEW,-1:1))
105IF(LLP)WRITE(IU,9) 'NRCSNDW   ',SIZE(NRCSNDW),SHAPE(NRCSNDW)
106ALLOCATE(NRCSNDE  (NDGSAG:NDGENG,NPRGPEW,-1:1))
107IF(LLP)WRITE(IU,9) 'NRCSNDE   ',SIZE(NRCSNDE),SHAPE(NRCSNDE)
108ALLOCATE(NRCRCVW  (NDGSAG:NDGENG,NPRGPEW,-1:1))
109IF(LLP)WRITE(IU,9) 'NRCRCVW   ',SIZE(NRCRCVW),SHAPE(NRCRCVW)
110ALLOCATE(NRCRCVE  (NDGSAG:NDGENG,NPRGPEW,-1:1))
111IF(LLP)WRITE(IU,9) 'NRCRCVE   ',SIZE(NRCRCVE),SHAPE(NRCRCVE)
112ALLOCATE(NRCSNDT  (NPRGPEW,-1:1))
113IF(LLP)WRITE(IU,9) 'NRCSNDT   ',SIZE(NRCSNDT),SHAPE(NRCSNDT)
114ALLOCATE(NRCRCVT  (NPRGPEW,-1:1))
115IF(LLP)WRITE(IU,9) 'NRCRCVT   ',SIZE(NRCRCVT),SHAPE(NRCRCVT)
116ALLOCATE(NRCRCVWO (NDGSAG:NDGENG,NPRGPEW,-1:1))
117IF(LLP)WRITE(IU,9) 'NRCRCVWO  ',SIZE(NRCRCVWO),SHAPE(NRCRCVWO)
118ALLOCATE(NRCRCVEO (NDGSAG:NDGENG,NPRGPEW,-1:1))
119IF(LLP)WRITE(IU,9) 'NRCRCVEO  ',SIZE(NRCRCVEO),SHAPE(NRCRCVEO)
120
1219 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)
122
123! INITIALISE GENERAL DATA STRUCTURES REQUIRED FOR RADIATION INTERPOLATION
124
125DO JGL=NDGSAG,NDGENG
126  NRIRINT(JGL)=0
127ENDDO
128DO JB=1,2*NPRGPEW
129  DO JGL=NDGSAG,NDGENG
130    NRFRSTOFF(JGL,JB)=0
131    NRLASTOFF(JGL,JB)=0
132    NRIMAX   (JGL,JB)=0
133    NRCNEEDW (JGL,JB)=0
134    NRCNEEDE (JGL,JB)=0
135  ENDDO
136ENDDO
137NRIMAXT=0
138DO JA=-1,1
139  DO JB=1,NPRGPEW
140    DO JGL=NDGSAG,NDGENG
141      NRCSNDW(JGL,JB,JA)=0
142      NRCSNDE(JGL,JB,JA)=0
143      NRCRCVW(JGL,JB,JA)=0
144      NRCRCVE(JGL,JB,JA)=0
145      NRCRCVWO(JGL,JB,JA)=0
146      NRCRCVEO(JGL,JB,JA)=0
147    ENDDO
148  ENDDO
149ENDDO
150DO JA=-1,1
151  DO JB=1,NPRGPEW
152    NRCSNDT(JB,JA)=0
153    NRCRCVT(JB,JA)=0
154  ENDDO
155ENDDO
156
157DO JB=1,2*NPRGPEW
158  DO JGL=1,NDGENL
159    ISTA(JGL,JB)=0
160    IONL(JGL,JB)=0
161  ENDDO
162ENDDO
163DO JB=1,NPRGPEW
164  DO JGL=1,NDGENL
165    IGL=NPTRFRSTLAT(MY_REGION_NS)-1+JGL
166    ISTA(JGL,JB)=NSTA(IGL,JB)
167    IONL(JGL,JB)=NONL(IGL,JB)
168  ENDDO
169ENDDO
170IF( LSPLITLAT(NFRSTLAT(MY_REGION_NS)) )THEN
171  LLMYSETAISWEST=.FALSE.
172  DO JB=1,NPRGPEW
173    IF( NSTA(NPTRFRSTLAT(MY_REGION_NS),JB) == 1 )THEN
174      LLMYSETAISWEST=.TRUE.
175    ENDIF
176  ENDDO
177  IF( LLMYSETAISWEST )THEN
178    DO JB=1,NPRGPEW
179      IGL=NPTRFRSTLAT(MY_REGION_NS+1)
180      ISTA(1,JB+NPRGPEW)=NSTA(IGL,JB)
181      IONL(1,JB+NPRGPEW)=NONL(IGL,JB)
182    ENDDO
183  ELSE
184    DO JB=1,NPRGPEW
185      IGL=NPTRFRSTLAT(MY_REGION_NS)-1
186      ISTA(1,JB+NPRGPEW)=NSTA(IGL,JB)
187      IONL(1,JB+NPRGPEW)=NONL(IGL,JB)
188    ENDDO
189  ENDIF
190ENDIF
191IF( LSPLITLAT(NLSTLAT(MY_REGION_NS)) )THEN
192  LLMYSETAISWEST=.FALSE.
193  DO JB=1,NPRGPEW
194    IF( NSTA(NPTRLSTLAT(MY_REGION_NS),JB) == 1 )THEN
195      LLMYSETAISWEST=.TRUE.
196    ENDIF
197  ENDDO
198  IF( LLMYSETAISWEST )THEN
199    DO JB=1,NPRGPEW
200      IGL=NPTRFRSTLAT(MY_REGION_NS+1)
201      ISTA(NDGENL,JB+NPRGPEW)=NSTA(IGL,JB)
202      IONL(NDGENL,JB+NPRGPEW)=NONL(IGL,JB)
203    ENDDO
204  ELSE
205    DO JB=1,NPRGPEW
206      IGL=NPTRFRSTLAT(MY_REGION_NS)-1
207      ISTA(NDGENL,JB+NPRGPEW)=NSTA(IGL,JB)
208      IONL(NDGENL,JB+NPRGPEW)=NONL(IGL,JB)
209    ENDDO
210  ENDIF
211ENDIF
212
213IMAXC=NDLON/NRINT+6
214IMAXC=IMAXC+(1-MOD(IMAXC,2))
215
216IF( LODBGRADI )THEN
217  IUNIT=10
218  WRITE(CLDBG,'("debug_a",I3.3,"b",I3.3)')MY_REGION_NS,MY_REGION_EW
219  OPEN(UNIT=IUNIT,FILE=CLDBG)
220  WRITE(IUNIT,'("SUECRADI: MY_REGION_NS=",I4," MY_REGION_EW=",I4)')MY_REGION_NS,MY_REGION_EW
221  WRITE(IUNIT,'("SUECRADI: NDGSAL=",I4," NDGENL=",I4)') NDGSAL,NDGENL
222  WRITE(IUNIT,'("SUECRADI: ")')
223ENDIF
224
225! LOOP OVER OUR PARTITION LATITUDES, TO INITIALISE SIMPLE ITEMS
226
227IMAXT=0
228
229DO JGL=1,NDGENL
230
231  JGLGLO=NFRSTLAT(MY_REGION_NS)+JGL-1
232  ILONS=NLOENG(JGLGLO)
233
234  IRINT=1
235  DO JF=1,NRINT
236    IF( MOD(ILONS,JF) == 0.AND.ILONS/JF <= IMAXC )THEN
237      IRINT=JF
238      EXIT
239    ENDIF
240  ENDDO
241  NRIRINT  (JGL)=IRINT
242 
243  IF( LODBGRADI )THEN
244    WRITE(IUNIT,'("SUECRADI: JGLGLO=",I4," JGL=",I4,&
245     & " NLOENG=",I4," NRIRINT=",I1," LSPLITLAT=",L2)')&
246     & JGLGLO,JGL,NLOENG(JGLGLO),NRIRINT(JGL),LSPLITLAT(JGLGLO) 
247  ENDIF
248
249  IF( LSPLITLAT(JGLGLO) )THEN
250    IPROCB=2*NPRGPEW
251  ELSE
252    IPROCB=NPRGPEW
253  ENDIF
254
255  DO JB=1,IPROCB
256    IF( IONL(JGL,JB) == 0 ) CYCLE
257    NRFRSTOFF(JGL,JB)=MOD(IRINT-MOD(ISTA(JGL,JB)-1,IRINT),IRINT)
258    NRLASTOFF(JGL,JB)=&
259     & MOD(IRINT-MOD(ISTA(JGL,JB)+IONL(JGL,JB)-2,IRINT),&
260     & IRINT) 
261    IMAX=0
262    DO JL=1+NRFRSTOFF(JGL,JB),IONL(JGL,JB),IRINT
263      IMAX=IMAX+1
264    ENDDO
265    NRIMAX(JGL,JB)=IMAX
266    IF( NRFRSTOFF(JGL,JB) == 0 )THEN
267      NRCNEEDW (JGL,JB)=JPRADCW-1
268    ELSE
269      NRCNEEDW (JGL,JB)=JPRADCW
270    ENDIF
271    IF( NRLASTOFF(JGL,JB) == 0 )THEN
272      NRCNEEDE (JGL,JB)=JPRADCE-1
273    ELSE
274      NRCNEEDE (JGL,JB)=JPRADCE
275    ENDIF
276    IF( LODBGRADI )THEN
277      WRITE(IUNIT,'("SUECRADI: JB=",I4," ISTA=",I4,&
278       & " IONL=",I4," NRFRSTOFF=",I1," NRIMAX=",I3,&
279       & " NRLASTOFF=",I1," CNEEDW=",I1," CNEEDE=",I1)')&
280       & JB,ISTA(JGL,JB),IONL(JGL,JB),NRFRSTOFF(JGL,JB),&
281       & NRIMAX(JGL,JB),NRLASTOFF(JGL,JB),&
282       & NRCNEEDW(JGL,JB),NRCNEEDE(JGL,JB) 
283    ENDIF
284  ENDDO
285
286  IF( LODBGRADI )THEN
287    WRITE(IUNIT,'("SUECRADI: ")')
288  ENDIF
289 
290  IMAXT=IMAXT+NRIMAX(JGL,MY_REGION_EW)
291 
292ENDDO
293
294NRIMAXT=IMAXT
295IF( LODBGRADI )THEN
296  WRITE(IUNIT,'("SUECRADI: NRIMAXT=",I6)') NRIMAXT
297ENDIF
298
299! NOW LOOP OVER OUR PARTITION LATITUDES, TO DETERMINE SEND AND RECEIVE
300! INFORMATION
301
302DO JGL=1,NDGENL
303
304! TEST IF WE HAVE ANY FINE POINTS
305! IF WE HAVEN'T, THEN WE DON'T HAVE TO SEND OR RECEIVE ANYTHING
306
307  IF( IONL(JGL,MY_REGION_EW) == 0 ) CYCLE
308  JGLGLO=NFRSTLAT(MY_REGION_NS)+JGL-1
309
310! TEST IF CURRENT LATITUDE IS SPLIT ACROSS SET A's
311! TO SET IPROCB TO THE MAXIMUM NUMBER OF SETB's WE MUST CONSIDER IN
312! THE FOLLOWING CODE FOR THIS LATITUDE
313
314  IF( LSPLITLAT(JGLGLO) )THEN
315    IPROCB=2*NPRGPEW
316  ELSE
317    IPROCB=NPRGPEW
318  ENDIF
319
320! NOW CONSIDER EACH PARTITION (ON THIS LATITUDE) IN TURN TO SEE WHO
321! WILL BE SENDING TO AND RECEIVING FROM IT, AND OBVIOUSLY NOTING
322! PERTINENT INFO IF OUR PARTITION IS SENDING OR RECEIVING
323
324  DO JBX=1,IPROCB
325
326! LET'S START BY BUILDING UP A LIST OF WESTERLY AND EASTERLY PARTITIONS
327! CONTAINING ONE OR MORE FINE POINTS, SO THAT WE CAN SUBSEQUENTLY IGNORE
328! ISSUES ABOUT WHETHER THIS IS A SPLIT LATITUDE AND THAT THE EARTH IS
329! ROUND. ALSO THE PARTITION BEING CONSIDERED (JBX) ALWAYS APPEARS AT THE
330! END OF EACH OF THESE LISTS, BECAUSE JBX MAY NEED TO 'LOGICALLY' SEND/RECEIVE
331! COURSE POINTS TO/FROM ITS OWN PARTITION FOR THIS LATITUDE.
332
333    ILW=0
334    ILE=0
335    IF( LSPLITLAT(JGLGLO) )THEN
336
337! DETERMINE WHETHER THE SET A SHARING THIS LATITUDE IS (ABOVE,LEFT) OR
338! (BELOW,RIGHT). WE DETERMINE THIS BY TESTING IF ANY SETB ON THIS LATITUDE
339! STARTS AT 1.
340
341      IAOFF=-1
342      DO JB=1,NPRGPEW
343        IF( ISTA(JGL,JB) == 1 )THEN
344          IAOFF=1
345          EXIT
346        ENDIF
347      ENDDO
348
349      IF( JBX <= NPRGPEW )THEN
350        IJBXSETA=MY_REGION_NS
351        IOTHSETA=MY_REGION_NS+IAOFF
352        IJBXBOFF=0
353        IOTHBOFF=NPRGPEW
354      ELSE
355        IJBXSETA=MY_REGION_NS+IAOFF
356        IOTHSETA=MY_REGION_NS
357        IJBXBOFF=NPRGPEW
358        IOTHBOFF=0
359      ENDIF
360! INITIALISE WEST LIST, SPLIT LAT
361      IF( JBX <= NPRGPEW )THEN
362        IB1=JBX-1
363        IB2=1
364        IB3=2*NPRGPEW
365        IB4=NPRGPEW+1
366        IB5=NPRGPEW
367        IB6=JBX
368      ELSE
369        IB1=JBX-1
370        IB2=NPRGPEW+1
371        IB3=NPRGPEW
372        IB4=1
373        IB5=2*NPRGPEW
374        IB6=JBX
375      ENDIF
376      DO JB=IB1,IB2,-1
377        IF( IONL(JGL,JB) > 0 )THEN
378          ILW=ILW+1
379          ILWA (ILW)=IJBXSETA
380          ILWB (ILW)=JB-IJBXBOFF
381          ILWBI(ILW)=JB
382        ENDIF
383      ENDDO
384      DO JB=IB3,IB4,-1
385        IF( IONL(JGL,JB) > 0 )THEN
386          ILW=ILW+1
387          ILWA (ILW)=IOTHSETA
388          ILWB (ILW)=JB-IOTHBOFF
389          ILWBI(ILW)=JB
390        ENDIF
391      ENDDO
392      DO JB=IB5,IB6,-1
393        IF( IONL(JGL,JB) > 0 )THEN
394          ILW=ILW+1
395          ILWA (ILW)=IJBXSETA
396          ILWB (ILW)=JB-IJBXBOFF
397          ILWBI(ILW)=JB
398        ENDIF
399      ENDDO
400! INITIALISE EAST LIST, SPLIT LAT
401      IF( JBX <= NPRGPEW )THEN
402        IB1=JBX+1
403        IB2=NPRGPEW
404        IB3=NPRGPEW+1
405        IB4=2*NPRGPEW
406        IB5=1
407        IB6=JBX
408      ELSE
409        IB1=JBX+1
410        IB2=2*NPRGPEW
411        IB3=1
412        IB4=NPRGPEW
413        IB5=NPRGPEW+1
414        IB6=JBX
415      ENDIF
416      DO JB=IB1,IB2
417        IF( IONL(JGL,JB) > 0 )THEN
418          ILE=ILE+1
419          ILEA (ILE)=IJBXSETA
420          ILEB (ILE)=JB-IJBXBOFF
421          ILEBI(ILE)=JB
422        ENDIF
423      ENDDO
424      DO JB=IB3,IB4
425        IF( IONL(JGL,JB) > 0 )THEN
426          ILE=ILE+1
427          ILEA (ILE)=IOTHSETA
428          ILEB (ILE)=JB-IOTHBOFF
429          ILEBI(ILE)=JB
430        ENDIF
431      ENDDO
432      DO JB=IB5,IB6
433        IF( IONL(JGL,JB) > 0 )THEN
434          ILE=ILE+1
435          ILEA (ILE)=IJBXSETA
436          ILEB (ILE)=JB-IJBXBOFF
437          ILEBI(ILE)=JB
438        ENDIF
439      ENDDO
440    ELSE
441      IAOFF=0
442! INITIALISE WEST LIST, NOT SPLIT LAT
443      DO JB=JBX-1,1,-1
444        IF( IONL(JGL,JB) > 0 )THEN
445          ILW=ILW+1
446          ILWA (ILW)=MY_REGION_NS
447          ILWB (ILW)=JB
448          ILWBI(ILW)=JB
449        ENDIF
450      ENDDO
451      DO JB=NPRGPEW,JBX,-1
452        IF( IONL(JGL,JB) > 0 )THEN
453          ILW=ILW+1
454          ILWA (ILW)=MY_REGION_NS
455          ILWB (ILW)=JB
456          ILWBI(ILW)=JB
457        ENDIF
458      ENDDO
459! INITIALISE EAST LIST, NOT SPLIT LAT
460      DO JB=JBX+1,NPRGPEW
461        IF( IONL(JGL,JB) > 0 )THEN
462          ILE=ILE+1
463          ILEA (ILE)=MY_REGION_NS
464          ILEB (ILE)=JB
465          ILEBI(ILE)=JB
466        ENDIF
467      ENDDO
468      DO JB=1,JBX
469        IF( IONL(JGL,JB) > 0 )THEN
470          ILE=ILE+1
471          ILEA (ILE)=MY_REGION_NS
472          ILEB (ILE)=JB
473          ILEBI(ILE)=JB
474        ENDIF
475      ENDDO
476    ENDIF
477    IF( ILW > 2*NPRGPEW .OR. ILE > 2*NPRGPEW )THEN
478      WRITE(NULOUT,'("SUECRAD: ILW > 2*NPRGPEW .OR. ",&
479       & "ILE > 2*NPRGPEW, ILW=",I6," ILE=",I6)') ILW,ILE 
480      CALL ABOR1('SUECRADI:ILW/E > 2*NPRGPEW')
481    ENDIF
482
483! DETERMINE FOR PARTITION JBX THOSE PARTITIONS THAT IT HAS TO RECEIVE
484! COURSE POINTS FROM.
485! DO THIS BY SEARCHING DOWN THE WESTERN LIST OF PARTITIONS FIRST AND THEN
486! FOR THE EASTERN LIST OF PARTITIONS.
487! THE SEND AND RECEIVE INFO FOR THIS (MY_REGION_NS,MY_REGION_EW) IS DETERMINED BY
488! SIMPLY NOTING WHETHER (MY_REGION_NS,MY_REGION_EW) IS A SENDER OR RECEIVER IN THE
489! ABOVE LIST SEARCH PROCESS.
490
491    ICNEED=NRCNEEDW(JGL,JBX)
492
493    DO JBW=1,ILW
494      IF( ICNEED == 0 ) EXIT
495
496! DOES THIS PARTITION HAVE ANY COURSE POINTS
497
498      IF( NRIMAX(JGL,ILWBI(JBW)) > 0 )THEN
499
500! YES, IT DOES
501! THEN TEST IF IT HAS ENOUGH TO SATISFY OUR NEED
502
503        IF( NRIMAX(JGL,ILWBI(JBW)) >= ICNEED )THEN
504          ICTAKE=ICNEED
505        ELSE
506          ICTAKE=NRIMAX(JGL,ILWBI(JBW))
507        ENDIF
508        IF( MY_REGION_NS == ILWA(JBW).AND.MY_REGION_EW == ILWB(JBW) )THEN
509! WE (MY_REGION_NS,MY_REGION_EW) ARE THE SENDER (SENDING EAST COURSE POINTS)
510          IF( JBX <= NPRGPEW )THEN
511            IB =JBX
512            IAO=0
513          ELSE
514            IB =JBX-NPRGPEW
515            IAO=IAOFF
516          ENDIF
517          NRCSNDE(JGL,IB,IAO)=ICTAKE
518          NRCSNDT(IB,IAO)=NRCSNDT(IB,IAO)+ICTAKE
519        ENDIF
520        IF( JBX == MY_REGION_EW )THEN
521! WE (MY_REGION_NS,MY_REGION_EW) ARE THE RECEIVER
522          IB =ILWB(JBW)
523          IAO=ILWA(JBW)-MY_REGION_NS
524          NRCRCVW (JGL,IB,IAO)=ICTAKE
525          NRCRCVWO(JGL,IB,IAO)=ICNEED-ICTAKE
526          NRCRCVT (IB,IAO)=NRCRCVT(IB,IAO)+ICTAKE
527        ENDIF
528        ICNEED=ICNEED-ICTAKE
529      ENDIF
530    ENDDO
531
532    ICNEED=NRCNEEDE(JGL,JBX)
533   
534    DO JBE=1,ILE
535      IF( ICNEED == 0 ) EXIT
536
537! DOES THIS PARTITION HAVE ANY COURSE POINTS
538
539      IF( NRIMAX(JGL,ILEBI(JBE)) > 0 )THEN
540
541! YES, IT DOES
542! THEN TEST IF IT HAS ENOUGH TO SATISFY OUR NEED
543
544        IF( NRIMAX(JGL,ILEBI(JBE)) >= ICNEED )THEN
545          ICTAKE=ICNEED
546        ELSE
547          ICTAKE=NRIMAX(JGL,ILEBI(JBE))
548        ENDIF
549        IF( MY_REGION_NS == ILEA(JBE).AND.MY_REGION_EW == ILEB(JBE) )THEN
550! WE (MY_REGION_NS,MY_REGION_EW) ARE THE SENDER (SENDING WEST COURSE POINTS)
551          IF( JBX <= NPRGPEW )THEN
552            IB =JBX
553            IAO=0
554          ELSE
555            IB =JBX-NPRGPEW
556            IAO=IAOFF
557          ENDIF
558          NRCSNDW(JGL,IB,IAO)=ICTAKE
559          NRCSNDT(IB,IAO)=NRCSNDT(IB,IAO)+ICTAKE
560        ENDIF
561        IF( JBX == MY_REGION_EW )THEN
562! WE (MY_REGION_NS,MY_REGION_EW) ARE THE RECEIVER
563          IB =ILEB(JBE)
564          IAO=ILEA(JBE)-MY_REGION_NS
565          NRCRCVE (JGL,IB,IAO)=ICTAKE
566          NRCRCVEO(JGL,IB,IAO)=NRCNEEDW(JGL,JBX)+NRCNEEDE(JGL,JBX)-ICNEED
567          NRCRCVT (IB,IAO)=NRCRCVT(IB,IAO)+ICTAKE
568        ENDIF
569        ICNEED=ICNEED-ICTAKE
570      ENDIF
571    ENDDO
572
573  ENDDO
574
575! END OF JBX LOOP OVER PARTITIONS
576
577ENDDO
578
579! END OF JGL LOOP OVER LATITUDES
580
581! WRITE OUT SEND/RECEIVE TABLES IF DEBUGGING
582
583IF( LODBGRADI )THEN
584  DO JA=-1,1
585    WRITE(IUNIT,'("SUECRADI: ")')
586    DO JB=1,NPRGPEW
587      IF( NRCSNDT(JB,JA) > 0.OR. NRCRCVT(JB,JA) > 0 )THEN
588        WRITE(IUNIT,'("SUECRADI: SETA=",I4," SETB=",I4,&
589         & " NRCSNDT=",I6," NRCRCVT=",I6)')&
590         & JA+MY_REGION_NS,JB,NRCSNDT(JB,JA),NRCRCVT(JB,JA) 
591      ENDIF
592    ENDDO
593  ENDDO
594 
595  WRITE(IUNIT,'("SUECRADI: ")')
596 
597  DO JA=-1,1
598    WRITE(IUNIT,'("SUECRADI: ")')
599    DO JB=1,NPRGPEW
600      DO JGL=1,NDGENL
601        JGLGLO=NFRSTLAT(MY_REGION_NS)+JGL-1
602        IF( NRCSNDW(JGL,JB,JA) > 0.OR.&
603           & NRCSNDE(JGL,JB,JA) > 0.OR.&
604           & NRCRCVW(JGL,JB,JA) > 0.OR.&
605           & NRCRCVE(JGL,JB,JA) > 0 )THEN 
606          WRITE(IUNIT,'("SUECRADI: JGLGLO=",I4," JGL=",I4,&
607           & " SETA=",I4," SETB=",I4,&
608           & " CSNDW=",I6," CSNDE=",I6,&
609           & " CRCVW=",I6," CRCVE=",I6,&
610           & " CRCVWO=",I1," CRCVEO=",I1)')&
611           & JGLGLO,JGL,JA+MY_REGION_NS,JB,&
612           & NRCSNDW(JGL,JB,JA),NRCSNDE(JGL,JB,JA),&
613           & NRCRCVW(JGL,JB,JA),NRCRCVE(JGL,JB,JA),&
614           & NRCRCVWO(JGL,JB,JA),NRCRCVEO(JGL,JB,JA) 
615        ENDIF
616      ENDDO
617    ENDDO
618  ENDDO
619  IF( .NOT.LODBGRADL )THEN
620    CLOSE(UNIT=IUNIT)
621  ENDIF
622ENDIF
623
624!     ------------------------------------------------------------------
625
626IF (LHOOK) CALL DR_HOOK('SUECRADI',1,ZHOOK_HANDLE)
627END SUBROUTINE SUECRADI
Note: See TracBrowser for help on using the repository browser.