Context Navigation

cv3a_compress.F @ 4007

Last change on this file since 4007 was 1299, checked in by Laurent Fairhead, 15 years ago

Nettoyage general pour se rapprocher des normes et éviter des erreurs a la
compilation:

tous les FLOAT() sont remplacés par des REAL()
tous les STOP dans phylmd sont remplacés par des appels à abort_gcm
le common control défini dans le fichier control.h est remplacé par le module control_mod pour éviter des messages sur l'alignement des variables dans les déclarations
des $Header$ remplacés par des $Id$ pour svn

Quelques remplacements à faire ont pu m'échapper

General cleanup of the code to try and adhere to norms and to prevent some
compilation errors:

all FLOAT() instructions have been replaced by REAL() instructions
all STOP instructions in phylmd have been replaced by calls to abort_gcm
the common block control defined in the control.h file has been replaced by the control_mod to prevent compilation warnings on the alignement of declared variables
$Header$ replaced by $Id$ for svn

Some changes which should have been made might have escaped me

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 5.0 KB

Line
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	do 121 j=1,ntra
119	ccccc do 111 k=1,nl+1
120	do 111 k=1,nd
121	nn=0
122	do 101 i=1,len
123	if(iflag1(i).eq.0)then
124	nn=nn+1
125	tra(nn,k,j)=tra1(i,k,j)
126	endif
127	101 continue
128	111 continue
129	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

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

Download in other formats:

Original Format