Context Navigation

cv3a_compress.F90 @ 5453

Last change on this file since 5453 was 4368, checked in by lguez, 2 years ago
Sync latest trunk changes to Ocean_skin
Property svn:keywords set to `Id`
File size: 10.4 KB

Line
1	SUBROUTINE 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
23	& ,xtnk1,xt1,xt1_wake,xtclw1 &
24	& ,xtnk,xt,xt_wake,xtclw &
25	#endif
26	& )
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
36	use infotrac_phy, ONLY: ntraciso=>ntiso
37	use isotopes_mod, ONLY: essai_convergence, iso_eau,iso_HDO
38	#ifdef ISOVERIF
39	use isotopes_verif_mod
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
80	!
81	! in/out
82	INTEGER, INTENT (INOUT) :: ncum
83	!
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
118	integer ixt
119	#endif
120
121	CHARACTER (LEN=20) :: modname = 'cv3a_compress'
122	CHARACTER (LEN=80) :: abort_message
123
124	#ifdef ISOVERIF
125	write(,) 'compress=', compress
126	write(,) 'nl=',nl
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
177	!
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
183	! AC! if(iflag1(i).eq.0)then
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
232	!
233	!jyg<
234	ELSE !(compress)
235	!
236	ncum = len
237	!
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
273	!
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
295	!
296	ENDIF !(compress)
297	!>jyg
298
299	RETURN
300	END SUBROUTINE cv3a_compress

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format