Context Navigation

optcv.F @ 828

Last change on this file since 828 was 808, checked in by slebonnois, 12 years ago
SL: Many changes for VENUS (related to newstart) and TITAN (related to clouds). Please read DOC/chantiers/commit_importants.log (cf v808).
File size: 7.3 KB

Line
1	SUBROUTINE OPTCV(qaer,nmicro,IPRINT)
2
3	use dimphy
4	use infotrac
5	#include "dimensions.h"
6	#include "microtab.h"
7	#include "clesphys.h"
8
9	c Argument:
10	c ---------
11	REAL qaer(klon,klev,nqtot)
12	integer nmicro
13	c ---------
14
15	c ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX
16	INTEGER ngrid
17	PARAMETER (ngrid=(jjm-1)*iim+2) ! = klon
18	c
19	PARAMETER(NLAYER=llm,NLEVEL=NLAYER+1)
20	PARAMETER (NSPECI=46,NSPC1I=47,NSPECV=24,NSPC1V=25)
21
22	COMMON /ATM/ Z(NLEVEL),PRESS(NLEVEL),DEN(NLEVEL),TEMP(NLEVEL)
23
24	COMMON /GASS/ CH4(NLEVEL),XN2(NLEVEL),H2(NLEVEL),AR(NLEVEL)
25	& ,XMU(NLEVEL),GAS1(NLAYER),COLDEN(NLAYER)
26
27	COMMON /VISGAS/SOLARF(NSPECV),NTERM(NSPECV),PEXPON(NSPECV),
28	& ATERM(4,NSPECV),BTERM(4,NSPECV)
29
30	COMMON /AERSOL/ RADIUS(NLAYER), XNUMB(NLAYER)
31	& , REALI(NSPECI), XIMGI(NSPECI), REALV(NSPECV), XIMGV(NSPECV)
32
33	COMMON /CLOUD/
34	& RCLDI(NSPECI), XICLDI(NSPECI)
35	& , RCLDV(NSPECV), XICLDV(NSPECV)
36	& , RCLDI2(NSPECI), XICLDI2(NSPECI)
37	& , RCLDV2(NSPECV), XICLDV2(NSPECV)
38
39	COMMON /TAUS/ TAUHI(ngrid,NSPECI), TAUCI(ngrid,NSPECI)
40	& ,TAUGI(ngrid,NSPECI), TAURV(ngrid,NSPECV)
41	& ,TAUHV(ngrid,NSPECV) ,TAUCV(ngrid,NSPECV)
42	& ,TAUGV(ngrid,NSPECV)
43
44	COMMON /TAUD/ TAUHID(ngrid,NLAYER,NSPECI)
45	& ,TAUCID(ngrid,NLAYER,NSPECI)
46	& ,TAUGID(ngrid,NLAYER,NSPECI)
47	& ,TAUHVD(ngrid,NLAYER,NSPECV)
48	& ,TAUCVD(ngrid,NLAYER,NSPECV)
49	& ,TAUGVD(ngrid,NLAYER,NSPECV)
50
51	COMMON /OPTICV/ DTAUV(ngrid,NLAYER,NSPECV,4)
52	& ,TAUV(ngrid,NLEVEL,NSPECV,4)
53	& ,WBARV(ngrid,NLAYER,NSPECV,4)
54	& ,COSBV(ngrid,NLAYER,NSPECV,4)
55	& ,DTAUVP(ngrid,NLAYER,NSPECV,4)
56	& ,TAUVP(ngrid,NLEVEL,NSPECV,4)
57	& ,WBARVP(ngrid,NLAYER,NSPECV,4)
58	& ,COSBVP(ngrid,NLAYER,NSPECV,4)
59
60	COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV)
61	& ,DWNV(NSPECV),WLNV(NSPECV)
62
63	COMMON /PLANT/ CSUBP,F0PI
64	COMMON /ADJUST/ RHCH4,FH2,FHAZE,FHVIS,FHIR,TAUFAC,RCLOUD,FARGON
65	COMMON /CONST/ RGAS,RHOP,PI,SIGMA
66	COMMON /part/ v(nrad),rayon(nrad),vrat,dr(nrad),dv(nrad)
67
68	c-----Rayons nuages et "composition" de la goutte
69	c sur la grille ...
70	integer ncount(ngrid,NLAYER)
71	real rmcbar(ngrid,NLAYER)
72	real xfbar(ngrid,NLAYER,4)
73	COMMON/rnuabar/ncount,rmcbar,xfbar
74
75	REAL xv1(klev,NSPECV)
76	REAL xv2(klev,NSPECV)
77	REAL xv3(klev,NSPECV)
78
79	REAL QF1(nrad,NSPECV),QF2(nrad,NSPECV)
80	REAL QF3(nrad,NSPECV),QF4(nrad,NSPECV)
81	REAL QM1(nrad,NSPECV),QM2(nrad,NSPECV)
82	REAL QM3(nrad,NSPECV),QM4(nrad,NSPECV)
83
84	save qf1,qf2,qf3,qf4,qm1,qm2,qm3,qm4
85
86	integer ioptv,iwarning ! ioptv: premier appel, une seule boucle sur les l.d'o.
87	integer ig_,seulmtunpt
88	save ioptv,iwarning,seulmtunpt
89	data ioptv,iwarning,seulmtunpt/0,0,0/
90
91	real zqaer_1pt(NLAYER,2*nrad)
92	#include "optcv_1pt.h"
93
94	character*100 dummy
95	real dummy2,dummy3
96
97	C*
98	C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE
99	C IT CALCULATES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS
100	C LAYER: WBAR, DTAU, COSBAR
101	C LEVEL: TAU
102	C
103	sum=0.
104	PRINT*,'OPTCV'
105	print*,'ATTENTION, TAU UNIFORME DANS OPTCV'
106
107	C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
108	c INITIALISATIONS UNE SEULE FOIS
109	C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
110
111	if (ioptv.eq.0) then
112
113	c verif pour taille zqaer_1pt, sachant que si microfi=0 et nqtot=1,
114	c il faut quand meme qu'on lise la look-up table de dim nrad=10
115	c et si microfi=1, on doit avoir nmicro=nrad (dans microtab.h)
116	c
117	c Nouvelle verif pour nuages :
118	c La condition ci-dessus n'est plus realisable !
119	c nmicro comprend maintenant aussi des glaces
120	c Donc on teste juste que nmicro soit > 2*nrad (ou nrad si on ne fait pas de nuages)
121	if (microfi.ge.1) then
122	if ((clouds.eq.1).and.(nmicro.lt.2*nrad)) then
123	print*,"OPTCV :"
124	print,"clouds = 1 MAIS nmicro < 2nrad"
125	print*,"Probleme pour zqaer_1pt dans optcv."
126	stop
127	endif
128	if ((clouds.eq.0).and.(nmicro.lt.nrad)) then
129	print*,"OPTCV :"
130	print*,"nmicro < nrad"
131	print*,"Probleme pour zqaer_1pt dans optcv."
132	stop
133	endif
134	endif
135
136	DO 130 K=1,NSPECV
137	C LETS USE THE OPTICAL CONSTANTS FOR THOLIN
138	CALL THOLIN(WLNV(K),TNR,TNI)
139	REALV(K)=TNR
140	XIMGV(K)=TNI*FHVIS
141	C BUT WE NOW USE THE GEOMETRIC ALBEDO FITTED RESULTS
142	C XIMGV(K)=FITEDT(WLNV(K))
143	C XIMGV(K)=FITEDN(WLNV(K))
144	C THE CLOUD IS CLEAR IN THE VISIBLE
145	CALL LIQCH4(WLNV(K),TNR,TNI)
146	RCLDV(K)=TNR
147	XICLDV(K)=TNI
148	CALL LIQC2H6(WLNV(K),TNR,TNI)
149	RCLDV2(K)=TNR
150	XICLDV2(K)=TNI
151	130 CONTINUE
152	C
153	c open (unit=1,file='xsetupv')
154	c do j=1,nspecv
155	c read(1,*) a
156	c do i=1,klev
157	c read(1,*) xv1(i,j),xv2(i,j),xv3(i,j)
158	c enddo
159	c enddo
160	c close(1)
161
162	endif ! fin initialisations premier appel
163
164	c***** DEBUT DES BOUCLE GRILLE **********************
165	c PRINT*, 'AEROSOLS EN VISIBLE'
166
167	DO 101 ig=1,klon !c! BOUCLE SUR GRILLE HORIZONTALE
168
169	if (microfi.ge.1) then
170	do iq=1,2*nrad
171	if (clouds.eq.0.and.iq.gt.nrad) then
172	zqaer_1pt(:,iq)=0.
173	else
174	do j=1,NLAYER
175	zqaer_1pt(j,iq)=qaer(ig,j,iq)
176	enddo
177	endif
178	enddo
179	else
180	if (ig.eq.1) then
181	c initialisation zqaer_1pt a partir d'une look-up table (uniforme en ig)
182	c boucle sur nrad=10
183	open(10,file="qaer_eq_1d.dat")
184	do iq=1,15
185	read(10,'(A100)') dummy
186	enddo
187	do j=NLAYER,1,-1
188	read(10,*) dummy2,dummy3,(zqaer_1pt(j,iq),iq=1,nrad)
189	enddo
190	close(10)
191	endif
192	endif
193
194	c if ((ig.eq.klon/2).or.(microfi.eq.0)) then
195	c print*,"Q01=",zqaer_1pt(:,1)
196	c print*,"Q05=",zqaer_1pt(:,5)
197	c print*,"Q10=",zqaer_1pt(:,10)
198	c stop
199	c endif
200
201	iout=0
202	c if ((microfi.eq.0).or.(ig.eq.klon/2)) iout=1
203	if (seulmtunpt.eq.0) then
204	call optcv_1pt3(zqaer_1pt,rmcbar(ig,:),xfbar(ig,:,:),
205	& ioptv,IPRINT)
206	ioptv = 1
207	endif
208
209	c Pas de microphysique, ni de composition variable: un seul passage
210	c dans optcv_1pt.
211	if ((microfi.eq.0).and.(ylellouch)) then
212	seulmtunpt = 1
213	endif
214
215	COSBV(ig,:,:,:)= COSBV_1pt(:,:,:)
216	WBARV(ig,:,:,:)= WBARV_1pt(:,:,:)
217	DTAUV(ig,:,:,:)= DTAUV_1pt(:,:,:)
218	TAUV(ig,:,:,:) = TAUV_1pt(:,:,:)
219
220	COSBVP(ig,:,:,:)= COSBVP_1pt(:,:,:)
221	WBARVP(ig,:,:,:)= WBARVP_1pt(:,:,:)
222	DTAUVP(ig,:,:,:)= DTAUVP_1pt(:,:,:)
223	TAUVP(ig,:,:,:) = TAUVP_1pt(:,:,:)
224
225	TAUHV(ig,:) = TAUHV_1pt(:)
226	TAUCV(ig,:) = TAUCV_1pt(:)
227	TAURV(ig,:) = TAURV_1pt(:)
228	TAUGV(ig,:) = TAUGV_1pt(:)
229
230	TAUHVD(ig,:,:) = TAUHVD_1pt(:,:)
231	TAUCVD(ig,:,:) = TAUCVD_1pt(:,:)
232	TAUGVD(ig,:,:) = TAUGVD_1pt(:,:)
233
234	101 CONTINUE
235
236	c FIN BOUCLE GRILLE *******
237	c******************************
238
239	PRINT*, 'FIN OPTCV'
240	RETURN
241	END

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

Download in other formats:

Original Format