source: LMDZ6/branches/Amaury_dev/libf/phylmd/cv3a_compress.F90 @ 5133

Last change on this file since 5133 was 5117, checked in by abarral, 5 months ago

rename modules properly lmdz_*
move some unused files to obsolete/
(lint) uppercase fortran keywords
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.0 KB
RevLine 
[2253]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)
[1992]22  ! **************************************************************
23  ! *
24  ! CV3A_COMPRESS                                               *
25  ! *
26  ! *
27  ! written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
28  ! modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.28.09    *
29  ! **************************************************************
[5111]30USE lmdz_abort_physic, ONLY: abort_physic
[1992]31  IMPLICIT NONE
[879]32
[1992]33  include "cv3param.h"
[879]34
[1992]35  ! inputs:
[2253]36  INTEGER, INTENT (IN)                               :: len, nloc, nd, ntra
37!jyg<
38  LOGICAL, INTENT (IN)                               :: compress  ! compression is performed if compress is true
39!>jyg
40  INTEGER, DIMENSION (len), INTENT (IN)              :: iflag1, nk1, icb1, icbs1
41  REAL, DIMENSION (len), INTENT (IN)                 :: plcl1, tnk1, qnk1, gznk1
42  REAL, DIMENSION (len), INTENT (IN)                 :: hnk1, unk1, vnk1
43  REAL, DIMENSION (len, nd), INTENT (IN)             :: wghti1(len, nd)
44  REAL, DIMENSION (len), INTENT (IN)                 :: pbase1, buoybase1
45  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1, q1, qs1
46  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1_wake, q1_wake, qs1_wake
47  REAL, DIMENSION (len), INTENT (IN)                 :: s1_wake
48  REAL, DIMENSION (len, nd), INTENT (IN)             :: u1, v1
49  REAL, DIMENSION (len, nd), INTENT (IN)             :: gz1, th1, th1_wake
50  REAL, DIMENSION (len, nd,ntra), INTENT (IN)        :: tra1
51  REAL, DIMENSION (len, nd), INTENT (IN)             :: h1, lv1, lf1, cpn1
52  REAL, DIMENSION (len, nd), INTENT (IN)             :: p1
53  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: ph1(len, nd+1)
54  REAL, DIMENSION (len, nd), INTENT (IN)             :: tv1, tp1
55  REAL, DIMENSION (len, nd), INTENT (IN)             :: tvp1, clw1
56  REAL, DIMENSION (len, nd), INTENT (IN)             :: h1_wake, lv1_wake, cpn1_wake
57  REAL, DIMENSION (len, nd), INTENT (IN)             :: tv1_wake, lf1_wake
58  REAL, DIMENSION (len, nd), INTENT (IN)             :: sig1, w01
59  REAL, DIMENSION (len), INTENT (IN)                 :: ptop21
60  REAL, DIMENSION (len), INTENT (IN)                 :: Ale1, Alp1
61  REAL, DIMENSION (len, nd), INTENT (IN)             :: omega1
[5099]62
[2253]63  ! in/out
64  INTEGER, INTENT (INOUT)                            :: ncum
[5099]65
[1992]66  ! outputs:
67  ! en fait, on a nloc=len pour l'instant (cf cv_driver)
[2253]68  INTEGER, DIMENSION (nloc), INTENT (OUT)            ::  iflag, nk, icb, icbs
69  REAL, DIMENSION (nloc), INTENT (OUT)               ::  plcl, tnk, qnk, gznk
70  REAL, DIMENSION (nloc), INTENT (OUT)               ::  hnk, unk, vnk
71  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  wghti
72  REAL, DIMENSION (nloc), INTENT (OUT)               ::  pbase, buoybase
73  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  t, q, qs
74  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  t_wake, q_wake, qs_wake
75  REAL, DIMENSION (nloc), INTENT (OUT)               ::  s_wake
76  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  u, v
77  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  gz, th, th_wake
78  REAL, DIMENSION (nloc, nd,ntra), INTENT (OUT)      ::  tra
79  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  h, lv, lf, cpn
80  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  p
81  REAL, DIMENSION (nloc, nd+1), INTENT (OUT)         ::  ph
82  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tv, tp
83  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tvp, clw
84  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  h_wake, lv_wake, cpn_wake
85  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tv_wake, lf_wake
86  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  sig, w0
87  REAL, DIMENSION (nloc), INTENT (OUT)               ::  ptop2
88  REAL, DIMENSION (nloc), INTENT (OUT)               ::  Ale, Alp
89  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  omega
[879]90
[1992]91  ! local variables:
92  INTEGER i, k, nn, j
[879]93
[1992]94  CHARACTER (LEN=20) :: modname = 'cv3a_compress'
95  CHARACTER (LEN=80) :: abort_message
[1403]96
[2253]97!jyg<
98  IF (compress) THEN
99!>jyg
[879]100
[1992]101  DO k = 1, nl + 1
102    nn = 0
103    DO i = 1, len
104      IF (iflag1(i)==0) THEN
105        nn = nn + 1
106        wghti(nn, k) = wghti1(i, k)
107        t(nn, k) = t1(i, k)
108        q(nn, k) = q1(i, k)
109        qs(nn, k) = qs1(i, k)
110        t_wake(nn, k) = t1_wake(i, k)
111        q_wake(nn, k) = q1_wake(i, k)
112        qs_wake(nn, k) = qs1_wake(i, k)
113        u(nn, k) = u1(i, k)
114        v(nn, k) = v1(i, k)
115        gz(nn, k) = gz1(i, k)
116        th(nn, k) = th1(i, k)
117        th_wake(nn, k) = th1_wake(i, k)
118        h(nn, k) = h1(i, k)
119        lv(nn, k) = lv1(i, k)
120        lf(nn, k) = lf1(i, k)
121        cpn(nn, k) = cpn1(i, k)
122        p(nn, k) = p1(i, k)
123        ph(nn, k) = ph1(i, k)
124        tv(nn, k) = tv1(i, k)
125        tp(nn, k) = tp1(i, k)
126        tvp(nn, k) = tvp1(i, k)
127        clw(nn, k) = clw1(i, k)
128        h_wake(nn, k) = h1_wake(i, k)
129        lv_wake(nn, k) = lv1_wake(i, k)
130        lf_wake(nn, k) = lf1_wake(i, k)
131        cpn_wake(nn, k) = cpn1_wake(i, k)
132        tv_wake(nn, k) = tv1_wake(i, k)
133        sig(nn, k) = sig1(i, k)
134        w0(nn, k) = w01(i, k)
[2201]135        omega(nn, k) = omega1(i, k)
[1992]136      END IF
137    END DO
138  END DO
[5099]139
[1992]140  ! AC!      do 121 j=1,ntra
141  ! AC!ccccc      do 111 k=1,nl+1
142  ! AC!      do 111 k=1,nd
143  ! AC!       nn=0
144  ! AC!      do 101 i=1,len
[5117]145  ! AC!      IF(iflag1(i).EQ.0)THEN
[1992]146  ! AC!       nn=nn+1
147  ! AC!       tra(nn,k,j)=tra1(i,k,j)
148  ! AC!      endif
149  ! AC! 101  continue
150  ! AC! 111  continue
151  ! AC! 121  continue
[879]152
[1992]153  IF (nn/=ncum) THEN
154    PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum
155    abort_message = ''
[2311]156    CALL abort_physic(modname, abort_message, 1)
[1992]157  END IF
158
159  nn = 0
160  DO i = 1, len
161    IF (iflag1(i)==0) THEN
162      nn = nn + 1
163      s_wake(nn) = s1_wake(i)
164      iflag(nn) = iflag1(i)
165      nk(nn) = nk1(i)
166      icb(nn) = icb1(i)
167      icbs(nn) = icbs1(i)
168      plcl(nn) = plcl1(i)
169      tnk(nn) = tnk1(i)
170      qnk(nn) = qnk1(i)
171      gznk(nn) = gznk1(i)
172      hnk(nn) = hnk1(i)
173      unk(nn) = unk1(i)
174      vnk(nn) = vnk1(i)
175      pbase(nn) = pbase1(i)
176      buoybase(nn) = buoybase1(i)
[2259]177      sig(nn, nd) = sig1(i, nd)
[1992]178      ptop2(nn) = ptop2(i)
[2253]179      Ale(nn) = Ale1(i)
180      Alp(nn) = Alp1(i)
[1992]181    END IF
182  END DO
[879]183
[1992]184  IF (nn/=ncum) THEN
185    PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum
186    abort_message = ''
[2311]187    CALL abort_physic(modname, abort_message, 1)
[1992]188  END IF
[5099]189
[2253]190!jyg<
191  ELSE  !(compress)
[5099]192
[2253]193      ncum = len
[5099]194
[2259]195      wghti(:,1:nl+1) = wghti1(:,1:nl+1)
196      t(:,1:nl+1) = t1(:,1:nl+1)
197      q(:,1:nl+1) = q1(:,1:nl+1)
198      qs(:,1:nl+1) = qs1(:,1:nl+1)
199      t_wake(:,1:nl+1) = t1_wake(:,1:nl+1)
200      q_wake(:,1:nl+1) = q1_wake(:,1:nl+1)
201      qs_wake(:,1:nl+1) = qs1_wake(:,1:nl+1)
202      u(:,1:nl+1) = u1(:,1:nl+1)
203      v(:,1:nl+1) = v1(:,1:nl+1)
204      gz(:,1:nl+1) = gz1(:,1:nl+1)
205      th(:,1:nl+1) = th1(:,1:nl+1)
206      th_wake(:,1:nl+1) = th1_wake(:,1:nl+1)
207      h(:,1:nl+1) = h1(:,1:nl+1)
208      lv(:,1:nl+1) = lv1(:,1:nl+1)
209      lf(:,1:nl+1) = lf1(:,1:nl+1)
210      cpn(:,1:nl+1) = cpn1(:,1:nl+1)
211      p(:,1:nl+1) = p1(:,1:nl+1)
212      ph(:,1:nl+1) = ph1(:,1:nl+1)
213      tv(:,1:nl+1) = tv1(:,1:nl+1)
214      tp(:,1:nl+1) = tp1(:,1:nl+1)
215      tvp(:,1:nl+1) = tvp1(:,1:nl+1)
216      clw(:,1:nl+1) = clw1(:,1:nl+1)
217      h_wake(:,1:nl+1) = h1_wake(:,1:nl+1)
218      lv_wake(:,1:nl+1) = lv1_wake(:,1:nl+1)
219      lf_wake(:,1:nl+1) = lf1_wake(:,1:nl+1)
220      cpn_wake(:,1:nl+1) = cpn1_wake(:,1:nl+1)
221      tv_wake(:,1:nl+1) = tv1_wake(:,1:nl+1)
222      sig(:,1:nl+1) = sig1(:,1:nl+1)
223      w0(:,1:nl+1) = w01(:,1:nl+1)
224      omega(:,1:nl+1) = omega1(:,1:nl+1)
[5099]225
[2253]226      s_wake(:) = s1_wake(:)
227      iflag(:) = iflag1(:)
228      nk(:) = nk1(:)
229      icb(:) = icb1(:)
230      icbs(:) = icbs1(:)
231      plcl(:) = plcl1(:)
232      tnk(:) = tnk1(:)
233      qnk(:) = qnk1(:)
234      gznk(:) = gznk1(:)
235      hnk(:) = hnk1(:)
236      unk(:) = unk1(:)
237      vnk(:) = vnk1(:)
238      pbase(:) = pbase1(:)
239      buoybase(:) = buoybase1(:)
[2259]240      sig(:, nd) = sig1(:, nd)
[2253]241      ptop2(:) = ptop2(:)
242      Ale(:) = Ale1(:)
243      Alp(:) = Alp1(:)
[5099]244
[2253]245  ENDIF !(compress)
246!>jyg
[972]247
[5105]248
[1992]249END SUBROUTINE cv3a_compress
Note: See TracBrowser for help on using the repository browser.