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

Rev	Line
[104]	1	SUBROUTINE OPTCV(qaer,nmicro,IPRINT)
[3]	2
[102]	3	use dimphy
[119]	4	use infotrac
[3]	5	#include "dimensions.h"
	6	#include "microtab.h"
	7	#include "clesphys.h"
	8
	9	c Argument:
	10	c ---------
[119]	11	REAL qaer(klon,klev,nqtot)
[3]	12	integer nmicro
	13	c ---------
	14
[104]	15	c ASTUCE POUR EVITER klon... EN ATTENDANT MIEUX
	16	INTEGER ngrid
	17	PARAMETER (ngrid=(jjm-1)*iim+2) ! = klon
	18	c
[3]	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
[175]	33	COMMON /CLOUD/
	34	& RCLDI(NSPECI), XICLDI(NSPECI)
[3]	35	& , RCLDV(NSPECV), XICLDV(NSPECV)
[175]	36	& , RCLDI2(NSPECI), XICLDI2(NSPECI)
	37	& , RCLDV2(NSPECV), XICLDV2(NSPECV)
[3]	38
[104]	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)
[3]	43
[104]	44	COMMON /TAUD/ TAUHID(ngrid,NLAYER,NSPECI)
[175]	45	& ,TAUCID(ngrid,NLAYER,NSPECI)
[104]	46	& ,TAUGID(ngrid,NLAYER,NSPECI)
	47	& ,TAUHVD(ngrid,NLAYER,NSPECV)
[175]	48	& ,TAUCVD(ngrid,NLAYER,NSPECV)
[104]	49	& ,TAUGVD(ngrid,NLAYER,NSPECV)
[3]	50
[104]	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)
[175]	55	& ,DTAUVP(ngrid,NLAYER,NSPECV,4)
	56	& ,TAUVP(ngrid,NLEVEL,NSPECV,4)
	57	& ,WBARVP(ngrid,NLAYER,NSPECV,4)
	58	& ,COSBVP(ngrid,NLAYER,NSPECV,4)
[3]	59
	60	COMMON /SPECTV/ BWNV(NSPC1V),WNOV(NSPECV)
	61	& ,DWNV(NSPECV),WLNV(NSPECV)
	62
[495]	63	COMMON /PLANT/ CSUBP,F0PI
[3]	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
[175]	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
[3]	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
[175]	91	real zqaer_1pt(NLAYER,2*nrad)
	92	#include "optcv_1pt.h"
	93
[3]	94	character*100 dummy
	95	real dummy2,dummy3
	96
	97	C*
	98	C THIS SUBROUTINE SETS THE OPTICAL CONSTANTS IN THE VISIBLE
[175]	99	C IT CALCULATES FOR EACH LAYER, FOR EACH SPECRAL INTERVAL IN THE VIS
[3]	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
[97]	113	c verif pour taille zqaer_1pt, sachant que si microfi=0 et nqtot=1,
[3]	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)
[175]	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
[3]	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
[175]	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
[3]	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
[175]	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
[3]	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
[808]	204	call optcv_1pt3(zqaer_1pt,rmcbar(ig,:),xfbar(ig,:,:),
[175]	205	& ioptv,IPRINT)
[3]	206	ioptv = 1
	207	endif
	208
	209	c Pas de microphysique, ni de composition variable: un seul passage
[175]	210	c dans optcv_1pt.
[3]	211	if ((microfi.eq.0).and.(ylellouch)) then
	212	seulmtunpt = 1
	213	endif
	214
[175]	215	COSBV(ig,:,:,:)= COSBV_1pt(:,:,:)
	216	WBARV(ig,:,:,:)= WBARV_1pt(:,:,:)
	217	DTAUV(ig,:,:,:)= DTAUV_1pt(:,:,:)
	218	TAUV(ig,:,:,:) = TAUV_1pt(:,:,:)
[3]	219
[175]	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
[3]	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