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

Contents of /trunk/Sources/dyn3d/PPM3d/qckxyz.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: 2312 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 qckxyz(q, qtmp, imr, jnp, nlay, j1, j2, cosp, acosp, cross, ic, &
2 nstep)
3
4 PARAMETER (tiny=1.E-60)
5 DIMENSION q(imr, jnp, nlay), qtmp(imr, jnp), cosp(*), acosp(*)
6 LOGICAL cross
7
8 nlaym1 = nlay - 1
9 len = imr*(j2-j1+1)
10 ip = 0
11
12 ! Top layer
13 l = 1
14 icr = 1
15 CALL filns(q(1,1,l), imr, jnp, j1, j2, cosp, acosp, ipy, tiny)
16 IF (ipy==0) GO TO 50
17 CALL filew(q(1,1,l), qtmp, imr, jnp, j1, j2, ipx, tiny)
18 IF (ipx==0) GO TO 50
19
20 IF (cross) THEN
21 CALL filcr(q(1,1,l), imr, jnp, j1, j2, cosp, acosp, icr, tiny)
22 END IF
23 IF (icr==0) GO TO 50
24
25 ! Vertical filling...
26 DO i = 1, len
27 IF (q(i,j1,1)<0.) THEN
28 ip = ip + 1
29 q(i, j1, 2) = q(i, j1, 2) + q(i, j1, 1)
30 q(i, j1, 1) = 0.
31 END IF
32 END DO
33
34 50 CONTINUE
35 DO l = 2, nlaym1
36 icr = 1
37
38 CALL filns(q(1,1,l), imr, jnp, j1, j2, cosp, acosp, ipy, tiny)
39 IF (ipy==0) GO TO 225
40 CALL filew(q(1,1,l), qtmp, imr, jnp, j1, j2, ipx, tiny)
41 IF (ipx==0) GO TO 225
42 IF (cross) THEN
43 CALL filcr(q(1,1,l), imr, jnp, j1, j2, cosp, acosp, icr, tiny)
44 END IF
45 IF (icr==0) GO TO 225
46
47 DO i = 1, len
48 IF (q(i,j1,l)<0.) THEN
49
50 ip = ip + 1
51 ! From above
52 qup = q(i, j1, l-1)
53 qly = -q(i, j1, l)
54 dup = min(qly, qup)
55 q(i, j1, l-1) = qup - dup
56 q(i, j1, l) = dup - qly
57 ! Below
58 q(i, j1, l+1) = q(i, j1, l+1) + q(i, j1, l)
59 q(i, j1, l) = 0.
60 END IF
61 END DO
62 225 END DO
63
64 ! BOTTOM LAYER
65 sum = 0.
66 l = nlay
67
68 CALL filns(q(1,1,l), imr, jnp, j1, j2, cosp, acosp, ipy, tiny)
69 IF (ipy==0) GO TO 911
70 CALL filew(q(1,1,l), qtmp, imr, jnp, j1, j2, ipx, tiny)
71 IF (ipx==0) GO TO 911
72
73 CALL filcr(q(1,1,l), imr, jnp, j1, j2, cosp, acosp, icr, tiny)
74 IF (icr==0) GO TO 911
75
76 DO i = 1, len
77 IF (q(i,j1,l)<0.) THEN
78 ip = ip + 1
79
80 ! From above
81
82 qup = q(i, j1, nlaym1)
83 qly = -q(i, j1, l)
84 dup = min(qly, qup)
85 q(i, j1, nlaym1) = qup - dup
86 ! From "below" the surface.
87 sum = sum + qly - dup
88 q(i, j1, l) = 0.
89 END IF
90 END DO
91
92 911 CONTINUE
93
94 IF (ip>imr) THEN
95 WRITE (6, *) 'IC=', ic, ' STEP=', nstep, ' Vertical filling pts=', ip
96 END IF
97
98 IF (sum>1.E-25) THEN
99 WRITE (6, *) ic, nstep, ' Mass source from the ground=', sum
100 END IF
101 RETURN
102 END SUBROUTINE qckxyz
103
  ViewVC Help
Powered by ViewVC 1.1.21