Context Navigation

lwxd.F @ 1242

Last change on this file since 1242 was 1047, checked in by emillour, 11 years ago

Mars GCM:

IMPORTANT CHANGE: Removed all reference/use of ngridmx (dimphys.h) in routines (necessary prerequisite to using parallel dynamics); in most cases this just means adding 'ngrid' as routine argument, and making local saved variables allocatable (and allocated at first call). In the process, had to convert many *.h files to equivalent modules: yomaer.h => yomaer_h.F90 , surfdat.h => surfdat_h.F90 , comsaison.h => comsaison_h.F90 , yomlw.h => yomlw_h.F90 , comdiurn.h => comdiurn_h.F90 , dimradmars.h => dimradmars_mod.F90 , comgeomfi.h => comgeomfi_h.F90, comsoil.h => comsoil_h.F90 , slope.h => slope_mod.F90
Also updated EOF routines, everything is now in eofdump_mod.F90
Removed unused routine lectfux.F (in dyn3d)

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

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

Download in other formats:

Original Format