Context Navigation

lwxn.F @ 2156

Last change on this file since 2156 was 1266, checked in by aslmd, 11 years ago

LMDZ.MARS
IMPORTANT CHANGE

Remove all reference/use of nlayermx and dimphys.h
Made use of automatic arrays whenever arrays are needed with dimension nlayer
Remove lots of obsolete reference to dimensions.h
Converted iono.h and param_v4.h into corresponding modules

(with embedded subroutine to allocate arrays)
(no arrays allocated if thermosphere not used)

Deleted param.h and put contents into module param_v4_h
Adapted testphys1d, newstart, etc...
Made DATA arrays in param_read to be initialized by subroutine

fill_data_thermos in module param_v4_h

Optimized computations in paramfoto_compact (twice less dlog10 calculations)
Checked consistency before/after modification in debug mode
Checked performance is not impacted (same as before)

File size: 12.5 KB

Rev	Line
[38]	1	subroutine lwxn ( ig0,kdlon,kflev
	2	. , dp
	3	. , aer_t,co2_u,co2_up)
	4
	5	c----------------------------------------------------------------------
	6	c LWXN computes transmission function and exchange coefficiants
	7	c for neighbours layers
	8	c (co2 / aerosols)
	9	c (bands 1 and 2 of co2)
	10	c----------------------------------------------------------------------
	11	c
	12	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	13	c kflev+1 \| \| \| \| \| \| \| \| 0 \| (space)
	14	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	15	c kflev \| \| \| \| \| \|***\| 0 \| \|
	16	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	17	c ... \| \| \| \| \|*\| 0 \|*\| \|
	18	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	19	c 4 \| \| \| \|*\| 0 \|*\| \| \|
	20	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	21	c 3 \| \| \|*\| 0 \|*\| \| \| \|
	22	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	23	c 2 \| \|*\| 0 \|*\| \| \| \| \|
	24	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	25	c 1 \| \| 0 \|***\| \| \| \| \| \|
	26	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	27	c 0 \| 0 \| \| \| \| \| \| \| \| (ground)
	28	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	29	c 0 1 2 3 4 ... k \|k+1
	30	c (ground) (space)
	31	c
	32	c (*) xi computed in this subroutine
	33	c----------------------------------------------------------------------
	34	c
	35	c *********************************************************** nj=1
	36	c
	37	c
	38	c sublayer 1
	39	c
	40	c
	41	c ----------------------------- nj=2
	42	c
	43	c sublayer 2
	44	c
	45	c - - - - LAYER j - - - - - ----------------------------- nj=3
	46	c
	47	c sublayer 3
	48	c ----------------------------- nj=4
	49	c sublayer ncouche
	50	c *********************************************************** ni=nj=ncouche+1
	51	c sublayer ncouche
	52	c ----------------------------- ni=4
	53	c sublayer 3
	54	c
	55	c - - - - LAYER i - - - - - ----------------------------- ni=3
	56	c
	57	c sublayer 2
	58	c
	59	c ----------------------------- ni=2
	60	c
	61	c
	62	c sublayer 1
	63	c
	64	c
	65	c *********************************************************** ni=1
	66	c
	67	c-----------------------------------------------------------------------
	68	c ATTENTION AUX UNITES:
	69	c le facteur 10*g fait passer des kg m-2 aux g cm-2
	70	c-----------------------------------------------------------------------
	71
[1047]	72	use dimradmars_mod, only: ndlo2, nuco2, ndlon, nflev
	73	use yomlw_h, only: nlaylte, xi, xi_ground, xi_emis
[38]	74	implicit none
	75
	76	#include "callkeys.h"
	77
	78	c----------------------------------------------------------------------
	79	c 0.1 arguments
	80	c ---------
	81	c inputs:
	82	c -------
	83	integer ig0
	84	integer kdlon ! part of ngrid
	85	integer kflev ! part of nalyer
	86
	87	real dp (ndlo2,kflev) ! layer pressure thickness (Pa)
	88
	89	real aer_t (ndlo2,nuco2,kflev+1) ! transmission (aer)
	90	real co2_u (ndlo2,nuco2,kflev+1) ! absorber amounts (co2)
	91	real co2_up (ndlo2,nuco2,kflev+1) ! idem scaled by the pressure (co2)
	92
	93	c----------------------------------------------------------------------
	94	c 0.2 local arrays
	95	c ------------
	96
	97	integer ja,jl,jk,nlmd,ni,nj
	98
	99	integer nmax
	100	parameter (nmax=50) ! max: 50 sublayers
	101
	102	real cn (nmax), cb (nmax)
	103
	104	real zu_layer_i (ndlon,nuco2)
	105	real zup_layer_i (ndlon,nuco2)
	106	real zt_aer_layer_i (ndlon,nuco2)
	107
	108	real zu_layer_j (ndlon,nuco2)
	109	real zup_layer_j (ndlon,nuco2)
	110	real zt_aer_layer_j (ndlon,nuco2)
	111
	112	real zu (ndlon,nuco2)
	113	real zup (ndlon,nuco2)
	114	real zt_co2 (ndlon,nuco2)
	115	real zt_aer (ndlon,nuco2)
	116
	117	real zu_i (ndlon,nuco2,nmax+1)
	118	real zup_i (ndlon,nuco2,nmax+1)
	119	real zu_j (ndlon,nuco2,nmax+1)
	120	real zup_j (ndlon,nuco2,nmax+1)
	121	real zt_aer_i (ndlon,nuco2,nmax+1)
	122	real zt_aer_j (ndlon,nuco2,nmax+1)
	123
	124	real trans (ndlon,nuco2,nmax+1,nmax+1)
	125	real ksi (ndlon,nuco2,nflev-1)
	126
	127	c----------------------------------------------------------------------
	128	c 0.3 Initialisation
	129	c --------------
	130
	131	jk=ncouche+1
	132	do ja = 1 ,nuco2
	133	do jl = 1 , kdlon
	134	zu_i (jl,ja,jk) = 0.
	135	zup_i (jl,ja,jk) = 0.
	136	zu_j (jl,ja,jk) = 0.
	137	zup_j (jl,ja,jk) = 0.
	138	zt_aer_i (jl,ja,jk) = 1.
	139	zt_aer_j (jl,ja,jk) = 1.
	140	enddo
	141	enddo
	142
	143	if (linear) then
	144
	145	do nlmd = 1 ,ncouche
	146	cn(nlmd)=(1.0/ncouche)
	147	cb(nlmd)=(ncouche-nlmd+0.5)/ncouche
	148	c print*,nlmd,cb(nlmd),cn(nlmd)
	149	enddo
	150
	151	else
	152
	153	do nlmd = 1 ,ncouche-1
	154	cn(nlmd)=(1-alphan)alphan*(nlmd-1)
	155	cb(nlmd)=0.5(1+alphan)alphan**(nlmd-1)
	156	enddo
	157	cn(ncouche)=alphan**(ncouche-1)
	158	cb(ncouche)=0.5alphan*(ncouche-1)
	159
	160	endif
	161
	162	c test
	163	if (nmax .LT. ncouche) then
	164	print*,'!!!!! ATTENTION !!!!! '
	165	print*,'probleme dans lwxn.F'
	166	print*,' nmax=',nmax,' < ncouche=',ncouche
	167	call exit(1)
	168	endif
	169
	170	c----------------------------------------------------------------------
	171	do jk = 1 , nlaylte-1
	172	c----------------------------------------------------------------------
	173	c 1.0 (co2) amount and (aer) transmission for all sublayers
	174	c ----------------------------------------------------
	175
	176	do ja = 1 , nuco2
	177	do jl = 1 , kdlon
	178
	179	c layer i (down)
	180	c -------------
	181	zu_layer_i(jl,ja) = co2_u(jl,ja,jk) - co2_u(jl,ja,jk+1)
	182	zup_layer_i(jl,ja) = co2_up(jl,ja,jk) - co2_up(jl,ja,jk+1)
	183	zt_aer_layer_i(jl,ja) = aer_t(jl,ja,jk)
	184	. / aer_t(jl,ja,jk+1)
	185
	186	do nlmd=1,ncouche
	187	zu_i(jl,ja,nlmd)=cn(nlmd)*zu_layer_i(jl,ja)
	188	zup_i(jl,ja,nlmd)=cn(nlmd)*zup_layer_i(jl,ja)
	189	zt_aer_i(jl,ja,nlmd)=zt_aer_layer_i(jl,ja)**cn(nlmd)
	190	enddo
	191
	192	c layer j (up)
	193	c ------------
	194	zu_layer_j(jl,ja) = co2_u(jl,ja,jk+1) - co2_u(jl,ja,jk+2)
	195	zup_layer_j(jl,ja) = co2_up(jl,ja,jk+1) - co2_up(jl,ja,jk+2)
	196	zt_aer_layer_j(jl,ja) = aer_t(jl,ja,jk+1)
	197	. / aer_t(jl,ja,jk+2)
	198
	199	do nlmd=1,ncouche
	200	zu_j(jl,ja,nlmd)=cn(nlmd)*zu_layer_j(jl,ja)
	201	zup_j(jl,ja,nlmd)=cn(nlmd)*zup_layer_j(jl,ja)
	202	zt_aer_j(jl,ja,nlmd)=zt_aer_layer_j(jl,ja)**cn(nlmd)
	203	enddo
	204
	205	enddo
	206	enddo
	207
	208	c----------------------------------------------------------------------
	209	c 2.0 transmissions between all sublayers
	210	c ------------------------------------
	211
	212	do ni = 1 ,ncouche+1
	213
	214	do ja = 1 ,nuco2
	215	do jl = 1 , kdlon
	216	zu(jl,ja)=0.
	217	zup(jl,ja)=0.
	218	zt_aer(jl,ja)=1.
	219
	220	do nlmd=ni,ncouche+1
	221	zu(jl,ja)=zu(jl,ja)+zu_i(jl,ja,nlmd)
	222	zup(jl,ja)=zup(jl,ja)+zup_i(jl,ja,nlmd)
	223	zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_i(jl,ja,nlmd)
	224	enddo
	225	enddo
	226	enddo
	227
	228	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
	229
	230	do ja = 1 ,nuco2
	231	do jl = 1 , kdlon
	232	trans(jl,ja,ni,ncouche+1)=zt_co2(jl,ja)*zt_aer(jl,ja)
	233	enddo
	234	enddo
	235
	236	c on ajoute la couche J
	237	do ja = 1 ,nuco2
	238	do jl = 1 , kdlon
	239	zu(jl,ja)=zu(jl,ja)+zu_layer_j(jl,ja)
	240	zup(jl,ja)=zup(jl,ja)+zup_layer_j(jl,ja)
	241	zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_layer_j(jl,ja)
	242	enddo
	243	enddo
	244
	245	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
	246
	247	do ja = 1 ,nuco2
	248	do jl = 1 , kdlon
	249	trans(jl,ja,ni,1)=zt_co2(jl,ja)*zt_aer(jl,ja)
	250	enddo
	251	enddo
	252
	253	enddo
	254	ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	255
	256	do nj = 1 ,ncouche+1
	257
	258	do ja = 1 ,nuco2
	259	do jl = 1 , kdlon
	260	zu(jl,ja)=0.
	261	zup(jl,ja)=0.
	262	zt_aer(jl,ja)=1.
	263
	264	do nlmd=nj,ncouche+1
	265	zu(jl,ja)=zu(jl,ja)+zu_j(jl,ja,nlmd)
	266	zup(jl,ja)=zup(jl,ja)+zup_j(jl,ja,nlmd)
	267	zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_j(jl,ja,nlmd)
	268	enddo
	269	enddo
	270	enddo
	271
	272	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
	273
	274	do ja = 1 ,nuco2
	275	do jl = 1 , kdlon
	276	trans(jl,ja,ncouche+1,nj)=zt_co2(jl,ja)*zt_aer(jl,ja)
	277	enddo
	278	enddo
	279
	280	c on ajoute la couche I
	281	do ja = 1 ,nuco2
	282	do jl = 1 , kdlon
	283	zu(jl,ja)=zu(jl,ja)+zu_layer_i(jl,ja)
	284	zup(jl,ja)=zup(jl,ja)+zup_layer_i(jl,ja)
	285	zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_layer_i(jl,ja)
	286	enddo
	287	enddo
	288
	289	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
	290
	291	do ja = 1 ,nuco2
	292	do jl = 1 , kdlon
	293	trans(jl,ja,1,nj)=zt_co2(jl,ja)*zt_aer(jl,ja)
	294	enddo
	295	enddo
	296
	297	enddo
	298
	299	c----------------------------------------------------------------------
	300	c 3.0 global exchange coefficiant between neigthbours
	301	c -----------------------------------------------
	302
	303	do ja = 1 ,nuco2
	304	do jl = 1 , kdlon
	305	ksi(jl,ja,jk) = 0.
	306	enddo
	307	enddo
	308
	309	do ni = 1 ,ncouche
	310	do ja = 1 ,nuco2
	311	do jl = 1 , kdlon
	312
	313	ksi(jl,ja,jk)=ksi(jl,ja,jk) +
	314	. ( trans(jl,ja,ni+1,ncouche+1)
	315	. - trans(jl,ja,ni,ncouche+1)
	316	. - trans(jl,ja,ni+1,1)
	317	. + trans(jl,ja,ni,1) )
	318	. * (cb(ni)dp(jl,jk)) 2
	319	. / (dp(jl,jk) + dp(jl,jk+1)) !!!!!!!!!!!!!!!!!!!
	320
	321	enddo
	322	enddo
	323	enddo
	324
	325	do nj = 1 ,ncouche
	326	do ja = 1 ,nuco2
	327	do jl = 1 , kdlon
	328
	329	ksi(jl,ja,jk)=ksi(jl,ja,jk) +
	330	. ( trans(jl,ja,ncouche+1,nj+1)
	331	. - trans(jl,ja,1,nj+1)
	332	. - trans(jl,ja,ncouche+1,nj)
	333	. + trans(jl,ja,1,nj) )
	334	. * (cb(nj)dp(jl,jk+1)) 2
	335	. / (dp(jl,jk) + dp(jl,jk+1)) !!!!!!!!!!!!!!!!!!!
	336
	337	enddo
	338	enddo
	339	enddo
	340
	341	do ja = 1 ,nuco2
	342	do jl = 1 , kdlon
	343	xi(ig0+jl,ja,jk,jk+1) = ksi(jl,ja,jk)
	344	. + xi_emis(ig0+jl,ja,jk)
	345
	346	c ksi reciprocity
	347	c ---------------
	348	xi(ig0+jl,ja,jk+1,jk) = xi(ig0+jl,ja,jk,jk+1)
	349	enddo
	350	enddo
	351
	352	c----------------------------------------------------------------------
	353	c 4.0 Special treatment for ground
	354	c ----------------------------
	355
	356
	357	if (jk .EQ. 1) then
	358
	359	do ja = 1 ,nuco2
	360	do jl = 1 , kdlon
	361	xi_ground(ig0+jl,ja)=0.
	362	enddo
	363	enddo
	364
	365	do ni = 1 ,ncouche
	366	do ja = 1 ,nuco2
	367	do jl = 1 , kdlon
	368
	369	xi_ground(ig0+jl,ja) = xi_ground(ig0+jl,ja)
	370	. + ( trans(jl,ja,ni+1,ncouche+1)
	371	. -trans(jl,ja,ni,ncouche+1))
	372	. * 2 * cb(ni)
	373	enddo
	374	enddo
	375	enddo
	376
	377	endif
	378
	379	c----------------------------------------------------------------------
	380	enddo ! boucle sur jk
	381	c----------------------------------------------------------------------
	382	return
	383	end
	384
	385
	386

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

Download in other formats:

Original Format