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

Rev	Line
[104]	1	SUBROUTINE OPTCV(qaer,nmicro,IPRINT)
[3]	2
[102]	3	use dimphy
[119]	4	use infotrac
[1056]	5	use common_mod, only:rmcbar,xfbar,ncount,TauHVD,TauCVD,TauGVD
[3]	6	#include "dimensions.h"
	7	#include "microtab.h"
	8	#include "clesphys.h"
	9
	10	c Argument:
	11	c ---------
[119]	12	REAL qaer(klon,klev,nqtot)
[3]	13	integer nmicro
	14	c ---------
	15
[104]	16	c ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX
	17	INTEGER ngrid
	18	PARAMETER (ngrid=(jjm-1)*iim+2) ! = klon
	19	c
[3]	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
[175]	34	COMMON /CLOUD/
	35	& RCLDI(NSPECI), XICLDI(NSPECI)
[3]	36	& , RCLDV(NSPECV), XICLDV(NSPECV)
[175]	37	& , RCLDI2(NSPECI), XICLDI2(NSPECI)
	38	& , RCLDV2(NSPECV), XICLDV2(NSPECV)
[3]	39
[104]	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)
[3]	44
[104]	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)
[175]	49	& ,DTAUVP(ngrid,NLAYER,NSPECV,4)
	50	& ,TAUVP(ngrid,NLEVEL,NSPECV,4)
	51	& ,WBARVP(ngrid,NLAYER,NSPECV,4)
	52	& ,COSBVP(ngrid,NLAYER,NSPECV,4)
[3]	53
	54	COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV)
	55	& ,DWNV(NSPECV),WLNV(NSPECV)
	56
[495]	57	COMMON /PLANT/ CSUBP,F0PI
[3]	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
[175]	78	real zqaer_1pt(NLAYER,2*nrad)
	79	#include "optcv_1pt.h"
	80
[3]	81	character*100 dummy
	82	real dummy2,dummy3
	83
	84	C*
	85	C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE
[175]	86	C IT CALCULATES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS
[3]	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
[97]	100	c verif pour taille zqaer_1pt, sachant que si microfi=0 et nqtot=1,
[3]	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)
[175]	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
[3]	121	endif
	122
	123	DO 130 K=1,NSPECV
	124	C LETS USE THE OPTICAL CONSTANTS FOR THOLIN
[1056]	125	c CALL THOLIN(WLNV(K),TNR,TNI)
	126	CALL THOLIN_CVD(WLNV(K),TNR,TNI)
[3]	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
[175]	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
[3]	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
[1126]	150	c DEBUG
	151	c print*,"wnov=",WNOV
	152
[3]	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
[175]	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
[3]	170	else
	171	if (ig.eq.1) then
[1126]	172	c initialisation zqaer_1pt a partir d une look-up table (uniforme en ig)
[3]	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
[808]	195	call optcv_1pt3(zqaer_1pt,rmcbar(ig,:),xfbar(ig,:,:),
[175]	196	& ioptv,IPRINT)
[3]	197	ioptv = 1
	198	endif
	199
	200	c Pas de microphysique, ni de composition variable: un seul passage
[175]	201	c dans optcv_1pt.
[3]	202	if ((microfi.eq.0).and.(ylellouch)) then
	203	seulmtunpt = 1
	204	endif
	205
[1080]	206	COSBV(ig,:,:,:)= MAX(MIN(COSBV_1pt(:,:,:),0.999999),1e-6)
[1081]	207	WBARV(ig,:,:,:)= MAX(MIN(WBARV_1pt(:,:,:),0.999999),1e-6)
[175]	208	DTAUV(ig,:,:,:)= DTAUV_1pt(:,:,:)
	209	TAUV(ig,:,:,:) = TAUV_1pt(:,:,:)
[3]	210
[1080]	211	COSBVP(ig,:,:,:)= MAX(MIN(COSBVP_1pt(:,:,:),0.999999),1e-6)
	212	WBARVP(ig,:,:,:)= MAX(MIN(WBARVP_1pt(:,:,:),0.999999),1e-6)
[175]	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
[1056]	221	TauHVD(ig,:,:) = TAUHVD_1pt(:,:)
	222	TauCVD(ig,:,:) = TAUCVD_1pt(:,:)
	223	TauGVD(ig,:,:) = TAUGVD_1pt(:,:)
[175]	224
[1126]	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
[3]	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