Context Navigation

lwxd.F @ 3400

Last change on this file since 3400 was 1917, checked in by emillour, 7 years ago
Mars GCM: Code cleanup: get rid of routine "zerophys". EM
File size: 9.2 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
[1917]	38	include "callkeys.h"
[38]	39
	40	c----------------------------------------------------------------------
	41	c 0.1 arguments
	42	c ---------
	43	c inputs:
	44	c -------
[1917]	45	integer,intent(in) :: ig0
	46	integer,intent(in) :: kdlon ! part of ngrid
	47	integer,intent(in) :: kflev ! part of nalyer
[38]	48
[1917]	49	real,intent(in) :: emis (ndlo2) ! surface emissivity
	50	real,intent(in) :: aer_t (ndlo2,nuco2,kflev+1) ! transmission (aer)
	51	real,intent(in) :: co2_u (ndlo2,nuco2,kflev+1) ! absorber amounts (co2)
	52	real,intent(in) :: co2_up (ndlo2,nuco2,kflev+1) ! idem scaled by the pressure (co2)
[38]	53
	54	c----------------------------------------------------------------------
	55	c 0.2 local arrays
	56	c ------------
	57
[1917]	58	integer ja,jl,jk,jkk
[38]	59	real zu (ndlon,nuco2)
	60	real zup (ndlon,nuco2)
	61	real zt_co2 (ndlon,nuco2)
	62	real zt_aer (ndlon,nuco2)
	63
	64	real ksi (ndlon,nuco2,0:nflev+1,0:nflev+1)
	65	real ksi_emis (ndlon,nuco2,0:nflev+1,0:nflev+1)
	66	real trans (ndlon,nuco2,0:nflev+1,0:nflev+1)
	67	real trans_emis (ndlon,nuco2,0:nflev+1,0:nflev+1)
	68
	69	c----------------------------------------------------------------------
[1917]	70	ksi_emis(:,:,:,:)=0
[38]	71	c----------------------------------------------------------------------
	72	c 1.0 Transmission functions
	73	c ----------------------
	74
	75	c----------------------------------------------------------------------
	76	c 1.1 Direct transmission
	77	c -------------------
	78
	79	do jk = 1 , nlaylte+1
	80	do jkk = jk , nlaylte+1
	81
	82	do ja = 1 , nuco2
	83	do jl = 1 , kdlon
	84	c co2
	85	c ---
	86	zu(jl,ja) = co2_u(jl,ja,jk) - co2_u(jl,ja,jkk)
	87	zup(jl,ja) = co2_up(jl,ja,jk) - co2_up(jl,ja,jkk)
	88	c aer
	89	c ---
	90	zt_aer(jl,ja)= aer_t(jl,ja,jk)
	91	. /aer_t(jl,ja,jkk)
	92
	93	enddo
	94	enddo
	95
	96	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
	97	c co2 and aer
	98	c -----------
	99	do ja = 1 , nuco2
	100	do jl = 1 , kdlon
	101	trans(jl,ja,jk,jkk) = zt_co2(jl,ja) * zt_aer(jl,ja)
	102	enddo
	103	enddo
	104	c trans reciprocity
	105	c -----------------
	106	do ja = 1 , nuco2
	107	do jl = 1 , kdlon
	108	trans(jl,ja,jkk,jk) = trans(jl,ja,jk,jkk)
	109	c if (trans(jl,ja,jk,jkk) .LT. 0 ) then
	110	c print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
	111	c endif
	112	c if (trans(jl,ja,jk,jkk) .GT. 1) then
	113	c print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
	114	c trans(jl,ja,jk,jkk)=1
	115	c print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
	116	c endif
	117
	118	enddo
	119	enddo
	120
	121	enddo
	122	enddo
	123
	124	c----------------------------------------------------------------------
	125	c 1.2 Transmission with reflexion
	126	c ---------------------------
	127
	128	do jk = 1 , nlaylte+1
	129	do jkk = jk , nlaylte+1
	130
	131	if (callemis) then
	132	do ja = 1 , nuco2
	133	do jl = 1 , kdlon
	134	c co2
	135	c ---
	136	zu(jl,ja) = 2 * co2_u(jl,ja,1) - co2_u(jl,ja,jk)
	137	. - co2_u(jl,ja,jkk)
	138	zup(jl,ja) = 2 * co2_up(jl,ja,1) - co2_up(jl,ja,jk)
	139	. - co2_up(jl,ja,jkk)
	140	c aer
	141	c ---
	142	zt_aer(jl,ja) = aer_t(jl,ja,1)
	143	. * aer_t(jl,ja,1)
	144	. / aer_t(jl,ja,jk)
	145	. / aer_t(jl,ja,jkk)
	146	enddo
	147	enddo
	148
	149	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
	150	c co2 and aer
	151	c -----------
	152	do ja = 1 , nuco2
	153	do jl = 1 , kdlon
	154	trans_emis(jl,ja,jk,jkk) = zt_co2(jl,ja)
	155	. * zt_aer(jl,ja)
	156	enddo
	157	enddo
	158
	159	else
	160
	161	do ja = 1 , nuco2
	162	do jl = 1 , kdlon
	163	trans_emis(jl,ja,jk,jkk) = 1.
	164	enddo
	165	enddo
	166
	167	endif
	168	c trans reciprocity
	169	c -----------------
	170	do ja = 1 , nuco2
	171	do jl = 1 , kdlon
	172	trans_emis(jl,ja,jkk,jk) = trans_emis(jl,ja,jk,jkk)
	173	c if (trans_emis(jl,ja,jk,jkk) .LT. 0
	174	c . .OR. trans_emis(jl,ja,jk,jkk) .GT. 1) then
	175	c print*,'trans_emis bande',ja,jk,jkk,trans_emis(jl,ja,jk,jkk)
	176	c endif
	177	enddo
	178	enddo
	179
	180	enddo
	181	enddo
	182
	183	c----------------------------------------------------------------------
	184	c 2.0 Exchange Coefficiants
	185	c ---------------------
	186
	187	do jk = 1 , nlaylte-2
	188	do jkk = jk+2 , nlaylte
	189	do ja = 1 , nuco2
	190	do jl = 1 , kdlon
	191
	192	ksi(jl,ja,jk,jkk) =
	193	. trans(jl,ja,jk+1,jkk) - trans(jl,ja,jk,jkk)
	194	. - trans(jl,ja,jk+1,jkk+1) + trans(jl,ja,jk,jkk+1)
	195
	196	ksi_emis(jl,ja,jk,jkk) =
	197	. trans_emis(jl,ja,jk,jkk) - trans_emis(jl,ja,jk+1,jkk)
	198	. - trans_emis(jl,ja,jk,jkk+1) + trans_emis(jl,ja,jk+1,jkk+1)
	199
	200	c if (ksi(jl,ja,jk,jkk) .LT. 0 ) then
	201	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
	202	c ksi(jl,ja,jk,jkk)=0
	203	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
	204	c endif
	205	c if (ksi(jl,ja,jk,jkk) .GT. 1) then
	206	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
	207	c ksi(jl,ja,jk,jkk)=1
	208	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
	209	c endif
	210
	211	c if (ksi_emis(jl,ja,jk,jkk) .LT. 0
	212	c . .OR. ksi_emis(jl,ja,jk,jkk) .GT. 1) then
	213	c print*,'ksi_emis bande',ja,jk,jkk,ksi_emis(jl,ja,jk,jkk)
	214	c endif
	215
	216	xi(ig0+jl,ja,jk,jkk) = ksi(jl,ja,jk,jkk)
	217	. + ksi_emis(jl,ja,jk,jkk) * (1 - emis(jl))
	218
	219	c ksi reciprocity
	220	c ---------------
	221	ksi(jl,ja,jkk,jk) = ksi(jl,ja,jk,jkk)
	222	ksi_emis(jl,ja,jkk,jk) = ksi_emis(jl,ja,jk,jkk)
	223	xi(ig0+jl,ja,jkk,jk) = xi(ig0+jl,ja,jk,jkk)
	224
	225	enddo
	226	enddo
	227	enddo
	228	enddo
	229
	230	c----------------------------------------------------------------------
	231	c 2.1 Save xi_emis for neighbours (lwxn.F)
	232	c -----------------------------------
	233
	234	do jk = 1 , nlaylte-1
	235	do ja = 1 , nuco2
	236	do jl = 1 , kdlon
	237
	238	c ksi_emis(jl,ja,jk,jk+1) =
	239	c . trans_emis(jl,ja,jk,jk+1) - trans_emis(jl,ja,jk+1,jk+1)
	240	c . - trans_emis(jl,ja,jk,jk+2) + trans_emis(jl,ja,jk+1,jk+2)
	241
	242	xi_emis(ig0+jl,ja,jk) =
	243	. ksi_emis(jl,ja,jk,jk+1) * (1-emis(jl))
	244
	245	enddo
	246	enddo
	247	enddo
	248
	249	c----------------------------------------------------------------------
	250	end

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

Download in other formats:

Original Format