Context Navigation

lwxd.F @ 1720

Last change on this file since 1720 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: 9.3 KB

Rev	Line
[38]	1	subroutine lwxd (ig0,kdlon,kflev,emis
	2	. ,aer_t,co2_u,co2_up)
	3
	4	c----------------------------------------------------------------------
	5	c LWXD computes transmission function and exchange coefficiants
	6	c for distant layers
	7	c (co2 / aerosols)
	8	c (bands 1 and 2 of co2)
	9	c----------------------------------------------------------------------
	10	c
	11	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	12	c kflev+1 \| \| \| \| \| \| \| \| 0 \| (space)
	13	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	14	c kflev \| \|*\|\|\|*\| \| 0 \| \|
	15	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	16	c ... \| \|*\|\|**\| \| 0 \| \| \|
	17	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	18	c 4 \| \|*\|\| \| 0 \| \|**\| \|
	19	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	20	c 3 \| \|*\| \| 0 \| \|\|**\| \|
	21	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	22	c 2 \| \| \| 0 \| \| \|*\|*\| \|
	23	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	24	c 1 \| \| 0 \| \| \|*\|\|**\| \|
	25	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	26	c 0 \| 0 \| \| \|*\|\|\|*\| \| (ground)
	27	c \|---\|---\|---\|---\|---\|---\|---\|---\|
	28	c 0 1 2 3 4 ... k \|k+1
	29	c (ground) (space)
	30	c
	31	c (*) xi computed in this subroutine
	32	c----------------------------------------------------------------------
	33
[1047]	34	use dimradmars_mod, only: ndlon, nuco2, nflev, ndlo2
	35	use yomlw_h, only: nlaylte, xi, xi_emis
[38]	36	implicit none
	37
	38	#include "callkeys.h"
	39
	40	c----------------------------------------------------------------------
	41	c 0.1 arguments
	42	c ---------
	43	c inputs:
	44	c -------
	45	integer ig0
	46	integer kdlon ! part of ngrid
	47	integer kflev ! part of nalyer
	48
	49	real emis (ndlo2) ! surface emissivity
	50	real aer_t (ndlo2,nuco2,kflev+1) ! transmission (aer)
	51	real co2_u (ndlo2,nuco2,kflev+1) ! absorber amounts (co2)
	52	real co2_up (ndlo2,nuco2,kflev+1) ! idem scaled by the pressure (co2)
	53
	54	c----------------------------------------------------------------------
	55	c 0.2 local arrays
	56	c ------------
	57
	58	integer ja,jl,jk,jkk,ndim
[1047]	59	! parameter(ndim = ndlonnuco2(nflev+2)*(nflev+2))
[38]	60
	61
	62	real zu (ndlon,nuco2)
	63	real zup (ndlon,nuco2)
	64	real zt_co2 (ndlon,nuco2)
	65	real zt_aer (ndlon,nuco2)
	66
	67	real ksi (ndlon,nuco2,0:nflev+1,0:nflev+1)
	68	real ksi_emis (ndlon,nuco2,0:nflev+1,0:nflev+1)
	69	real trans (ndlon,nuco2,0:nflev+1,0:nflev+1)
	70	real trans_emis (ndlon,nuco2,0:nflev+1,0:nflev+1)
	71
	72	c----------------------------------------------------------------------
[1047]	73	ndim = ndlonnuco2(nflev+2)*(nflev+2)
[38]	74	call zerophys(ndim,ksi_emis)
	75	c----------------------------------------------------------------------
	76	c 1.0 Transmission functions
	77	c ----------------------
	78
	79	c----------------------------------------------------------------------
	80	c 1.1 Direct transmission
	81	c -------------------
	82
	83	do jk = 1 , nlaylte+1
	84	do jkk = jk , nlaylte+1
	85
	86	do ja = 1 , nuco2
	87	do jl = 1 , kdlon
	88	c co2
	89	c ---
	90	zu(jl,ja) = co2_u(jl,ja,jk) - co2_u(jl,ja,jkk)
	91	zup(jl,ja) = co2_up(jl,ja,jk) - co2_up(jl,ja,jkk)
	92	c aer
	93	c ---
	94	zt_aer(jl,ja)= aer_t(jl,ja,jk)
	95	. /aer_t(jl,ja,jkk)
	96
	97	enddo
	98	enddo
	99
	100	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
	101	c co2 and aer
	102	c -----------
	103	do ja = 1 , nuco2
	104	do jl = 1 , kdlon
	105	trans(jl,ja,jk,jkk) = zt_co2(jl,ja) * zt_aer(jl,ja)
	106	enddo
	107	enddo
	108	c trans reciprocity
	109	c -----------------
	110	do ja = 1 , nuco2
	111	do jl = 1 , kdlon
	112	trans(jl,ja,jkk,jk) = trans(jl,ja,jk,jkk)
	113	c if (trans(jl,ja,jk,jkk) .LT. 0 ) then
	114	c print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
	115	c endif
	116	c if (trans(jl,ja,jk,jkk) .GT. 1) then
	117	c print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
	118	c trans(jl,ja,jk,jkk)=1
	119	c print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
	120	c endif
	121
	122	enddo
	123	enddo
	124
	125	enddo
	126	enddo
	127
	128	c----------------------------------------------------------------------
	129	c 1.2 Transmission with reflexion
	130	c ---------------------------
	131
	132	do jk = 1 , nlaylte+1
	133	do jkk = jk , nlaylte+1
	134
	135	if (callemis) then
	136	do ja = 1 , nuco2
	137	do jl = 1 , kdlon
	138	c co2
	139	c ---
	140	zu(jl,ja) = 2 * co2_u(jl,ja,1) - co2_u(jl,ja,jk)
	141	. - co2_u(jl,ja,jkk)
	142	zup(jl,ja) = 2 * co2_up(jl,ja,1) - co2_up(jl,ja,jk)
	143	. - co2_up(jl,ja,jkk)
	144	c aer
	145	c ---
	146	zt_aer(jl,ja) = aer_t(jl,ja,1)
	147	. * aer_t(jl,ja,1)
	148	. / aer_t(jl,ja,jk)
	149	. / aer_t(jl,ja,jkk)
	150	enddo
	151	enddo
	152
	153	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
	154	c co2 and aer
	155	c -----------
	156	do ja = 1 , nuco2
	157	do jl = 1 , kdlon
	158	trans_emis(jl,ja,jk,jkk) = zt_co2(jl,ja)
	159	. * zt_aer(jl,ja)
	160	enddo
	161	enddo
	162
	163	else
	164
	165	do ja = 1 , nuco2
	166	do jl = 1 , kdlon
	167	trans_emis(jl,ja,jk,jkk) = 1.
	168	enddo
	169	enddo
	170
	171	endif
	172	c trans reciprocity
	173	c -----------------
	174	do ja = 1 , nuco2
	175	do jl = 1 , kdlon
	176	trans_emis(jl,ja,jkk,jk) = trans_emis(jl,ja,jk,jkk)
	177	c if (trans_emis(jl,ja,jk,jkk) .LT. 0
	178	c . .OR. trans_emis(jl,ja,jk,jkk) .GT. 1) then
	179	c print*,'trans_emis bande',ja,jk,jkk,trans_emis(jl,ja,jk,jkk)
	180	c endif
	181	enddo
	182	enddo
	183
	184	enddo
	185	enddo
	186
	187	c----------------------------------------------------------------------
	188	c 2.0 Exchange Coefficiants
	189	c ---------------------
	190
	191	do jk = 1 , nlaylte-2
	192	do jkk = jk+2 , nlaylte
	193	do ja = 1 , nuco2
	194	do jl = 1 , kdlon
	195
	196	ksi(jl,ja,jk,jkk) =
	197	. trans(jl,ja,jk+1,jkk) - trans(jl,ja,jk,jkk)
	198	. - trans(jl,ja,jk+1,jkk+1) + trans(jl,ja,jk,jkk+1)
	199
	200	ksi_emis(jl,ja,jk,jkk) =
	201	. trans_emis(jl,ja,jk,jkk) - trans_emis(jl,ja,jk+1,jkk)
	202	. - trans_emis(jl,ja,jk,jkk+1) + trans_emis(jl,ja,jk+1,jkk+1)
	203
	204	c if (ksi(jl,ja,jk,jkk) .LT. 0 ) then
	205	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
	206	c ksi(jl,ja,jk,jkk)=0
	207	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
	208	c endif
	209	c if (ksi(jl,ja,jk,jkk) .GT. 1) then
	210	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
	211	c ksi(jl,ja,jk,jkk)=1
	212	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
	213	c endif
	214
	215	c if (ksi_emis(jl,ja,jk,jkk) .LT. 0
	216	c . .OR. ksi_emis(jl,ja,jk,jkk) .GT. 1) then
	217	c print*,'ksi_emis bande',ja,jk,jkk,ksi_emis(jl,ja,jk,jkk)
	218	c endif
	219
	220	xi(ig0+jl,ja,jk,jkk) = ksi(jl,ja,jk,jkk)
	221	. + ksi_emis(jl,ja,jk,jkk) * (1 - emis(jl))
	222
	223	c ksi reciprocity
	224	c ---------------
	225	ksi(jl,ja,jkk,jk) = ksi(jl,ja,jk,jkk)
	226	ksi_emis(jl,ja,jkk,jk) = ksi_emis(jl,ja,jk,jkk)
	227	xi(ig0+jl,ja,jkk,jk) = xi(ig0+jl,ja,jk,jkk)
	228
	229	enddo
	230	enddo
	231	enddo
	232	enddo
	233
	234	c----------------------------------------------------------------------
	235	c 2.1 Save xi_emis for neighbours (lwxn.F)
	236	c -----------------------------------
	237
	238	do jk = 1 , nlaylte-1
	239	do ja = 1 , nuco2
	240	do jl = 1 , kdlon
	241
	242	c ksi_emis(jl,ja,jk,jk+1) =
	243	c . trans_emis(jl,ja,jk,jk+1) - trans_emis(jl,ja,jk+1,jk+1)
	244	c . - trans_emis(jl,ja,jk,jk+2) + trans_emis(jl,ja,jk+1,jk+2)
	245
	246	xi_emis(ig0+jl,ja,jk) =
	247	. ksi_emis(jl,ja,jk,jk+1) * (1-emis(jl))
	248
	249	enddo
	250	enddo
	251	enddo
	252
	253	c----------------------------------------------------------------------
	254	return
	255	end

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

Download in other formats:

Original Format