My Project
 All Classes Files Functions Variables Macros
cv3a_compress.F
Go to the documentation of this file.
1  SUBROUTINE cv3a_compress( len,nloc,ncum,nd,ntra
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 ,cpn1 ,p1,ph1,tv1 ,tp1,tvp1,clw1
9  : ,h1_wake,lv1_wake,cpn1_wake ,tv1_wake
10  : ,sig1,w01,ptop21
11  : ,ale1,alp1
12  o ,iflag,nk,icb,icbs
13  o ,plcl,tnk,qnk,gznk,hnk,unk,vnk
14  o ,wghti,pbase,buoybase
15  o ,t,q,qs,t_wake,q_wake,qs_wake,s_wake
16  o ,u,v,gz,th,th_wake
17  o ,tra
18  o ,h ,lv ,cpn ,p,ph,tv ,tp,tvp,clw
19  o ,h_wake,lv_wake,cpn_wake ,tv_wake
20  o ,sig,w0,ptop2
21  o ,ale,alp )
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 ***************************************************************
30 *
31  implicit none
32 
33 #include "cv3param.h"
34 
35 c inputs:
36  integer len,nloc,ncum,nd,ntra
37  integer iflag1(len),nk1(len),icb1(len),icbs1(len)
38  real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
39  real hnk1(len),unk1(len),vnk1(len)
40  real wghti1(len,nd),pbase1(len),buoybase1(len)
41  real t1(len,nd),q1(len,nd),qs1(len,nd)
42  real t1_wake(len,nd),q1_wake(len,nd),qs1_wake(len,nd)
43  real s1_wake(len)
44  real u1(len,nd),v1(len,nd)
45  real gz1(len,nd),th1(len,nd),th1_wake(len,nd)
46  real tra1(len,nd,ntra)
47  real h1(len,nd),lv1(len,nd),cpn1(len,nd)
48  real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
49  real tvp1(len,nd),clw1(len,nd)
50  real h1_wake(len,nd),lv1_wake(len,nd),cpn1_wake(len,nd)
51  real tv1_wake(len,nd)
52  real sig1(len,nd), w01(len,nd), ptop21(len)
53  real ale1(len),alp1(len)
54 
55 c outputs:
56 c en fait, on a nloc=len pour l'instant (cf cv_driver)
57  integer iflag(len),nk(len),icb(len),icbs(len)
58  real plcl(len),tnk(len),qnk(len),gznk(len)
59  real hnk(len),unk(len),vnk(len)
60  real wghti(len,nd),pbase(len),buoybase(len)
61  real t(len,nd),q(len,nd),qs(len,nd)
62  real t_wake(len,nd),q_wake(len,nd),qs_wake(len,nd)
63  real s_wake(len)
64  real u(len,nd),v(len,nd)
65  real gz(len,nd),th(len,nd),th_wake(len,nd)
66  real tra(len,nd,ntra)
67  real h(len,nd),lv(len,nd),cpn(len,nd)
68  real p(len,nd),ph(len,nd+1),tv(len,nd),tp(len,nd)
69  real tvp(len,nd),clw(len,nd)
70  real h_wake(len,nd),lv_wake(len,nd),cpn_wake(len,nd)
71  real tv_wake(len,nd)
72  real sig(len,nd), w0(len,nd), ptop2(len)
73  real ale(len),alp(len)
74 
75 c local variables:
76  integer i,k,nn,j
77 
78  CHARACTER (LEN=20) :: modname='cv3a_compress'
79  CHARACTER (LEN=80) :: abort_message
80 
81 
82  do 110 k=1,nl+1
83  nn=0
84  do 100 i=1,len
85  if(iflag1(i).eq.0)then
86  nn=nn+1
87  wghti(nn,k)=wghti1(i,k)
88  t(nn,k)=t1(i,k)
89  q(nn,k)=q1(i,k)
90  qs(nn,k)=qs1(i,k)
91  t_wake(nn,k)=t1_wake(i,k)
92  q_wake(nn,k)=q1_wake(i,k)
93  qs_wake(nn,k)=qs1_wake(i,k)
94  u(nn,k)=u1(i,k)
95  v(nn,k)=v1(i,k)
96  gz(nn,k)=gz1(i,k)
97  th(nn,k)=th1(i,k)
98  th_wake(nn,k)=th1_wake(i,k)
99  h(nn,k)=h1(i,k)
100  lv(nn,k)=lv1(i,k)
101  cpn(nn,k)=cpn1(i,k)
102  p(nn,k)=p1(i,k)
103  ph(nn,k)=ph1(i,k)
104  tv(nn,k)=tv1(i,k)
105  tp(nn,k)=tp1(i,k)
106  tvp(nn,k)=tvp1(i,k)
107  clw(nn,k)=clw1(i,k)
108  h_wake(nn,k)=h1_wake(i,k)
109  lv_wake(nn,k)=lv1_wake(i,k)
110  cpn_wake(nn,k)=cpn1_wake(i,k)
111  tv_wake(nn,k)=tv1_wake(i,k)
112  sig(nn,k)=sig1(i,k)
113  w0(nn,k)=w01(i,k)
114  endif
115  100 continue
116  110 continue
117 
118 !AC! do 121 j=1,ntra
119 !AC!ccccc do 111 k=1,nl+1
120 !AC! do 111 k=1,nd
121 !AC! nn=0
122 !AC! do 101 i=1,len
123 !AC! if(iflag1(i).eq.0)then
124 !AC! nn=nn+1
125 !AC! tra(nn,k,j)=tra1(i,k,j)
126 !AC! endif
127 !AC! 101 continue
128 !AC! 111 continue
129 !AC! 121 continue
130 
131  if (nn.ne.ncum) then
132  print*,'WARNING nn not equal to ncum: ',nn,ncum
133  abort_message = ''
134  CALL abort_gcm(modname,abort_message,1)
135  endif
136 
137  nn=0
138  do 150 i=1,len
139  if(iflag1(i).eq.0)then
140  nn=nn+1
141  s_wake(nn)=s1_wake(i)
142  iflag(nn)=iflag1(i)
143  nk(nn)=nk1(i)
144  icb(nn)=icb1(i)
145  icbs(nn)=icbs1(i)
146  plcl(nn)=plcl1(i)
147  tnk(nn)=tnk1(i)
148  qnk(nn)=qnk1(i)
149  gznk(nn)=gznk1(i)
150  hnk(nn)=hnk1(i)
151  unk(nn)=unk1(i)
152  vnk(nn)=vnk1(i)
153  pbase(nn)=pbase1(i)
154  buoybase(nn)=buoybase1(i)
155  ptop2(nn)=ptop2(i)
156  ale(nn) = ale1(i)
157  alp(nn) = alp1(i)
158  endif
159  150 continue
160 
161  if (nn.ne.ncum) then
162  print*,'WARNING nn not equal to ncum: ',nn,ncum
163  abort_message = ''
164  CALL abort_gcm(modname,abort_message,1)
165  endif
166 
167  RETURN
168  END