Context Navigation

optcv.F @ 1525

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