/[lmdze]/trunk/Sources/dyn3d/PPM3d/filcr.f
ViewVC logotype

Contents of /trunk/Sources/dyn3d/PPM3d/filcr.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 166 - (show annotations)
Wed Jul 29 14:32:55 2015 UTC (8 years, 10 months ago) by guez
File size: 2295 byte(s) 
Split ppm3d.f into files containing a single procedure.

Factorized computations of filtering matrices into a procedure
inifilr_hemisph. Had then to change the matrices from allocatable to
pointer and from customized lower bound to lower bound 1. The change
in lower bounds does not matter because the matrices are only used as
a whole as actual arguments.

Also, in infilr, instead of finding jfilt[ns][uv] from approximately
jjm /2, start at index j1 that corresponds to the equator. This is not
the same if there is a zoom in latitude.

Also, the test (rlamda(modfrst[ns][uv](j)) * cos(rlat[uv](j)) < 1) in
the loops on filtered latitudes is not useful now that we start from
j1: it is necessarily true. See notes.

Just encapsulated lwvn into a module and removed unused argument ktraer.
1 SUBROUTINE filcr(q, imr, jnp, j1, j2, cosp, acosp, icr, tiny)
2 DIMENSION q(imr, *), cosp(*), acosp(*)
3
4 icr = 0
5 DO j = j1 + 1, j2 - 1
6 DO i = 1, imr - 1
7 IF (q(i,j)<0.) THEN
8 icr = 1
9 dq = -q(i, j)*cosp(j)
10 ! N-E
11 dn = q(i+1, j+1)*cosp(j+1)
12 d0 = max(0., dn)
13 d1 = min(dq, d0)
14 q(i+1, j+1) = (dn-d1)*acosp(j+1)
15 dq = dq - d1
16 ! S-E
17 ds = q(i+1, j-1)*cosp(j-1)
18 d0 = max(0., ds)
19 d2 = min(dq, d0)
20 q(i+1, j-1) = (ds-d2)*acosp(j-1)
21 q(i, j) = (d2-dq)*acosp(j) + tiny
22 END IF
23 END DO
24 IF (icr==0 .AND. q(imr,j)>=0.) GO TO 65
25 DO i = 2, imr
26 IF (q(i,j)<0.) THEN
27 icr = 1
28 dq = -q(i, j)*cosp(j)
29 ! N-W
30 dn = q(i-1, j+1)*cosp(j+1)
31 d0 = max(0., dn)
32 d1 = min(dq, d0)
33 q(i-1, j+1) = (dn-d1)*acosp(j+1)
34 dq = dq - d1
35 ! S-W
36 ds = q(i-1, j-1)*cosp(j-1)
37 d0 = max(0., ds)
38 d2 = min(dq, d0)
39 q(i-1, j-1) = (ds-d2)*acosp(j-1)
40 q(i, j) = (d2-dq)*acosp(j) + tiny
41 END IF
42 END DO
43 ! *****************************************
44 ! i=1
45 i = 1
46 IF (q(i,j)<0.) THEN
47 icr = 1
48 dq = -q(i, j)*cosp(j)
49 ! N-W
50 dn = q(imr, j+1)*cosp(j+1)
51 d0 = max(0., dn)
52 d1 = min(dq, d0)
53 q(imr, j+1) = (dn-d1)*acosp(j+1)
54 dq = dq - d1
55 ! S-W
56 ds = q(imr, j-1)*cosp(j-1)
57 d0 = max(0., ds)
58 d2 = min(dq, d0)
59 q(imr, j-1) = (ds-d2)*acosp(j-1)
60 q(i, j) = (d2-dq)*acosp(j) + tiny
61 END IF
62 ! *****************************************
63 ! i=IMR
64 i = imr
65 IF (q(i,j)<0.) THEN
66 icr = 1
67 dq = -q(i, j)*cosp(j)
68 ! N-E
69 dn = q(1, j+1)*cosp(j+1)
70 d0 = max(0., dn)
71 d1 = min(dq, d0)
72 q(1, j+1) = (dn-d1)*acosp(j+1)
73 dq = dq - d1
74 ! S-E
75 ds = q(1, j-1)*cosp(j-1)
76 d0 = max(0., ds)
77 d2 = min(dq, d0)
78 q(1, j-1) = (ds-d2)*acosp(j-1)
79 q(i, j) = (d2-dq)*acosp(j) + tiny
80 END IF
81 ! *****************************************
82 65 END DO
83
84 DO i = 1, imr
85 IF (q(i,j1)<0. .OR. q(i,j2)<0.) THEN
86 icr = 1
87 GO TO 80
88 END IF
89 END DO
90
91 80 CONTINUE
92
93 IF (q(1,1)<0. .OR. q(1,jnp)<0.) THEN
94 icr = 1
95 END IF
96
97 RETURN
98 END SUBROUTINE filcr
99
  ViewVC Help
Powered by ViewVC 1.1.21