source: LMDZ5/branches/IPSLCM5A2.1_ISO/libf/phyiso/rrtm/suecradi15.F90 @ 5308

Last change on this file since 5308 was 3331, checked in by acozic, 6 years ago

Add modification for isotopes

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