source: lmdz_wrf/trunk/WRFV3/share/sint.F @ 1539

Last change on this file since 1539 was 1, checked in by lfita, 11 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 19.9 KB
Line 
1
2      SUBROUTINE SINT(XF,                        &
3                   ims, ime, jms, jme, icmask ,  &
4                   its, ite, jts, jte, nf, xstag, ystag )
5      IMPLICIT NONE
6      INTEGER ims, ime, jms, jme, &
7              its, ite, jts, jte
8
9      LOGICAL icmask( ims:ime, jms:jme )
10      LOGICAL xstag, ystag
11
12      INTEGER nf, ior
13      REAL    one12, one24, ep
14      PARAMETER(one12=1./12.,one24=1./24.)                             
15      PARAMETER(ior=2)                       
16!                                                                       
17      REAL XF(ims:ime,jms:jme,NF)
18!                                                                       
19      REAL Y(ims:ime,jms:jme,-IOR:IOR),    &
20           Z(ims:ime,jms:jme,-IOR:IOR),    &
21           F(ims:ime,jms:jme,0:1)                                       
22!
23      INTEGER I,J,II,JJ,IIM
24      INTEGER N2STAR, N2END, N1STAR, N1END
25!                                                                       
26      DATA  EP/ 1.E-10/                                                 
27
28      REAL W(ims:ime,jms:jme),OV(ims:ime,jms:jme),UN(ims:ime,jms:jme)                     
29      REAL MXM(ims:ime,jms:jme),MN(ims:ime,jms:jme)                                 
30      REAL FL(ims:ime,jms:jme,0:1)                                           
31      REAL XIG(NF*NF), XJG(NF*NF)  ! NF is parent to child grid refinement ratio
32      integer rr
33
34      REAL rioff, rjoff
35!                                                                       
36      REAL donor, y1, y2, a
37      DONOR(Y1,Y2,A)=(Y1*AMAX1(0.,SIGN(1.,A))-Y2*AMIN1(0.,SIGN(1.,A)))*A
38      REAL tr4, ym1, y0, yp1, yp2
39      TR4(YM1,Y0,YP1,YP2,A)=A*ONE12*(7.*(YP1+Y0)-(YP2+YM1))               &
40       -A*A*ONE24*(15.*(YP1-Y0)-(YP2-YM1))-A*A*A*ONE12*((YP1+Y0)          &
41       -(YP2+YM1))+A*A*A*A*ONE24*(3.*(YP1-Y0)-(YP2-YM1))               
42      REAL pp, pn, x
43      PP(X)=AMAX1(0.,X)                                                 
44      PN(X)=AMIN1(0.,X)                                                 
45
46      rr = nint(sqrt(float(nf)))
47!!      write(6,*) ' nf, rr are ',nf,rr
48
49      rioff = 0
50      rjoff = 0
51      if(xstag .and. (mod(rr,2) .eq. 0)) rioff = 1.
52      if(ystag .and. (mod(rr,2) .eq. 0)) rjoff = 1.
53
54      DO I=1,rr
55        DO J=1,rr
56          XIG(J+(I-1)*rr)=(float(rr)-1.-rioff)/float(2*rr)-FLOAT(J-1)*1./float(rr)
57          XJG(J+(I-1)*rr)=(float(rr)-1.-rjoff)/float(2*rr)-FLOAT(I-1)*1./float(rr)   
58        ENDDO
59      ENDDO
60
61      N2STAR = jts
62      N2END  = jte
63      N1STAR = its
64      N1END  = ite
65
66      DO 2000 IIM=1,NF                                                 
67!                                                                       
68!  HERE STARTS RESIDUAL ADVECTION                                       
69!                                                                       
70        DO 9000 JJ=N2STAR,N2END                                         
71          DO 50 J=-IOR,IOR                                             
72
73            DO 51 I=-IOR,IOR                                           
74              DO 511 II=N1STAR,N1END                                   
75                IF ( icmask(II,JJ) ) Y(II,JJ,I)=XF(II+I,JJ+J,IIM)             
76  511         CONTINUE
77   51       CONTINUE                                                   
78
79            DO 811 II=N1STAR,N1END                                     
80              IF ( icmask(II,JJ) ) THEN
81                FL(II,JJ,0)=DONOR(Y(II,JJ,-1),Y(II,JJ,0),XIG(IIM))       
82                FL(II,JJ,1)=DONOR(Y(II,JJ,0),Y(II,JJ,1),XIG(IIM))           
83              ENDIF
84  811         CONTINUE
85            DO 812 II=N1STAR,N1END                                     
86              IF ( icmask(II,JJ) ) W(II,JJ)=Y(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))               
87  812         CONTINUE
88            DO 813 II=N1STAR,N1END                                     
89              IF ( icmask(II,JJ) ) THEN
90                MXM(II,JJ)=                                             &
91                         AMAX1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),       &
92                         W(II,JJ))                                     
93                MN(II,JJ)=AMIN1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),W(II,JJ))
94              ENDIF
95  813         CONTINUE
96            DO 312 II=N1STAR,N1END                                     
97              IF ( icmask(II,JJ) ) THEN
98                F(II,JJ,0)=                                               &
99                           TR4(Y(II,JJ,-2),Y(II,JJ,-1),Y(II,JJ,0),        &
100                           Y(II,JJ,1),XIG(IIM))                           
101                F(II,JJ,1)=                                                 &
102                         TR4(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),Y(II,JJ,2),&
103                         XIG(IIM))                                       
104                ENDIF
105  312         CONTINUE
106            DO 822 II=N1STAR,N1END                                     
107              IF ( icmask(II,JJ) ) THEN
108                F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)                         
109                F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)                           
110              ENDIF
111  822         CONTINUE
112            DO 823 II=N1STAR,N1END                                     
113              IF ( icmask(II,JJ) ) THEN
114                OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+         &
115                        PP(F(II,JJ,0))+EP)                             
116                UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-             &
117                      PN(F(II,JJ,0))+EP)                               
118              ENDIF
119  823         CONTINUE
120            DO 824 II=N1STAR,N1END                                     
121              IF ( icmask(II,JJ) ) THEN
122                F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+            &
123                           PN(F(II,JJ,0))*AMIN1(1.,UN(II,JJ))             
124                F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+            &
125                           PN(F(II,JJ,1))*AMIN1(1.,OV(II,JJ))             
126              ENDIF                                                   
127  824         CONTINUE                                                   
128            DO 825 II=N1STAR,N1END                                     
129              IF ( icmask(II,JJ) ) THEN
130                Y(II,JJ,0)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))                 
131              ENDIF
132  825         CONTINUE
133            DO 361 II=N1STAR,N1END                                     
134              IF ( icmask(II,JJ) ) Z(II,JJ,J)=Y(II,JJ,0)                                       
135  361         CONTINUE
136!                                                                       
137!  END IF FIRST J LOOP                                                 
138!                                                                       
139 8000       CONTINUE                                                   
140   50     CONTINUE                                                     
141
142          DO 911 II=N1STAR,N1END                                       
143            IF ( icmask(II,JJ) ) THEN
144              FL(II,JJ,0)=DONOR(Z(II,JJ,-1),Z(II,JJ,0),XJG(IIM))         
145              FL(II,JJ,1)=DONOR(Z(II,JJ,0),Z(II,JJ,1),XJG(IIM))             
146            ENDIF
147  911       CONTINUE
148          DO 912 II=N1STAR,N1END                                       
149            IF ( icmask(II,JJ) ) W(II,JJ)=Z(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))                 
150  912       CONTINUE
151          DO 913 II=N1STAR,N1END                                       
152            IF ( icmask(II,JJ) ) THEN
153              MXM(II,JJ)=AMAX1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))
154              MN(II,JJ)=AMIN1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))   
155            ENDIF
156  913       CONTINUE
157          DO 412 II=N1STAR,N1END                                       
158            IF ( icmask(II,JJ) ) THEN
159              F(II,JJ,0)=                                                 &
160                         TR4(Z(II,JJ,-2),Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1)&
161                         ,XJG(IIM))                                       
162              F(II,JJ,1)=                                                   &
163                         TR4(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),Z(II,JJ,2),  &
164                         XJG(IIM))                                         
165            ENDIF
166  412       CONTINUE
167          DO 922 II=N1STAR,N1END                                       
168            IF ( icmask(II,JJ) ) THEN
169              F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)                           
170              F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)                             
171            ENDIF
172  922       CONTINUE
173          DO 923 II=N1STAR,N1END                                       
174            IF ( icmask(II,JJ) ) THEN
175              OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+           &
176                        PP(F(II,JJ,0))+EP)                               
177              UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-PN(F(II,JJ,0))+ &
178                      EP)                                                 
179            ENDIF
180  923       CONTINUE
181          DO 924 II=N1STAR,N1END                                       
182            IF ( icmask(II,JJ) ) THEN
183              F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+PN(F(II,JJ,0))  &
184                         *AMIN1(1.,UN(II,JJ))                             
185              F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+PN(F(II,JJ,1))  &
186                         *AMIN1(1.,OV(II,JJ))                             
187            ENDIF
188  924     CONTINUE                                                     
189 9000   CONTINUE                                                       
190        DO 925 JJ=N2STAR,N2END                                         
191          DO 925 II=N1STAR,N1END                                       
192            IF ( icmask(II,JJ) ) XF(II,JJ,IIM)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))               
193  925     CONTINUE
194                                                                       
195!                                                                       
196 2000 CONTINUE                                                         
197      RETURN                                                           
198      END                                                               
199                                                                       
200! Version of sint that replaces mask with detailed ranges for avoiding boundaries
201! may help performance by getting the conditionals out of innner loops
202
203      SUBROUTINE SINTB(XF1, XF ,                  &
204                   ims, ime, jms, jme, icmask ,  &
205                   its, ite, jts, jte, nf, xstag, ystag )
206      IMPLICIT NONE
207      INTEGER ims, ime, jms, jme, &
208              its, ite, jts, jte
209
210      LOGICAL icmask( ims:ime, jms:jme )
211      LOGICAL xstag, ystag
212
213      INTEGER nf, ior
214      REAL    one12, one24, ep
215      PARAMETER(one12=1./12.,one24=1./24.)                             
216      PARAMETER(ior=2)                       
217!                                                                       
218      REAL XF(ims:ime,jms:jme,NF)
219      REAL XF1(ims:ime,jms:jme,NF)
220!                                                                       
221      REAL Y(ims:ime,jms:jme,-IOR:IOR),    &
222           Z(ims:ime,jms:jme,-IOR:IOR),    &
223           F(ims:ime,jms:jme,0:1)                                       
224!
225      INTEGER I,J,II,JJ,IIM
226      INTEGER N2STAR, N2END, N1STAR, N1END
227!                                                                       
228      DATA  EP/ 1.E-10/                                                 
229!                                                                       
230!      PARAMETER(NONOS=1)                                               
231!      PARAMETER(N1OS=N1*NONOS+1-NONOS,N2OS=N2*NONOS+1-NONOS)           
232!                                                                       
233      REAL W(ims:ime,jms:jme),OV(ims:ime,jms:jme),UN(ims:ime,jms:jme)                     
234      REAL MXM(ims:ime,jms:jme),MN(ims:ime,jms:jme)                                 
235      REAL FL(ims:ime,jms:jme,0:1)                                           
236      REAL XIG(NF*NF), XJG(NF*NF)  ! NF is the parent to child grid refinement ratio
237      integer rr
238
239      REAL rioff, rjoff
240!                                                                       
241      REAL donor, y1, y2, a
242      DONOR(Y1,Y2,A)=(Y1*AMAX1(0.,SIGN(1.,A))-Y2*AMIN1(0.,SIGN(1.,A)))*A
243      REAL tr4, ym1, y0, yp1, yp2
244      TR4(YM1,Y0,YP1,YP2,A)=A*ONE12*(7.*(YP1+Y0)-(YP2+YM1))               &
245       -A*A*ONE24*(15.*(YP1-Y0)-(YP2-YM1))-A*A*A*ONE12*((YP1+Y0)          &
246       -(YP2+YM1))+A*A*A*A*ONE24*(3.*(YP1-Y0)-(YP2-YM1))               
247      REAL pp, pn, x
248      PP(X)=AMAX1(0.,X)                                                 
249      PN(X)=AMIN1(0.,X)                                                 
250
251      rr = nint(sqrt(float(nf)))
252
253      rioff = 0
254      rjoff = 0
255      if(xstag .and. (mod(rr,2) .eq. 0)) rioff = 1.
256      if(ystag .and. (mod(rr,2) .eq. 0)) rjoff = 1.
257
258      DO I=1,rr
259        DO J=1,rr
260          XIG(J+(I-1)*rr)=(float(rr)-1.-rioff)/float(2*rr)-FLOAT(J-1)*1./float(rr)
261          XJG(J+(I-1)*rr)=(float(rr)-1.-rjoff)/float(2*rr)-FLOAT(I-1)*1./float(rr)   
262        ENDDO
263      ENDDO
264
265      N2STAR = jts
266      N2END  = jte
267      N1STAR = its
268      N1END  = ite
269
270      DO 2000 IIM=1,NF                                                 
271!                                                                       
272!  HERE STARTS RESIDUAL ADVECTION                                       
273!                                                                       
274        DO 9000 JJ=N2STAR,N2END                                         
275!cdir unroll=5
276          DO 50 J=-IOR,IOR                                             
277
278!cdir unroll=5
279            DO 51 I=-IOR,IOR                                           
280              DO 511 II=N1STAR,N1END                                   
281                Y(II,JJ,I)=XF1(II+I,JJ+J,IIM)             
282  511         CONTINUE
283   51       CONTINUE                                                   
284
285            DO 811 II=N1STAR,N1END                                     
286              FL(II,JJ,0)=DONOR(Y(II,JJ,-1),Y(II,JJ,0),XIG(IIM))       
287              FL(II,JJ,1)=DONOR(Y(II,JJ,0),Y(II,JJ,1),XIG(IIM))           
288  811         CONTINUE
289            DO 812 II=N1STAR,N1END                                     
290              W(II,JJ)=Y(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))               
291  812         CONTINUE
292            DO 813 II=N1STAR,N1END                                     
293              MXM(II,JJ)=                                             &
294                       AMAX1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),       &
295                       W(II,JJ))                                     
296              MN(II,JJ)=AMIN1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),W(II,JJ))
297  813         CONTINUE
298            DO 312 II=N1STAR,N1END                                     
299              F(II,JJ,0)=                                               &
300                         TR4(Y(II,JJ,-2),Y(II,JJ,-1),Y(II,JJ,0),        &
301                         Y(II,JJ,1),XIG(IIM))                           
302              F(II,JJ,1)=                                                 &
303                       TR4(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),Y(II,JJ,2),&
304                       XIG(IIM))                                       
305  312         CONTINUE
306            DO 822 II=N1STAR,N1END                                     
307              F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)                         
308              F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)                           
309  822         CONTINUE
310            DO 823 II=N1STAR,N1END                                     
311              OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+         &
312                      PP(F(II,JJ,0))+EP)                             
313              UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-             &
314                    PN(F(II,JJ,0))+EP)                               
315  823         CONTINUE
316            DO 824 II=N1STAR,N1END                                     
317              F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+            &
318                         PN(F(II,JJ,0))*AMIN1(1.,UN(II,JJ))             
319              F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+            &
320                         PN(F(II,JJ,1))*AMIN1(1.,OV(II,JJ))             
321  824         CONTINUE                                                   
322            DO 825 II=N1STAR,N1END                                     
323              Y(II,JJ,0)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))                 
324  825         CONTINUE
325            DO 361 II=N1STAR,N1END                                     
326              Z(II,JJ,J)=Y(II,JJ,0)                                       
327  361         CONTINUE
328!                                                                       
329!  END IF FIRST J LOOP                                                 
330!                                                                       
331 8000       CONTINUE                                                   
332   50     CONTINUE                                                     
333
334          DO 911 II=N1STAR,N1END                                       
335            FL(II,JJ,0)=DONOR(Z(II,JJ,-1),Z(II,JJ,0),XJG(IIM))         
336            FL(II,JJ,1)=DONOR(Z(II,JJ,0),Z(II,JJ,1),XJG(IIM))             
337  911       CONTINUE
338          DO 912 II=N1STAR,N1END                                       
339            W(II,JJ)=Z(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))                 
340  912       CONTINUE
341          DO 913 II=N1STAR,N1END                                       
342            MXM(II,JJ)=AMAX1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))
343            MN(II,JJ)=AMIN1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))   
344  913       CONTINUE
345          DO 412 II=N1STAR,N1END                                       
346            F(II,JJ,0)=                                                 &
347                       TR4(Z(II,JJ,-2),Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1)&
348                       ,XJG(IIM))                                       
349            F(II,JJ,1)=                                                   &
350                       TR4(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),Z(II,JJ,2),  &
351                       XJG(IIM))                                         
352  412       CONTINUE
353          DO 922 II=N1STAR,N1END                                       
354            F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)                           
355            F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)                             
356  922       CONTINUE
357          DO 923 II=N1STAR,N1END                                       
358            OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+           &
359                      PP(F(II,JJ,0))+EP)                               
360            UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-PN(F(II,JJ,0))+ &
361                    EP)                                                 
362  923       CONTINUE
363          DO 924 II=N1STAR,N1END                                       
364            F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+PN(F(II,JJ,0))  &
365                       *AMIN1(1.,UN(II,JJ))                             
366            F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+PN(F(II,JJ,1))  &
367                       *AMIN1(1.,OV(II,JJ))                             
368  924     CONTINUE                                                     
369 9000   CONTINUE                                                       
370        DO 925 JJ=N2STAR,N2END                                         
371          DO 925 II=N1STAR,N1END                                       
372            XF(II,JJ,IIM)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))               
373  925     CONTINUE
374                                                                       
375!                                                                       
376 2000 CONTINUE                                                         
377      RETURN                                                           
378      END                                                               
379                                                                       
380
Note: See TracBrowser for help on using the repository browser.