Context Navigation

optcv.F @ 1242

Last change on this file since 1242 was 1126, checked in by slebonnois, 11 years ago
SL: update of Titan photochemical module to include computation of chemistry up to 1300 km
File size: 7.3 KB

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

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

Download in other formats:

Original Format