source: LMDZ6/branches/Amaury_dev/libf/phylmdiso/cv3a_compress.F90 @ 5119

Last change on this file since 5119 was 5117, checked in by abarral, 4 months ago

rename modules properly lmdz_*
move some unused files to obsolete/
(lint) uppercase fortran keywords
  • Property svn:keywords set to Id
File size: 10.4 KB
RevLine 
[3927]1SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, compress, &
2                         iflag1, nk1, icb1, icbs1, &
3                         plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, &
4                         wghti1, pbase1, buoybase1, &
5                         t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &
6                         u1, v1, gz1, th1, th1_wake, &
7                         tra1, &
8                         h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
9                         h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, &
10                         sig1, w01, ptop21, &
11                         Ale1, Alp1, omega1, &
12                         iflag, nk, icb, icbs, &
13                         plcl, tnk, qnk, gznk, hnk, unk, vnk, &
14                         wghti, pbase, buoybase, &
15                         t, q, qs, t_wake, q_wake, qs_wake, s_wake, &
16                         u, v, gz, th, th_wake, &
17                         tra, &
18                         h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, &
19                         h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, &
20                         sig, w0, ptop2, &
21                         Ale, Alp, omega &
22#ifdef ISO
[5087]23          ,xtnk1,xt1,xt1_wake,xtclw1 &
24          ,xtnk,xt,xt_wake,xtclw &
[3927]25#endif
[5087]26          )
[3927]27  ! **************************************************************
28  ! *
29  ! CV3A_COMPRESS                                               *
30  ! *
31  ! *
32  ! written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
33  ! modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.28.09    *
34  ! **************************************************************
35#ifdef ISO
[5117]36    USE infotrac_phy, ONLY: ntraciso=>ntiso
37    USE isotopes_mod, ONLY: essai_convergence, iso_eau,iso_HDO
[3927]38#ifdef ISOVERIF
[5117]39    USE isotopes_verif_mod
[3927]40#endif
41#endif
42
43  IMPLICIT NONE
44
45  include "cv3param.h"
46
47  ! inputs:
48  INTEGER, INTENT (IN)                               :: len, nloc, nd, ntra
49!jyg<
50  LOGICAL, INTENT (IN)                               :: compress  ! compression is performed if compress is true
51!>jyg
52  INTEGER, DIMENSION (len), INTENT (IN)              :: iflag1, nk1, icb1, icbs1
53  REAL, DIMENSION (len), INTENT (IN)                 :: plcl1, tnk1, qnk1, gznk1
54  REAL, DIMENSION (len), INTENT (IN)                 :: hnk1, unk1, vnk1
55  REAL, DIMENSION (len, nd), INTENT (IN)             :: wghti1(len, nd)
56  REAL, DIMENSION (len), INTENT (IN)                 :: pbase1, buoybase1
57  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1, q1, qs1
58  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1_wake, q1_wake, qs1_wake
59  REAL, DIMENSION (len), INTENT (IN)                 :: s1_wake
60  REAL, DIMENSION (len, nd), INTENT (IN)             :: u1, v1
61  REAL, DIMENSION (len, nd), INTENT (IN)             :: gz1, th1, th1_wake
62  REAL, DIMENSION (len, nd,ntra), INTENT (IN)        :: tra1
63  REAL, DIMENSION (len, nd), INTENT (IN)             :: h1, lv1, lf1, cpn1
64  REAL, DIMENSION (len, nd), INTENT (IN)             :: p1
65  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: ph1(len, nd+1)
66  REAL, DIMENSION (len, nd), INTENT (IN)             :: tv1, tp1
67  REAL, DIMENSION (len, nd), INTENT (IN)             :: tvp1, clw1
68  REAL, DIMENSION (len, nd), INTENT (IN)             :: h1_wake, lv1_wake, cpn1_wake
69  REAL, DIMENSION (len, nd), INTENT (IN)             :: tv1_wake, lf1_wake
70  REAL, DIMENSION (len, nd), INTENT (IN)             :: sig1, w01
71  REAL, DIMENSION (len), INTENT (IN)                 :: ptop21
72  REAL, DIMENSION (len), INTENT (IN)                 :: Ale1, Alp1
73  REAL, DIMENSION (len, nd), INTENT (IN)             :: omega1
74#ifdef ISO
75  REAL, DIMENSION (ntraciso,len,nd), INTENT (IN)     :: xtclw1
76  REAL, DIMENSION (ntraciso,len), INTENT (IN)        :: xtnk1
77  REAL, DIMENSION (ntraciso,len,nd), INTENT (IN)     :: xt1
78  REAL, DIMENSION (ntraciso,len,nd), INTENT (IN)     :: xt1_wake
79#endif
[5099]80
[3927]81  ! in/out
82  INTEGER, INTENT (INOUT)                            :: ncum
[5099]83
[3927]84  ! outputs:
85  ! en fait, on a nloc=len pour l'instant (cf cv_driver)
86  INTEGER, DIMENSION (nloc), INTENT (OUT)            ::  iflag, nk, icb, icbs
87  REAL, DIMENSION (nloc), INTENT (OUT)               ::  plcl, tnk, qnk, gznk
88  REAL, DIMENSION (nloc), INTENT (OUT)               ::  hnk, unk, vnk
89  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  wghti
90  REAL, DIMENSION (nloc), INTENT (OUT)               ::  pbase, buoybase
91  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  t, q, qs
92  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  t_wake, q_wake, qs_wake
93  REAL, DIMENSION (nloc), INTENT (OUT)               ::  s_wake
94  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  u, v
95  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  gz, th, th_wake
96  REAL, DIMENSION (nloc, nd,ntra), INTENT (OUT)      ::  tra
97  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  h, lv, lf, cpn
98  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  p
99  REAL, DIMENSION (nloc, nd+1), INTENT (OUT)         ::  ph
100  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tv, tp
101  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tvp, clw
102  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  h_wake, lv_wake, cpn_wake
103  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tv_wake, lf_wake
104  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  sig, w0
105  REAL, DIMENSION (nloc), INTENT (OUT)               ::  ptop2
106  REAL, DIMENSION (nloc), INTENT (OUT)               ::  Ale, Alp
107  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  omega
108#ifdef ISO   
109  REAL, DIMENSION (ntraciso,nloc), INTENT (OUT)      ::  xtnk
110  REAL, DIMENSION (ntraciso,nloc, nd), INTENT (OUT)  ::  xtclw
111  REAL, DIMENSION (ntraciso,nloc, nd), INTENT (OUT)  ::  xt
112  REAL, DIMENSION (ntraciso,nloc, nd), INTENT (OUT)  ::  xt_wake
113#endif
114
115  ! local variables:
116  INTEGER i, k, nn, j
117#ifdef ISO 
[5117]118      INTEGER ixt
[3927]119#endif
120
121  CHARACTER (LEN=20) :: modname = 'cv3a_compress'
122  CHARACTER (LEN=80) :: abort_message
123
124#ifdef ISOVERIF
[5116]125        WRITE(*,*) 'compress=',   compress
126        WRITE(*,*) 'nl=',nl
[3927]127#endif
128!jyg<
129  IF (compress) THEN
130!>jyg
131
132  DO k = 1, nl + 1
133    nn = 0
134    DO i = 1, len
135      IF (iflag1(i)==0) THEN
136        nn = nn + 1
137        wghti(nn, k) = wghti1(i, k)
138        t(nn, k) = t1(i, k)
139        q(nn, k) = q1(i, k)
140        qs(nn, k) = qs1(i, k)
141        t_wake(nn, k) = t1_wake(i, k)
142        q_wake(nn, k) = q1_wake(i, k)
143        qs_wake(nn, k) = qs1_wake(i, k)
144        u(nn, k) = u1(i, k)
145        v(nn, k) = v1(i, k)
146        gz(nn, k) = gz1(i, k)
147        th(nn, k) = th1(i, k)
148        th_wake(nn, k) = th1_wake(i, k)
149        h(nn, k) = h1(i, k)
150        lv(nn, k) = lv1(i, k)
151        lf(nn, k) = lf1(i, k)
152        cpn(nn, k) = cpn1(i, k)
153        p(nn, k) = p1(i, k)
154        ph(nn, k) = ph1(i, k)
155        tv(nn, k) = tv1(i, k)
156        tp(nn, k) = tp1(i, k)
157        tvp(nn, k) = tvp1(i, k)
158        clw(nn, k) = clw1(i, k)
159        h_wake(nn, k) = h1_wake(i, k)
160        lv_wake(nn, k) = lv1_wake(i, k)
161        lf_wake(nn, k) = lf1_wake(i, k)
162        cpn_wake(nn, k) = cpn1_wake(i, k)
163        tv_wake(nn, k) = tv1_wake(i, k)
164        sig(nn, k) = sig1(i, k)
165        w0(nn, k) = w01(i, k)
166        omega(nn, k) = omega1(i, k)
167#ifdef ISO
168        do ixt=1,ntraciso
169          xt(ixt,nn,k)=xt1(ixt,i,k)
170          xt_wake(ixt,nn,k)=xt1_wake(ixt,i,k)
171          xtclw(ixt,nn,k)=xtclw1(ixt,i,k)
172        enddo
173#endif
174      END IF
175    END DO
176  END DO
[5099]177
[3927]178  ! AC!      do 121 j=1,ntra
179  ! AC!ccccc      do 111 k=1,nl+1
180  ! AC!      do 111 k=1,nd
181  ! AC!       nn=0
182  ! AC!      do 101 i=1,len
[5117]183  ! AC!      IF(iflag1(i).EQ.0)THEN
[3927]184  ! AC!       nn=nn+1
185  ! AC!       tra(nn,k,j)=tra1(i,k,j)
186  ! AC!      endif
187  ! AC! 101  continue
188  ! AC! 111  continue
189  ! AC! 121  continue
190
191  IF (nn/=ncum) THEN
192    PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum
193    abort_message = ''
194    CALL abort_physic(modname, abort_message, 1)
195  END IF
196
197  nn = 0
198  DO i = 1, len
199    IF (iflag1(i)==0) THEN
200      nn = nn + 1
201      s_wake(nn) = s1_wake(i)
202      iflag(nn) = iflag1(i)
203      nk(nn) = nk1(i)
204      icb(nn) = icb1(i)
205      icbs(nn) = icbs1(i)
206      plcl(nn) = plcl1(i)
207      tnk(nn) = tnk1(i)
208      qnk(nn) = qnk1(i)
209      gznk(nn) = gznk1(i)
210      hnk(nn) = hnk1(i)
211      unk(nn) = unk1(i)
212      vnk(nn) = vnk1(i)
213      pbase(nn) = pbase1(i)
214      buoybase(nn) = buoybase1(i)
215      sig(nn, nd) = sig1(i, nd)
216      ptop2(nn) = ptop2(i)
217      Ale(nn) = Ale1(i)
218      Alp(nn) = Alp1(i)
219#ifdef ISO
220        do ixt=1,ntraciso
221          xtnk(ixt,nn)=xtnk1(ixt,i)
222        enddo
223#endif
224    END IF
225  END DO
226
227  IF (nn/=ncum) THEN
228    PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum
229    abort_message = ''
230    CALL abort_physic(modname, abort_message, 1)
231  END IF
[5099]232
[3927]233!jyg<
234  ELSE  !(compress)
[5099]235
[3927]236      ncum = len
[5099]237
[3927]238      wghti(:,1:nl+1) = wghti1(:,1:nl+1)
239      t(:,1:nl+1) = t1(:,1:nl+1)
240      q(:,1:nl+1) = q1(:,1:nl+1)
241      qs(:,1:nl+1) = qs1(:,1:nl+1)
242      t_wake(:,1:nl+1) = t1_wake(:,1:nl+1)
243      q_wake(:,1:nl+1) = q1_wake(:,1:nl+1)
244      qs_wake(:,1:nl+1) = qs1_wake(:,1:nl+1)
245      u(:,1:nl+1) = u1(:,1:nl+1)
246      v(:,1:nl+1) = v1(:,1:nl+1)
247      gz(:,1:nl+1) = gz1(:,1:nl+1)
248      th(:,1:nl+1) = th1(:,1:nl+1)
249      th_wake(:,1:nl+1) = th1_wake(:,1:nl+1)
250      h(:,1:nl+1) = h1(:,1:nl+1)
251      lv(:,1:nl+1) = lv1(:,1:nl+1)
252      lf(:,1:nl+1) = lf1(:,1:nl+1)
253      cpn(:,1:nl+1) = cpn1(:,1:nl+1)
254      p(:,1:nl+1) = p1(:,1:nl+1)
255      ph(:,1:nl+1) = ph1(:,1:nl+1)
256      tv(:,1:nl+1) = tv1(:,1:nl+1)
257      tp(:,1:nl+1) = tp1(:,1:nl+1)
258      tvp(:,1:nl+1) = tvp1(:,1:nl+1)
259      clw(:,1:nl+1) = clw1(:,1:nl+1)
260      h_wake(:,1:nl+1) = h1_wake(:,1:nl+1)
261      lv_wake(:,1:nl+1) = lv1_wake(:,1:nl+1)
262      lf_wake(:,1:nl+1) = lf1_wake(:,1:nl+1)
263      cpn_wake(:,1:nl+1) = cpn1_wake(:,1:nl+1)
264      tv_wake(:,1:nl+1) = tv1_wake(:,1:nl+1)
265      sig(:,1:nl+1) = sig1(:,1:nl+1)
266      w0(:,1:nl+1) = w01(:,1:nl+1)
267      omega(:,1:nl+1) = omega1(:,1:nl+1)
268#ifdef ISO
269      xt(:,:,1:nl+1) = xt1(:,:,1:nl+1)
270      xtclw(:,:,1:nl+1) = xtclw1(:,:,1:nl+1)
271      xt_wake(:,:,1:nl+1) = xt1_wake(:,:,1:nl+1)
272#endif
[5099]273
[3927]274      s_wake(:) = s1_wake(:)
275      iflag(:) = iflag1(:)
276      nk(:) = nk1(:)
277      icb(:) = icb1(:)
278      icbs(:) = icbs1(:)
279      plcl(:) = plcl1(:)
280      tnk(:) = tnk1(:)
281      qnk(:) = qnk1(:)
282      gznk(:) = gznk1(:)
283      hnk(:) = hnk1(:)
284      unk(:) = unk1(:)
285      vnk(:) = vnk1(:)
286      pbase(:) = pbase1(:)
287      buoybase(:) = buoybase1(:)
288      sig(:, nd) = sig1(:, nd)
289      ptop2(:) = ptop2(:)
290      Ale(:) = Ale1(:)
291      Alp(:) = Alp1(:)
292#ifdef ISO
293      xtnk(:,:) = xtnk1(:,:)
294#endif
[5099]295
[3927]296  ENDIF !(compress)
297!>jyg
298
[5105]299
[3927]300END SUBROUTINE cv3a_compress
Note: See TracBrowser for help on using the repository browser.