Context Navigation

mat_oper.F @ 416

Last change on this file since 416 was 414, checked in by aslmd, 14 years ago

LMDZ.MARS : NEW NLTE MODEL FROM GRANADA AMIGOS

23/11/11 == FGG + MALV

New parameterization of the NLTE 15 micron cooling. The old parameterization is kept as an option, including or not variable atomic oxygen concentration. A new flag is introduced in callphys.def, nltemodel, to select which parameterization wants to be used (new one, old one with variable [O], or old one with fixed [O], see below). Includes many new subroutines and commons in phymars. Some existing routines are also modified:

-physiq.F. Call to the new subroutine NLTE_leedat in first call. Call to nltecool modified to allow for variable atomic oxygen. Depending on the value of nltemodel, the new subroutine NLTEdlvr09_TCOOL is called instead of nltecool.

-inifis.F. Reading of nltemodel is added.

-callkeys.h Declaration of nltemodel is added.

The following lines should be added to callphys.def (ideally after setting callnlte):

# NLTE 15um scheme to use.
# 0-> Old scheme, static oxygen
# 1-> Old scheme, dynamic oxygen
# 2-> New scheme
nltemodel = 2

A new directory, NLTEDAT, has to be included in datagcm.

Improvements into NLTE NIR heating parameterization to take into account variability with O/CO2 ratio and SZA. A new subroutine, NIR_leedat.F, and a new common, NIRdata.h, are included. A new flag, nircorr, is added in callphys.def, to include or not these corrections. The following files are modified:

-nirco2abs.F: nq and pq are added in the arguments. The corrections factors are interpolated to the GCM grid and included in the clculation. A new subroutine, interpnir, is added at the end of the file.

-physiq.F: Call to NIR_leedat added at first call. Modified call to nirco2abs

-inifis: Reading new flag nircorr.

-callkeys.h: Declaration of nircorr.

The following lines have to be added to callphys.def (ideally after callnirco2):

# NIR NLTE correction for variable SZA and O/CO2?
# matters only if callnirco2=T
# 0-> no correction
# 1-> include correction
nircorr=1

A new data file, NIRcorrection_feb2011.dat, has to be included in datagcm.

Small changes to the molecular diffusion scheme to fix the number of species considered, to avoid problems when compiling with more than 15 tracers (for example, when CH4 is included). Modified subroutines: aeronomars/moldiff.F and aeronomars/moldiffcoeff.F

File size: 18.8 KB

Rev	Line
[414]	1	c set of subroutines for the cz*.for programs:
	2	! subroutine unit(a,n)
	3	! subroutine vector(v,cte,n)
	4	! subroutine diagop(a,v,n)
	5	! subroutine diago(a,v,n) diagonal matrix with v
	6	! subroutine dyago(a,v,n) diagonal matrix with inverse of v
	7	! subroutine invdiag(a,b,n) inverse of diagonal matrix
	8	! subroutine sypvvv(a,b,c,d,n) suma y prod de 3 vectores, muy comun
	9	! subroutine sypvmv(v,w,b,u,n) suma y prod de 3 vectores, muy comun
	10	! subroutine mulmvv(w,b,u,v,n) prod matriz vector vector
	11	! subroutine muymvv(w,b,u,v,n) prod matriz (inv.vector) vector
	12	! subroutine samem (a,m,n)
	13	! subroutine samemcore (a,m,n,n-2) extract core of matrix
	14	! subroutine samemsp (a,m,n)
	15	! subroutine samevsp (v,w,n)
	16	! subroutine samev (v,w,n)
	17	! subroutine samevcore (v,w,n,n-2) extract core of vector
	18	! no subroutine operaux (a,n, b,c,d,e, ll,mm,dd,maux1,maux2)
	19	! no subroutine invmcore (a,acore,n, dd,ll,mm)
	20	! subroutine mulmv(a,b,c,n)
	21	! subroutine mulvmv(a,u,b,v,n)
	22	! subroutine mulmm(a,b,c,n)
	23	! subroutine summm(a,b,c,n)
	24	! subroutine resmm(a,b,c,n)
	25	! subroutine mulvv(a,b,c,n)
	26	! subroutine sumvv(a,b,c,n)
	27	! subroutine sumvvv(a,b,c,d,n)
	28	! subroutine resvv(a,b,c,n)
	29	! subroutine zerom(a,n)
	30	! subroutine zeromsp (a,n)
	31	! subroutine zero4m(a,b,c,d,n)
	32	! subroutine zero4msp(a,b,c,d,n)
	33	! subroutine zero3m(a,b,c,n)
	34	! subroutine zero3msp(a,b,c,n)
	35	! subroutine zero2m(a,b,n)
	36	! subroutine zero2msp(a,b,n)
	37	! subroutine zerov(a,n)
	38	! subroutine zerovdim3(a,n1,n2,n3) ! sustituye a zerojt de cristina
	39	! subroutine zero4v(a,b,c,d,n)
	40	! subroutine zero3v(a,b,c,n)
	41	! subroutine zero2v(a,b,n)
	42	! subroutine zerovsp(a,n)
	43	! subroutine zero4vsp(a,b,c,d,n)
	44	! subroutine zero3vsp(a,b,c,n)
	45	! subroutine zero2vsp(a,b,n)
	46	!
	47	!
	48	!
	49	! May-05 Sustituimos todos los zerojt de cristina por las subrutinas
	50	! genericas zerov***
	51	!
	52	c ***********************************************************************
	53	subroutine unit(a,n)
	54	c store the unit value in the diagonal of a
	55	c ***********************************************************************
	56	real*8 a(n,n)
	57	integer n,i,j,k
	58	do 1,i=2,n-1
	59	do 2,j=2,n-1
	60	if(i.eq.j) then
	61	a(i,j) = 1.d0
	62	else
	63	a(i,j)=0.0d0
	64	end if
	65	2 continue
	66	1 continue
	67	do k=1,n
	68	a(n,k) = 0.0d0
	69	a(1,k) = 0.0d0
	70	a(k,1) = 0.0d0
	71	a(k,n) = 0.0d0
	72	end do
	73	return
	74	end
	75
	76	! subroutine vector(v,cte,n)
	77	c ***********************************************************************
	78	subroutine vector(v,cte,n)
	79	c build a vector by storing the value cte in all its elements
	80	c ***********************************************************************
	81	real*8 v(n),cte
	82	integer n,i
	83	do 1,i=1,n
	84	v(i) = cte
	85	1 continue
	86	return
	87	end
	88	c ***********************************************************************
	89	subroutine diagop(a,v,n)
	90	c store the core of v in the diagonal elements of the square matrix a
	91	c ***********************************************************************
	92	real*8 a(n,n),v(n+2)
	93	integer n,i,j,k
	94	do 1,i=2,n-1
	95	do 2,j=2,n-1
	96	if(i.eq.j) then
	97	a(i,j) = v(i+1)
	98	else
	99	a(i,j)=0.0d0
	100	end if
	101	2 continue
	102	1 continue
	103	do k=1,n
	104	a(n,k) = 0.0d0
	105	a(1,k) = 0.0d0
	106	a(k,1) = 0.0d0
	107	a(k,n) = 0.0d0
	108	end do
	109	return
	110	end
	111	c ***********************************************************************
	112	subroutine diago(a,v,n)
	113	c store the vector v in the diagonal elements of the square matrix a
	114	c ***********************************************************************
	115	implicit none
	116
	117	integer n,i,j,k
	118	real*8 a(n,n),v(n)
	119
	120	do 1,i=2,n-1
	121	do 2,j=2,n-1
	122	if(i.eq.j) then
	123	a(i,j) = v(i)
	124	else
	125	a(i,j)=0.0d0
	126	end if
	127	2 continue
	128	1 continue
	129	do k=1,n
	130	a(n,k) = 0.0d0
	131	a(1,k) = 0.0d0
	132	a(k,1) = 0.0d0
	133	a(k,n) = 0.0d0
	134	end do
	135	return
	136	end
	137	c ***********************************************************************
	138	subroutine dyago(a,v,n)
	139	c store the inverse of v in the diagonal elements of the square matrix a
	140	c ***********************************************************************
	141	implicit none
	142
	143	integer n,i,j,k
	144	real*8 a(n,n),v(n)
	145
	146	do 1,i=2,n-1
	147	do 2,j=2,n-1
	148	if(i.eq.j) then
	149	a(i,j) = 1.d0/v(i)
	150	else
	151	a(i,j)=0.0d0
	152	end if
	153	2 continue
	154	1 continue
	155	do k=1,n
	156	a(n,k) = 0.0d0
	157	a(1,k) = 0.0d0
	158	a(k,1) = 0.0d0
	159	a(k,n) = 0.0d0
	160	end do
	161	return
	162	end
	163
	164	c ***********************************************************************
	165	subroutine samem (a,m,n)
	166	c store the matrix m in the matrix a
	167	c ***********************************************************************
	168	real*8 a(n,n),m(n,n)
	169	integer n,i,j,k
	170	do 1,i=2,n-1
	171	do 2,j=2,n-1
	172	a(i,j) = m(i,j)
	173	2 continue
	174	1 continue
	175	do k=1,n
	176	a(n,k) = 0.0d0
	177	a(1,k) = 0.0d0
	178	a(k,1) = 0.0d0
	179	a(k,n) = 0.0d0
	180	end do
	181	return
	182	end
	183	c ***********************************************************************
	184	subroutine samemcore (a,b,m,n)
	185	c store the matrix m in the matrix a
	186	c ***********************************************************************
	187	real*8 a(m,m),b(n,n)
	188	integer n,i,j,k
	189	if ( m.ne.(n-2) ) stop 'Error in dimensions (m.ne.n-2) '
	190	do 1,i=2,n-1
	191	do 2,j=2,n-1
	192	a(i,j) = b(i,j)
	193	2 continue
	194	1 continue
	195	return
	196	end
	197	c ***********************************************************************
	198	subroutine samemsp (a,m,n)
	199	c store the matrix m in the matrix a
	200	c ***********************************************************************
	201	real*4 a(n,n),m(n,n)
	202	integer n,i,j,k
	203	do 1,i=2,n-1
	204	do 2,j=2,n-1
	205	a(i,j) = m(i,j)
	206	2 continue
	207	1 continue
	208	do k=1,n
	209	a(n,k) = 0.0
	210	a(1,k) = 0.0
	211	a(k,1) = 0.0
	212	a(k,n) = 0.0
	213	end do
	214	return
	215	end
	216	c ***********************************************************************
	217	subroutine samevsp (v,w,n)
	218	c store the vector w in the vector v
	219	c ***********************************************************************
	220	real*4 v(n),w(n)
	221	integer n,i
	222	do 1,i=2,n-1
	223	v(i) = w(i)
	224	1 continue
	225	v(1) = 0.0
	226	v(n) = 0.0
	227	return
	228	end
	229	c ***********************************************************************
	230	subroutine samev (v,w,n)
	231	c store the vector w in the vector v
	232	c ***********************************************************************
	233	real*8 v(n),w(n)
	234	integer n,i
	235	do 1,i=2,n-1
	236	v(i) = w(i)
	237	1 continue
	238	v(1) = 0.0d0
	239	v(n) = 0.0d0
	240	return
	241	end
	242	c ***********************************************************************
	243	subroutine samevcore (v,w,m,n)
	244	c store the vector w in the vector v
	245	c ***********************************************************************
	246	real*8 v(m),w(n)
	247	integer n,i
	248	if (m.ne.(n-2)) stop ' Error in dimensions (m.ne.n-2) '
	249	do 1,i=2,n-1
	250	v(i) = w(i)
	251	1 continue
	252	return
	253	end
	254	!c ***********************************************************************
	255	! subroutine operaux (a,n, b,c,d,e, ll,mm,dd,maux1,maux2)
	256	!c ***********************************************************************
	257	! real*8 a(n,n),b(n,n),c(n,n),d(n,n),e(n,n)
	258	! real*8 maux1(n,n),maux2(n,n),ll(n),mm(n),dd
	259	! integer n
	260	! call mulmm(a,c,e,n)
	261	! call unit(maux1,n)
	262	! call resmm(maux2,maux1,a,n) ! maux2 = 1 - c e
	263	! call mynvdpnd(maux2,n,dd,ll,mm) ! maux2 = 1 / (1-ce)
	264	! call mulmm(a,c,d,n)
	265	! call resmm(maux1,b,a,n) ! a = b - c d
	266	! call mulmm(a,maux2,maux1,n) ! a = cax2 * (b-cd)
	267	! return
	268	! end
	269	!c ***********************************************************************
	270	! subroutine invmcore (a,acore,n, dd,ll,mm)
	271	!c ***********************************************************************
	272	! real*8 a(n,n), acore(n-2,n-2)
	273	! real*8 ll(n-2),mm(n-2),dd
	274	! integer i,n,j,k
	275	!
	276	! do i=2,n-1
	277	! do j=2,n-1
	278	! acore(i-1,j-1) = a(i,j)
	279	! end do
	280	! end do
	281	! call mynvdpnd (acore,n-2,dd,ll,mm)
	282	! do i=2,n-1
	283	! do j=2,n-1
	284	! a(i,j) = acore(i-1,j-1)
	285	! end do
	286	! end do
	287	! do k=1,n
	288	! a(1,k) = 0.d0
	289	! a(n,k) = 0.d0
	290	! a(k,1) = 0.d0
	291	! a(k,n) = 0.d0
	292	! end do
	293	!
	294	! return
	295	! end
	296	c ***********************************************************************
	297	subroutine mulmv(a,b,c,n)
	298	c do a(i)=b(i,j)*c(j). a, b, and c must be distint
	299	c ***********************************************************************
	300	implicit none
	301
	302	integer n,i,j
	303	real*8 a(n),b(n,n),c(n),sum
	304
	305	do 1,i=2,n-1
	306	sum=0.0d0
	307	do 2,j=2,n-1
	308	sum=sum+ (b(i,j)) * (c(j))
	309	2 continue
	310	a(i)=sum
	311	1 continue
	312	a(1) = 0.0d0
	313	a(n) = 0.0d0
	314	return
	315	end
	316
	317
	318
	319	cc ***********************************************************************
	320	subroutine muymmv(w,b,c,v,n)
	321	c c(i,j) is diagonall and will be inverted. Let us call Z(i)=c(i,i)^(-1)
	322	c Z(i) and v(i) are vectors. multiply first Z(i) and v(i)
	323	c them multiply b and the previous product. w(i)=b(i,j)*(Z(j)+v(j))
	324	c ***********************************************************************
	325	real*8 w(n),b(n,n),c(n,n),v(n), sum
	326	integer n,i,j,k
	327	do 1,i=2,n-1
	328	sum=0.0d0
	329	do 2,j=2,n-1
	330	sum=sum+ (b(i,j)) * (v(j)/c(j,j))
	331	2 continue
	332	w(i)=sum
	333	1 continue
	334	w(1) = 0.0d0
	335	w(n) = 0.0d0
	336	return
	337	end
	338	cc ***********************************************************************
	339	subroutine muymvv(w,b,u,v,n)
	340	c u(i) is to be inverted. Let us call Z=u^(-1)
	341	c Z(i) and v(i) are vectors. multiply first Z(i) and v(i)
	342	c them multiply b and the previous product. w(i)=b(i,j)*(Z(j)+v(j))
	343	c ***********************************************************************
	344	real*8 w(n),u(n),b(n,n),v(n), sum
	345	integer n,i,j,k
	346	do 1,i=2,n-1
	347	sum=0.0d0
	348	do 2,j=2,n-1
	349	sum=sum+ (b(i,j)) * (v(j)/u(j))
	350	2 continue
	351	w(i)=sum
	352	1 continue
	353	w(1) = 0.0d0
	354	w(n) = 0.0d0
	355	return
	356	end
	357	c ***********************************************************************
	358	subroutine mulmvv(w,b,u,v,n)
	359	c u(i) and v(i) are vectors. multiply first u(i) and v(i)
	360	c them multiply b and the previous product. w(i)=b(i,j)*(u(j)+v(j))
	361	c ***********************************************************************
	362	real*8 w(n),u(n),b(n,n),v(n), sum
	363	integer n,i,j,k
	364	do 1,i=2,n-1
	365	sum=0.0d0
	366	do 2,j=2,n-1
	367	sum=sum+ (b(i,j)) * (u(j)+v(j))
	368	2 continue
	369	w(i)=sum
	370	1 continue
	371	w(1) = 0.0d0
	372	w(n) = 0.0d0
	373	return
	374	end
	375	c ***********************************************************************
	376	subroutine mulvmv(a,u,b,v,n)
	377	c u(i) and v(i) are vectors. store u(i) and v(i) in the diagonal
	378	c elements of square matrixes. then do a(i,j)= u(i,i)b(i,j)v(j,j)
	379	c ***********************************************************************
	380	real*8 a(n,n),u(n),b(n,n),v(n)
	381	integer n,i,j,k
	382	do i=2,n-1
	383	do j=2,n-1
	384	a(i,j)=(b(i,j)) * (v(j))
	385	end do
	386	end do
	387	do i=2,n-1
	388	do j=2,n-1
	389	a(i,j)=(u(i)) * (a(i,j))
	390	end do
	391	end do
	392	do k=1,n
	393	a(1,k) = 0.d0
	394	a(n,k) = 0.d0
	395	a(k,1) = 0.d0
	396	a(k,n) = 0.d0
	397	end do
	398
	399	return
	400	end
	401	c ***********************************************************************
	402	subroutine mulmm(a,b,c,n)
	403	c ***********************************************************************
	404	real*8 a(n,n), b(n,n), c(n,n)
	405	integer n,i,j,k
	406
	407	! do i=2,n-1
	408	! do j=2,n-1
	409	! a(i,j)= 0.d00
	410	! do k=2,n-1
	411	! a(i,j) = a(i,j) + b(i,k) * c(k,j)
	412	! end do
	413	! end do
	414	! end do
	415	do j=2,n-1
	416	do i=2,n-1
	417	a(i,j)=0.d0
	418	enddo
	419	do k=2,n-1
	420	do i=2,n-1
	421	a(i,j)=a(i,j)+b(i,k)*c(k,j)
	422	enddo
	423	enddo
	424	enddo
	425	do k=1,n
	426	a(n,k) = 0.0d0
	427	a(1,k) = 0.0d0
	428	a(k,1) = 0.0d0
	429	a(k,n) = 0.0d0
	430	end do
	431
	432	return
	433	end
	434	c ***********************************************************************
	435	subroutine summm(a,b,c,n)
	436	c ***********************************************************************
	437	real*8 a(n,n), b(n,n), c(n,n)
	438	integer n,i,j,k
	439
	440	do i=2,n-1
	441	do j=2,n-1
	442	a(i,j)= b(i,j) + c(i,j)
	443	end do
	444	end do
	445	do k=1,n
	446	a(n,k) = 0.0d0
	447	a(1,k) = 0.0d0
	448	a(k,1) = 0.0d0
	449	a(k,n) = 0.0d0
	450	end do
	451
	452	return
	453	end
	454	c ***********************************************************************
	455	subroutine resmm(a,b,c,n)
	456	c ***********************************************************************
	457	real*8 a(n,n), b(n,n), c(n,n)
	458	integer n,i,j,k
	459
	460	do i=2,n-1
	461	do j=2,n-1
	462	a(i,j)= b(i,j) - c(i,j)
	463	end do
	464	end do
	465	do k=1,n
	466	a(n,k) = 0.0d0
	467	a(1,k) = 0.0d0
	468	a(k,1) = 0.0d0
	469	a(k,n) = 0.0d0
	470	end do
	471
	472	return
	473	end
	474	c ***********************************************************************
	475	subroutine mulvv(a,b,c,n)
	476	c a(i)=b(i)*c(i)
	477	c ***********************************************************************
	478	real*8 a(n),b(n),c(n)
	479	integer n,i
	480	do 1,i=2,n-1
	481	a(i)= (b(i)) * (c(i))
	482	1 continue
	483	a(1) = 0.0d0
	484	a(n) = 0.0d0
	485	return
	486	end
	487	c ***********************************************************************
	488	subroutine sumvv(a,b,c,n)
	489	c a(i)=b(i)+c(i)
	490	c ***********************************************************************
	491	implicit none
	492
	493	integer n,i
	494	real*8 a(n),b(n),c(n)
	495
	496	do 1,i=2,n-1
	497	a(i)= (b(i)) + (c(i))
	498	1 continue
	499	a(1) = 0.0d0
	500	a(n) = 0.0d0
	501	return
	502	end
	503
	504	c ***********************************************************************
	505	subroutine sumvvv(a,b,c,d,n)
	506	c a(i)=b(i)+c(i)+d(i)
	507	c ***********************************************************************
	508	real*8 a(n),b(n),c(n),d(n)
	509	integer n,i
	510	do 1,i=2,n-1
	511	a(i)= b(i) + c(i) + d(i)
	512	1 continue
	513	a(1) = 0.0d0
	514	a(n) = 0.0d0
	515	return
	516	end
	517	c ***********************************************************************
	518	subroutine resvv(a,b,c,n)
	519	c a(i)=b(i)-c(i)
	520	c ***********************************************************************
	521	real*8 a(n),b(n),c(n)
	522	integer n,i
	523	do 1,i=2,n-1
	524	a(i)= (b(i)) - (c(i))
	525	1 continue
	526	a(1) = 0.0d0
	527	a(n) = 0.0d0
	528	return
	529	end
	530	c ***********************************************************************
	531	subroutine zerom(a,n)
	532	c a(i,j)= 0.0
	533	c ***********************************************************************
	534
	535	implicit none
	536
	537	integer n,i,j
	538	real*8 a(n,n)
	539
	540	do 1,i=1,n
	541	do 2,j=1,n
	542	a(i,j) = 0.0d0
	543	2 continue
	544	1 continue
	545	return
	546	end
	547	c ***********************************************************************
	548	subroutine zeromsp (a,n)
	549	c a(i,j)= 0.0
	550	c ***********************************************************************
	551	real*4 a(n,n)
	552	integer n,i,j
	553	do 1,i=1,n
	554	do 2,j=1,n
	555	a(i,j) = 0.0
	556	2 continue
	557	1 continue
	558	return
	559	end
	560	c ***********************************************************************
	561	subroutine zero4m(a,b,c,d,n)
	562	c a(i,j) = b(i,j) = c(i,j) = d(i,j) = 0.0
	563	c ***********************************************************************
	564	real*8 a(n,n), b(n,n), c(n,n), d(n,n)
	565	integer n,i,j
	566	do 1,i=1,n
	567	do 2,j=1,n
	568	a(i,j) = 0.0d0
	569	b(i,j) = 0.0d0
	570	c(i,j) = 0.0d0
	571	d(i,j) = 0.0d0
	572	2 continue
	573	1 continue
	574	return
	575	end
	576	c ***********************************************************************
	577	subroutine zero4msp(a,b,c,d,n)
	578	c a(i,j) = b(i,j) = c(i,j) = d(i,j) = 0.0
	579	c ***********************************************************************
	580	real*4 a(n,n), b(n,n), c(n,n), d(n,n)
	581	integer n,i,j
	582	do 1,i=1,n
	583	do 2,j=1,n
	584	a(i,j) = 0.0
	585	b(i,j) = 0.0
	586	c(i,j) = 0.0
	587	d(i,j) = 0.0
	588	2 continue
	589	1 continue
	590	return
	591	end
	592	c ***********************************************************************
	593	subroutine zero3m(a,b,c,n)
	594	c a(i,j) = b(i,j) = c(i,j) = 0.0
	595	c **********************************************************************
	596	real*8 a(n,n), b(n,n), c(n,n)
	597	integer n,i,j
	598	do 1,i=1,n
	599	do 2,j=1,n
	600	a(i,j) = 0.0d0
	601	b(i,j) = 0.0d0
	602	c(i,j) = 0.0d0
	603	2 continue
	604	1 continue
	605	return
	606	end
	607	c ***********************************************************************
	608	subroutine zero3msp(a,b,c,n)
	609	c a(i,j) = b(i,j) = c(i,j) = 0.0
	610	c ***********************************************************************
	611	real*4 a(n,n), b(n,n), c(n,n)
	612	integer n,i,j
	613	do 1,i=1,n
	614	do 2,j=1,n
	615	a(i,j) = 0.0
	616	b(i,j) = 0.0
	617	c(i,j) = 0.0
	618	2 continue
	619	1 continue
	620	return
	621	end
	622	c ***********************************************************************
	623	subroutine zero2m(a,b,n)
	624	c a(i,j) = b(i,j) = 0.0
	625	c ***********************************************************************
	626	real*8 a(n,n), b(n,n)
	627	integer n,i,j
	628	do 1,i=1,n
	629	do 2,j=1,n
	630	a(i,j) = 0.0d0
	631	b(i,j) = 0.0d0
	632	2 continue
	633	1 continue
	634	return
	635	end
	636	c ***********************************************************************
	637	subroutine zero2msp(a,b,n)
	638	c a(i,j) = b(i,j) = 0.0
	639	c ***********************************************************************
	640	real*4 a(n,n), b(n,n)
	641	integer n,i,j
	642	do 1,i=1,n
	643	do 2,j=1,n
	644	a(i,j) = 0.0
	645	b(i,j) = 0.0
	646	2 continue
	647	1 continue
	648	return
	649	end
	650	c ***********************************************************************
	651	subroutine zerov(a,n)
	652	c a(i)= 0.0
	653	c ***********************************************************************
	654	real*8 a(n)
	655	integer n,i
	656	do 1,i=1,n
	657	a(i) = 0.0d0
	658	1 continue
	659	return
	660	end
	661	c ***********************************************************************
	662	subroutine zero4v(a,b,c,d,n)
	663	c a(i) = b(i) = c(i) = d(i,j) = 0.0
	664	c ***********************************************************************
	665	real*8 a(n), b(n), c(n), d(n)
	666	integer n,i
	667	do 1,i=1,n
	668	a(i) = 0.0d0
	669	b(i) = 0.0d0
	670	c(i) = 0.0d0
	671	d(i) = 0.0d0
	672	1 continue
	673	return
	674	end
	675	c ***********************************************************************
	676	subroutine zero3v(a,b,c,n)
	677	c a(i) = b(i) = c(i) = 0.0
	678	c ***********************************************************************
	679	real*8 a(n), b(n), c(n)
	680	integer n,i
	681	do 1,i=1,n
	682	a(i) = 0.0d0
	683	b(i) = 0.0d0
	684	c(i) = 0.0d0
	685	1 continue
	686	return
	687	end
	688	c ***********************************************************************
	689	subroutine zero2v(a,b,n)
	690	c a(i) = b(i) = 0.0
	691	c ***********************************************************************
	692	real*8 a(n), b(n)
	693	integer n,i
	694	do 1,i=1,n
	695	a(i) = 0.0d0
	696	b(i) = 0.0d0
	697	1 continue
	698	return
	699	end
	700	c ***********************************************************************
	701	subroutine zerovsp(a,n)
	702	c a(i)= 0.0
	703	c ***********************************************************************
	704	real*4 a(n)
	705	integer n,i
	706	do 1,i=1,n
	707	a(i) = 0.0
	708	1 continue
	709	return
	710	end
	711	c ***********************************************************************
	712	subroutine zero4vsp(a,b,c,d,n)
	713	c a(i) = b(i) = c(i) = d(i) = 0.0
	714	c ***********************************************************************
	715	real*4 a(n), b(n), c(n), d(n)
	716	integer n,i
	717	do 1,i=1,n
	718	a(i) = 0.0
	719	b(i) = 0.0
	720	c(i) = 0.0
	721	d(i) = 0.0
	722	1 continue
	723	return
	724	end
	725	c ***********************************************************************
	726	subroutine zero3vsp(a,b,c,n)
	727	c a(i) = b(i) = c(i) = 0.0
	728	c **********************************************************************
	729	real*4 a(n), b(n), c(n)
	730	integer n,i
	731	do 1,i=1,n
	732	a(i) = 0.0
	733	b(i) = 0.0
	734	c(i) = 0.0
	735	1 continue
	736	return
	737	end
	738	c ***********************************************************************
	739	subroutine zero2vsp(a,b,n)
	740	c a(i) = b(i) = 0.0
	741	c ***********************************************************************
	742	real*4 a(n), b(n)
	743	integer n,i
	744	do 1,i=1,n
	745	a(i) = 0.0
	746	b(i) = 0.0
	747	1 continue
	748	return
	749	end
	750	c ***********************************************************************
	751	!subroutine zerojt(a,n1,n2,n3)
	752	subroutine zerovdim3(a,n1,n2,n3) ! sustituye a zerojt de cristina
	753	c a(i,j,k)= 0.0
	754	c jt(icol,nisos,nb+1,n)
	755	c ***********************************************************************
	756	! real*4 a(9,34,n)
	757	! integer n,i,j,k,icol,ic
	758	real*4 a(n1,n2,n3)
	759	integer n1,n2,n3,i,j,k
	760
	761	do 2,i=1,n1
	762	do 3,j=1,n2
	763	do 4,k=1,n3
	764	a(i,j,k) = 0.0
	765	4 continue
	766	3 continue
	767	2 continue
	768
	769	return
	770	end
	771	c ***********************************************************************

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

Download in other formats:

Original Format