New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

modarrays.F in trunk/AGRIF/AGRIF_FILES – NEMO

Context Navigation

source: trunk/AGRIF/AGRIF_FILES/modarrays.F @ 396

Last change on this file since 396 was 396, checked in by opalod, 18 years ago
Initial revision
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 40.0 KB

Rev	Line
[396]	1	!
	2	! $Id$
	3	!
	4	C AGRIF (Adaptive Grid Refinement In Fortran)
	5	C
	6	C Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
	7	C Christophe Vouland (Christophe.Vouland@imag.fr)
	8	C
	9	C This program is free software; you can redistribute it and/or modify
	10	C it under the terms of the GNU General Public License as published by
	11	C the Free Software Foundation; either version 2 of the License, or
	12	C (at your option) any later version.
	13	C
	14	C This program is distributed in the hope that it will be useful,
	15	C but WITHOUT ANY WARRANTY; without even the implied warranty of
	16	C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	17	C GNU General Public License for more details.
	18	C
	19	C You should have received a copy of the GNU General Public License
	20	C along with this program; if not, write to the Free Software
	21	C Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
	22	C
	23	C
	24	C
	25	CCC Module Agrif_Arrays
	26	C
	27	Module Agrif_Arrays
	28	Use Agrif_Types
	29	C
	30	implicit none
	31	C
	32	Contains
	33	C **************************************************************************
	34	CCC Subroutine Agrif_Childbounds
	35	C **************************************************************************
	36	C
	37	Subroutine Agrif_Childbounds(nbdim,lboundloc,uboundloc,
	38	& pttab,petab,pttruetab,cetruetab,memberin)
	39	C
	40	CCC Description:
	41	CCC Subroutine calculating the global indices of the child grid
	42	C
	43	C
	44	C Declarations:
	45	C
	46
	47	C
	48	C Arguments
	49	INTEGER :: nbdim
	50	INTEGER,DIMENSION(nbdim) :: lboundloc,uboundloc
	51	INTEGER,DIMENSION(nbdim) :: pttab,petab,pttruetab,cetruetab
	52	LOGICAL :: memberin
	53	C
	54	C Local variables
	55	INTEGER :: i,lbglob,ubglob
	56	C
	57	#ifdef AGRIF_MPI
	58	INTEGER :: indglob1,indglob2
	59	#endif
	60	C
	61	C
	62	do i = 1,nbdim
	63	C
	64	lbglob = lboundloc(i)
	65	ubglob = uboundloc(i)
	66	C
	67	#ifdef AGRIF_MPI
	68	C
	69	Call AGRIF_InvLoc(lbglob,Agrif_ProcRank,i,indglob1)
	70	C
	71	Call AGRIF_InvLoc(ubglob,Agrif_ProcRank,i,indglob2)
	72	C
	73	pttruetab(i) = max(pttab(i),indglob1)
	74	C
	75	cetruetab(i) = min(petab(i),indglob2)
	76	C
	77	#else
	78	C
	79	pttruetab(i) = max(pttab(i),lbglob)
	80	C
	81	cetruetab(i) = min(petab(i),ubglob)
	82	C
	83	#endif
	84	C
	85	enddo
	86
	87	memberin = .TRUE.
	88
	89	do i=1,nbdim
	90	IF (cetruetab(i) < pttruetab(i)) THEN
	91	memberin = .FALSE.
	92	EXIT
	93	ENDIF
	94	enddo
	95	C
	96	Return
	97	C
	98	C
	99	End Subroutine Agrif_Childbounds
	100	C
	101	C
	102	C **************************************************************************
	103	CCC Subroutine Agrif_nbdim_Get_bound
	104	C **************************************************************************
	105	C
	106	Subroutine Agrif_nbdim_Get_bound(Variable,
	107	& lower,upper,indice,nbdim)
	108	C
	109	CCC Description:
	110	CCC This subroutine is used to get the lower and the upper boundaries of a
	111	C table. Output datas are scalar.
	112	C
	113	C Declarations:
	114	C
	115
	116	C
	117	C Arguments
	118	C
	119	! we want extract boundaries of this table
	120	TYPE(AGRIF_Variable), Pointer :: Variable
	121	INTEGER :: lower,upper ! output data
	122	! direction in wich we want to know the dimension
	123	INTEGER :: indice
	124	INTEGER :: nbdim ! dimension of the table
	125	C
	126	C Local variables
	127	C
	128	SELECT CASE (nbdim)
	129	CASE (1)
	130	lower = lbound(Variable % array1,indice)
	131	upper = ubound(Variable % array1,indice)
	132	CASE (2)
	133	lower = lbound(Variable % array2,indice)
	134	upper = ubound(Variable % array2,indice)
	135	CASE (3)
	136	lower = lbound(Variable % array3,indice)
	137	upper = ubound(Variable % array3,indice)
	138	CASE (4)
	139	lower = lbound(Variable % array4,indice)
	140	upper = ubound(Variable % array4,indice)
	141	CASE (5)
	142	lower = lbound(Variable % array5,indice)
	143	upper = ubound(Variable % array5,indice)
	144	CASE (6)
	145	lower = lbound(Variable % array6,indice)
	146	upper = ubound(Variable % array6,indice)
	147	END SELECT
	148	C
	149	return
	150	C
	151	End Subroutine Agrif_nbdim_Get_bound
	152	C
	153	C
	154	C **************************************************************************
	155	CCC Subroutine Agrif_Get_bound_dimension
	156	C **************************************************************************
	157	C
	158	Subroutine Agrif_nbdim_Get_bound_dimension(Variable,
	159	& lower,upper,nbdim)
	160	C
	161	CCC Description:
	162	CCC This subroutine is used to get the lower and the upper boundaries of a
	163	C table. Output datas are scalar.
	164	C
	165	C Declarations:
	166	C
	167
	168	C
	169	C Arguments
	170	C
	171	! we want extract boundaries of this table
	172	TYPE(AGRIF_Variable), Pointer :: Variable
	173	INTEGER :: nbdim ! dimension of the table
	174	INTEGER,DIMENSION(nbdim) :: lower,upper ! output data
	175	C
	176	C Local variables
	177	C
	178	SELECT CASE (nbdim)
	179	CASE (1)
	180	lower = lbound(Variable % array1)
	181	upper = ubound(Variable % array1)
	182	CASE (2)
	183	lower = lbound(Variable % array2)
	184	upper = ubound(Variable % array2)
	185	CASE (3)
	186	lower = lbound(Variable % array3)
	187	upper = ubound(Variable % array3)
	188	CASE (4)
	189	lower = lbound(Variable % array4)
	190	upper = ubound(Variable % array4)
	191	CASE (5)
	192	lower = lbound(Variable % array5)
	193	upper = ubound(Variable % array5)
	194	CASE (6)
	195	lower = lbound(Variable % array6)
	196	upper = ubound(Variable % array6)
	197	END SELECT
	198	C
	199	return
	200	C
	201	End Subroutine Agrif_nbdim_Get_bound_dimension
	202
	203	C **************************************************************************
	204	CCC Subroutine Agrif_nbdim_allocation
	205	C **************************************************************************
	206	C
	207	Subroutine Agrif_nbdim_allocation(Variable,inf,sup,nbdim)
	208	C
	209	CCC Description:
	210	CCC This subroutine is used to Allocate the table Variable
	211	C
	212	C Declarations:
	213	C
	214
	215	C
	216	C Arguments
	217	C
	218	TYPE(AGRIF_Variable), Pointer :: Variable
	219	INTEGER :: nbdim ! dimension of the table
	220	INTEGER,DIMENSION(nbdim) :: inf,sup
	221	C
	222	C Local variables
	223	C
	224	SELECT CASE (nbdim)
	225	CASE (1)
	226	allocate(Variable%array1(
	227	& inf(1):sup(1)))
	228	CASE (2)
	229	allocate(Variable%array2(
	230	& inf(1):sup(1),
	231	& inf(2):sup(2)))
	232	CASE (3)
	233	allocate(Variable%array3(
	234	& inf(1):sup(1),
	235	& inf(2):sup(2),
	236	& inf(3):sup(3)))
	237	CASE (4)
	238	allocate(Variable%array4(
	239	& inf(1):sup(1),
	240	& inf(2):sup(2),
	241	& inf(3):sup(3),
	242	& inf(4):sup(4)))
	243	CASE (5)
	244	allocate(Variable%array5(
	245	& inf(1):sup(1),
	246	& inf(2):sup(2),
	247	& inf(3):sup(3),
	248	& inf(4):sup(4),
	249	& inf(5):sup(5)))
	250	CASE (6)
	251	allocate(Variable%array6(
	252	& inf(1):sup(1),
	253	& inf(2):sup(2),
	254	& inf(3):sup(3),
	255	& inf(4):sup(4),
	256	& inf(5):sup(5),
	257	& inf(6):sup(6)))
	258	END SELECT
	259	C
	260	return
	261	C
	262	End Subroutine Agrif_nbdim_allocation
	263	C
	264	C
	265	C **************************************************************************
	266	CCC Subroutine Agrif_nbdim_deallocation
	267	C **************************************************************************
	268	C
	269	Subroutine Agrif_nbdim_deallocation(Variable,nbdim)
	270	C
	271	CCC Description:
	272	CCC This subroutine is used to give the same value to the table Variable
	273	C
	274	C Declarations:
	275	C
	276
	277	C
	278	C Arguments
	279	C
	280	TYPE(AGRIF_Variable), Pointer :: Variable
	281	INTEGER :: nbdim ! dimension of the table
	282	C
	283	C Local variables
	284	C
	285
	286	SELECT CASE (nbdim)
	287	CASE (1)
	288	Deallocate(Variable%array1)
	289	CASE (2)
	290	Deallocate(Variable%array2)
	291	CASE (3)
	292	Deallocate(Variable%array3)
	293	CASE (4)
	294	Deallocate(Variable%array4)
	295	CASE (5)
	296	Deallocate(Variable%array5)
	297	CASE (6)
	298	Deallocate(Variable%array6)
	299	END SELECT
	300	C
	301	return
	302	C
	303	End Subroutine Agrif_nbdim_deallocation
	304	C
	305	C
	306	C **************************************************************************
	307	CCC Subroutine Agrif_nbdim_Full_VarEQreal
	308	C **************************************************************************
	309	C
	310	Subroutine Agrif_nbdim_Full_VarEQreal(Variable,Value,nbdim)
	311	C
	312	CCC Description:
	313	CCC This subroutine is used to get the lower and the upper boundaries of a
	314	C table. Output datas are scalar.
	315	C
	316	C Declarations:
	317	C
	318
	319	C
	320	C Arguments
	321	C
	322	TYPE(AGRIF_Variable), Pointer :: Variable
	323	REAL :: Value
	324	INTEGER :: nbdim ! dimension of the table
	325	C
	326	C Local variables
	327	C
	328	SELECT CASE (nbdim)
	329	CASE (1)
	330	Variable%array1 = Value
	331	CASE (2)
	332	Variable%array2 = Value
	333	CASE (3)
	334	Variable%array3 = Value
	335	CASE (4)
	336	Variable%array4 = Value
	337	CASE (5)
	338	Variable%array5 = Value
	339	CASE (6)
	340	Variable%array6 = Value
	341	END SELECT
	342	C
	343	return
	344	C
	345	End Subroutine Agrif_nbdim_Full_VarEQreal
	346	C
	347	C
	348	#if !defined AGRIF_MPI
	349	C **************************************************************************
	350	CCC Subroutine Agrif_nbdim_VarEQreal
	351	C **************************************************************************
	352	C
	353	Subroutine Agrif_nbdim_VarEQreal(Variable,inf,sup,Value,nbdim)
	354	C
	355	CCC Description:
	356	CCC This subroutine is used to give the same value to a part of
	357	C the table Variable
	358	C
	359	C Declarations:
	360	C
	361
	362	C
	363	C Arguments
	364	C
	365	TYPE(AGRIF_Variable), Pointer :: Variable
	366	REAL :: Value
	367	INTEGER :: nbdim ! dimension of the table
	368	INTEGER,DIMENSION(nbdim) :: inf,sup
	369	C
	370	C Local variables
	371	C
	372	SELECT CASE (nbdim)
	373	CASE (1)
	374	Variable%array1(
	375	& inf(1):sup(1)
	376	& ) = Value
	377	CASE (2)
	378	Variable%array2(
	379	& inf(1):sup(1),
	380	& inf(2):sup(2)
	381	& ) = Value
	382	CASE (3)
	383	Variable%array3(
	384	& inf(1):sup(1),
	385	& inf(2):sup(2),
	386	& inf(3):sup(3)
	387	& ) = Value
	388	CASE (4)
	389	Variable%array4(
	390	& inf(1):sup(1),
	391	& inf(2):sup(2),
	392	& inf(3):sup(3),
	393	& inf(4):sup(4)
	394	& ) = Value
	395	CASE (5)
	396	Variable%array5(
	397	& inf(1):sup(1),
	398	& inf(2):sup(2),
	399	& inf(3):sup(3),
	400	& inf(4):sup(4),
	401	& inf(5):sup(5)
	402	& ) = Value
	403	CASE (6)
	404	Variable%array6(
	405	& inf(1):sup(1),
	406	& inf(2):sup(2),
	407	& inf(3):sup(3),
	408	& inf(4):sup(4),
	409	& inf(5):sup(5),
	410	& inf(6):sup(6)
	411	& ) = Value
	412	END SELECT
	413	C
	414	return
	415	C
	416	End Subroutine Agrif_nbdim_VarEQreal
	417	#endif
	418	C
	419	C
	420	C
	421	C **************************************************************************
	422	CCC Subroutine Agrif_nbdim_VarEQvar
	423	C **************************************************************************
	424	C
	425	Subroutine Agrif_nbdim_VarEQvar(Variable,inf,sup,
	426	& Variable2,inf2,sup2,
	427	& nbdim)
	428	C
	429	CCC Description:
	430	CCC This subroutine is used to give the value of a part of the table
	431	C Variable2 to the table Variable
	432	C
	433	C Declarations:
	434	C
	435
	436	C
	437	C Arguments
	438	C
	439	TYPE(AGRIF_Variable), Pointer :: Variable
	440	TYPE(AGRIF_Variable), Pointer :: Variable2
	441	INTEGER :: nbdim ! dimension of the table
	442	INTEGER,DIMENSION(nbdim) :: inf,sup
	443	INTEGER,DIMENSION(nbdim) :: inf2,sup2
	444	C
	445	C Local variables
	446	C
	447	SELECT CASE (nbdim)
	448	CASE (1)
	449	Variable%array1(inf(1):sup(1)) =
	450	& Variable2%array1(inf2(1):sup2(1))
	451	CASE (2)
	452	Variable%array2(inf(1):sup(1),
	453	& inf(2):sup(2)) =
	454	& Variable2%array2(inf2(1):sup2(1),
	455	& inf2(2):sup2(2))
	456	CASE (3)
	457	Variable%array3(inf(1):sup(1),
	458	& inf(2):sup(2),
	459	& inf(3):sup(3)) =
	460	& Variable2%array3(inf2(1):sup2(1),
	461	& inf2(2):sup2(2),
	462	& inf2(3):sup2(3))
	463	CASE (4)
	464	Variable%array4(inf(1):sup(1),
	465	& inf(2):sup(2),
	466	& inf(3):sup(3),
	467	& inf(4):sup(4)) =
	468	& Variable2%array4(inf2(1):sup2(1),
	469	& inf2(2):sup2(2),
	470	& inf2(3):sup2(3),
	471	& inf2(4):sup2(4))
	472	CASE (5)
	473	Variable%array5(inf(1):sup(1),
	474	& inf(2):sup(2),
	475	& inf(3):sup(3),
	476	& inf(4):sup(4),
	477	& inf(5):sup(5)) =
	478	& Variable2%array5(inf2(1):sup2(1),
	479	& inf2(2):sup2(2),
	480	& inf2(3):sup2(3),
	481	& inf2(4):sup2(4),
	482	& inf2(5):sup2(5))
	483	CASE (6)
	484	Variable%array6(inf(1):sup(1),
	485	& inf(2):sup(2),
	486	& inf(3):sup(3),
	487	& inf(4):sup(4),
	488	& inf(5):sup(5),
	489	& inf(6):sup(6)) =
	490	& Variable2%array6(inf2(1):sup2(1),
	491	& inf2(2):sup2(2),
	492	& inf2(3):sup2(3),
	493	& inf2(4):sup2(4),
	494	& inf2(5):sup2(5),
	495	& inf2(6):sup2(6))
	496	END SELECT
	497	C
	498	return
	499	C
	500	End Subroutine Agrif_nbdim_VarEQvar
	501	C
	502	C **************************************************************************
	503	CCC Subroutine Agrif_nbdim_Full_VarEQvar
	504	C **************************************************************************
	505	C
	506	Subroutine Agrif_nbdim_Full_VarEQvar(Variable,Variable2,
	507	& nbdim)
	508	C
	509	CCC Description:
	510	CCC This subroutine is used to give the value of the table Variable2
	511	C to the table Variable
	512	C
	513	C Declarations:
	514	C
	515
	516	C
	517	C Arguments
	518	C
	519	TYPE(AGRIF_Variable), Pointer :: Variable
	520	TYPE(AGRIF_Variable), Pointer :: Variable2
	521	INTEGER :: nbdim ! dimension of the table
	522	C
	523	C Local variables
	524	C
	525	SELECT CASE (nbdim)
	526	CASE (1)
	527	Variable%array1 = Variable2%array1
	528	CASE (2)
	529	Variable%array2 = Variable2%array2
	530	CASE (3)
	531	Variable%array3 = Variable2%array3
	532	CASE (4)
	533	Variable%array4 = Variable2%array4
	534	CASE (5)
	535	Variable%array5 = Variable2%array5
	536	CASE (6)
	537	Variable%array6 = Variable2%array6
	538	END SELECT
	539	C
	540	return
	541	C
	542	End Subroutine Agrif_nbdim_Full_VarEQvar
	543	C
	544	C
	545	C **************************************************************************
	546	CCC Subroutine Agrif_array2vector
	547	C **************************************************************************
	548	C
	549	Subroutine Agrif_array2vector(array,bounds,vector,nbdim)
	550	C
	551	CCC Description:
	552	CCC This subroutine is used to record the array into the vector
	553	C
	554	C Declarations:
	555	C
	556
	557	C
	558	C Arguments
	559	C
	560	TYPE(AGRIF_Variable), Pointer :: array
	561	REAL, DIMENSION(:) :: vector ! Array used for the time
	562	INTEGER :: nbdim ! dimension of the table
	563	INTEGER,DIMENSION(nbdim,2) :: bounds
	564	C
	565	C Local variables
	566	C
	567	INTEGER :: nind,ir,jr,kr,lr,mr,nr
	568	C
	569	SELECT CASE (nbdim)
	570	CASE (1)
	571	nind=0
	572	do ir=bounds(1,1),bounds(1,2)
	573	nind=nind+1
	574	array%array1(ir) = vector(nind)
	575	enddo
	576	C
	577	CASE (2)
	578	nind=0
	579	do jr=bounds(2,1),bounds(2,2)
	580	do ir=bounds(1,1),bounds(1,2)
	581	nind=nind+1
	582	array%array2(ir,jr) = vector(nind)
	583	enddo
	584	enddo
	585	C
	586	CASE (3)
	587	nind=0
	588	do kr=bounds(3,1),bounds(3,2)
	589	do jr=bounds(2,1),bounds(2,2)
	590	do ir=bounds(1,1),bounds(1,2)
	591	nind=nind+1
	592	array%array3(ir,jr,kr) = vector(nind)
	593	enddo
	594	enddo
	595	enddo
	596	C
	597	CASE (4)
	598	nind=0
	599	do lr=bounds(4,1),bounds(4,2)
	600	do kr=bounds(3,1),bounds(3,2)
	601	do jr=bounds(2,1),bounds(2,2)
	602	do ir=bounds(1,1),bounds(1,2)
	603	nind=nind+1
	604	array%array4(ir,jr,kr,lr) = vector(nind)
	605	enddo
	606	enddo
	607	enddo
	608	enddo
	609	C
	610	CASE (5)
	611	nind=0
	612	do mr=bounds(5,1),bounds(5,2)
	613	do lr=bounds(4,1),bounds(4,2)
	614	do kr=bounds(3,1),bounds(3,2)
	615	do jr=bounds(2,1),bounds(2,2)
	616	do ir=bounds(1,1),bounds(1,2)
	617	nind=nind+1
	618	array%array5(ir,jr,kr,lr,mr) = vector(nind)
	619	enddo
	620	enddo
	621	enddo
	622	enddo
	623	enddo
	624	C
	625	CASE (6)
	626	nind=0
	627	do nr=bounds(6,1),bounds(6,2)
	628	do mr=bounds(5,1),bounds(5,2)
	629	do lr=bounds(4,1),bounds(4,2)
	630	do kr=bounds(3,1),bounds(3,2)
	631	do jr=bounds(2,1),bounds(2,2)
	632	do ir=bounds(1,1),bounds(1,2)
	633	nind=nind+1
	634	array%array6(ir,jr,kr,lr,mr,nr) = vector(nind)
	635	enddo
	636	enddo
	637	enddo
	638	enddo
	639	enddo
	640	enddo
	641	END SELECT
	642	C
	643	return
	644	C
	645	End Subroutine Agrif_array2vector
	646	C
	647	C
	648	C
	649	C **************************************************************************
	650	CCC Subroutine Agrif_vector2array
	651	C **************************************************************************
	652	C
	653	Subroutine Agrif_vector2array(vector,array,bounds,nbdim)
	654	C
	655	CCC Description:
	656	CCC This subroutine is used to record the array into the vector
	657	C
	658	C Declarations:
	659	C
	660
	661	C
	662	C Arguments
	663	C
	664	TYPE(AGRIF_Variable), Pointer :: array
	665	REAL, DIMENSION(:) :: vector ! Array used for the time
	666	INTEGER :: nbdim ! dimension of the table
	667	INTEGER,DIMENSION(nbdim,2) :: bounds
	668	C
	669	C Local variables
	670	C
	671	INTEGER :: nind,ir,jr,kr,lr,mr,nr
	672	C
	673	SELECT CASE (nbdim)
	674	CASE (1)
	675	nind=0
	676	do ir=bounds(1,1),bounds(1,2)
	677	nind=nind+1
	678	vector(nind) = array%array1(ir)
	679	enddo
	680	C
	681	CASE (2)
	682	nind=0
	683	do jr=bounds(2,1),bounds(2,2)
	684	do ir=bounds(1,1),bounds(1,2)
	685	nind=nind+1
	686	vector(nind) = array%array2(ir,jr)
	687	enddo
	688	enddo
	689	C
	690	CASE (3)
	691	nind=0
	692	do kr=bounds(3,1),bounds(3,2)
	693	do jr=bounds(2,1),bounds(2,2)
	694	do ir=bounds(1,1),bounds(1,2)
	695	nind=nind+1
	696	vector(nind) = array%array3(ir,jr,kr)
	697	enddo
	698	enddo
	699	enddo
	700	C
	701	CASE (4)
	702	nind=0
	703	do lr=bounds(4,1),bounds(4,2)
	704	do kr=bounds(3,1),bounds(3,2)
	705	do jr=bounds(2,1),bounds(2,2)
	706	do ir=bounds(1,1),bounds(1,2)
	707	nind=nind+1
	708	vector(nind) = array%array4(ir,jr,kr,lr)
	709	enddo
	710	enddo
	711	enddo
	712	enddo
	713	C
	714	CASE (5)
	715	nind=0
	716	do mr=bounds(5,1),bounds(5,2)
	717	do lr=bounds(4,1),bounds(4,2)
	718	do kr=bounds(3,1),bounds(3,2)
	719	do jr=bounds(2,1),bounds(2,2)
	720	do ir=bounds(1,1),bounds(1,2)
	721	nind=nind+1
	722	vector(nind) = array%array5(ir,jr,kr,lr,mr)
	723	enddo
	724	enddo
	725	enddo
	726	enddo
	727	enddo
	728	C
	729	CASE (6)
	730	nind=0
	731	do nr=bounds(6,1),bounds(6,2)
	732	do mr=bounds(5,1),bounds(5,2)
	733	do lr=bounds(4,1),bounds(4,2)
	734	do kr=bounds(3,1),bounds(3,2)
	735	do jr=bounds(2,1),bounds(2,2)
	736	do ir=bounds(1,1),bounds(1,2)
	737	nind=nind+1
	738	vector(nind) = array%array6(ir,jr,kr,lr,mr,nr)
	739	enddo
	740	enddo
	741	enddo
	742	enddo
	743	enddo
	744	enddo
	745	END SELECT
	746	C
	747	return
	748	C
	749	End Subroutine Agrif_vector2array
	750
	751	#ifdef AGRIF_MPI
	752	C **************************************************************************
	753	CCC Subroutine GiveAgrif_SpecialValueToTab_mpi
	754	C **************************************************************************
	755	C
	756	Subroutine GiveAgrif_SpecialValueToTab_mpi(Variable1,Variable2,
	757	& bound1,lower,upper,Value,nbdim)
	758	C
	759	CCC Description:
	760	CCC
	761	C
	762	C Declarations:
	763	C
	764
	765	C
	766	C Arguments
	767	C
	768	TYPE(AGRIF_VARIABLE), Pointer :: Variable1
	769	TYPE(AGRIF_VARIABLE), Pointer :: Variable2
	770	INTEGER :: nbdim
	771	INTEGER,DIMENSION(:,:,:) :: bound1
	772	INTEGER,DIMENSION(nbdim) :: lower,upper
	773	REAL :: Value
	774	C
	775	C Local variables
	776	C
	777	SELECT CASE (nbdim)
	778	CASE (1)
	779	Where (Variable1 % array1(
	780	& bound1(lower(1),1,2):bound1(upper(1),1,2))
	781	& == Value)
	782	Variable2 % array1(lower(1):upper(1))
	783	& = Value
	784	C
	785	End Where
	786	CASE (2)
	787	Where (Variable1 % array2(
	788	& bound1(lower(1),1,2):bound1(upper(1),1,2),
	789	& bound1(lower(2),2,2):bound1(upper(2),2,2))
	790	& == Value)
	791	Variable2 % array2(lower(1):upper(1),
	792	& lower(2):upper(2))
	793	& = Value
	794	C
	795	End Where
	796	CASE (3)
	797	Where (Variable1 % array3(
	798	& bound1(lower(1),1,2):bound1(upper(1),1,2),
	799	& bound1(lower(2),2,2):bound1(upper(2),2,2),
	800	& bound1(lower(3),3,2):bound1(upper(3),3,2))
	801	& == Value)
	802	Variable2 % array3(lower(1):upper(1),
	803	& lower(2):upper(2),
	804	& lower(3):upper(3))
	805	& = Value
	806	C
	807	End Where
	808	CASE (4)
	809	Where (Variable1 % array4(
	810	& bound1(lower(1),1,2):bound1(upper(1),1,2),
	811	& bound1(lower(2),2,2):bound1(upper(2),2,2),
	812	& bound1(lower(3),3,2):bound1(upper(3),3,2),
	813	& bound1(lower(4),4,2):bound1(upper(4),4,2))
	814	& == Value)
	815	Variable2 % array4(lower(1):upper(1),
	816	& lower(2):upper(2),
	817	& lower(3):upper(3),
	818	& lower(4):upper(4))
	819	& = Value
	820	C
	821	End Where
	822	CASE (5)
	823	Where (Variable1 % array5(
	824	& bound1(lower(1),1,2):bound1(upper(1),1,2),
	825	& bound1(lower(2),2,2):bound1(upper(2),2,2),
	826	& bound1(lower(3),3,2):bound1(upper(3),3,2),
	827	& bound1(lower(4),4,2):bound1(upper(4),4,2),
	828	& bound1(lower(5),5,2):bound1(upper(5),5,2))
	829	& == Value)
	830	Variable2 % array5(lower(1):upper(1),
	831	& lower(2):upper(2),
	832	& lower(3):upper(3),
	833	& lower(4):upper(4),
	834	& lower(5):upper(5))
	835	& = Value
	836	C
	837	End Where
	838	CASE (6)
	839	Where (Variable1 % array6(
	840	& bound1(lower(1),1,2):bound1(upper(1),1,2),
	841	& bound1(lower(2),2,2):bound1(upper(2),2,2),
	842	& bound1(lower(2),3,2):bound1(upper(3),3,2),
	843	& bound1(lower(4),4,2):bound1(upper(4),4,2),
	844	& bound1(lower(5),5,2):bound1(upper(5),5,2),
	845	& bound1(lower(6),6,2):bound1(upper(6),6,2))
	846	& == Value)
	847	Variable2 % array6(lower(1):upper(1),
	848	& lower(2):upper(2),
	849	& lower(3):upper(3),
	850	& lower(4):upper(4),
	851	& lower(5):upper(5),
	852	& lower(6):upper(6))
	853	& = Value
	854	C
	855	End Where
	856	END SELECT
	857	C
	858	return
	859	C
	860	End Subroutine GiveAgrif_SpecialValueToTab_mpi
	861	#else
	862	C **************************************************************************
	863	CCC Subroutine GiveAgrif_SpecialValueToTab
	864	C **************************************************************************
	865	C
	866	Subroutine GiveAgrif_SpecialValueToTab(Variable1,Variable2,
	867	& lower,upper,Value,nbdim)
	868	C
	869	CCC Description:
	870	CCC
	871	C
	872	C Declarations:
	873	C
	874
	875	C
	876	C Arguments
	877	C
	878	TYPE(AGRIF_VARIABLE), Pointer :: Variable1
	879	TYPE(AGRIF_VARIABLE), Pointer :: Variable2
	880	INTEGER :: nbdim
	881	INTEGER,DIMENSION(nbdim) :: lower,upper
	882	REAL :: Value
	883	C
	884	C Local variables
	885	C
	886	SELECT CASE (nbdim)
	887	CASE (1)
	888	Where (Variable1 % array1(
	889	& lower(1):upper(1))
	890	& == Value)
	891	Variable2 % array1(lower(1):upper(1))
	892	& = Value
	893	C
	894	End Where
	895	CASE (2)
	896	Where (Variable1 % array2(
	897	& lower(1):upper(1),
	898	& lower(2):upper(2))
	899	& == Value)
	900	Variable2 % array2(lower(1):upper(1),
	901	& lower(2):upper(2))
	902	& = Value
	903	C
	904	End Where
	905	CASE (3)
	906	Where (Variable1 % array3(
	907	& lower(1):upper(1),
	908	& lower(2):upper(2),
	909	& lower(3):upper(3))
	910	& == Value)
	911	Variable2 % array3(lower(1):upper(1),
	912	& lower(2):upper(2),
	913	& lower(3):upper(3))
	914	& = Value
	915	C
	916	End Where
	917	CASE (4)
	918	Where (Variable1 % array4(
	919	& lower(1):upper(1),
	920	& lower(2):upper(2),
	921	& lower(3):upper(3),
	922	& lower(4):upper(4))
	923	& == Value)
	924	Variable2 % array4(lower(1):upper(1),
	925	& lower(2):upper(2),
	926	& lower(3):upper(3),
	927	& lower(4):upper(4))
	928	& = Value
	929	C
	930	End Where
	931	CASE (5)
	932	Where (Variable1 % array5(
	933	& lower(1):upper(1),
	934	& lower(2):upper(2),
	935	& lower(3):upper(3),
	936	& lower(4):upper(4),
	937	& lower(5):upper(5))
	938	& == Value)
	939	Variable2 % array5(lower(1):upper(1),
	940	& lower(2):upper(2),
	941	& lower(3):upper(3),
	942	& lower(4):upper(4),
	943	& lower(5):upper(5))
	944	& = Value
	945	C
	946	End Where
	947	CASE (6)
	948	Where (Variable1 % array6(
	949	& lower(1):upper(1),
	950	& lower(2):upper(2),
	951	& lower(2):upper(3),
	952	& lower(4):upper(4),
	953	& lower(5):upper(5),
	954	& lower(6):upper(6))
	955	& == Value)
	956	Variable2 % array6(lower(1):upper(1),
	957	& lower(2):upper(2),
	958	& lower(3):upper(3),
	959	& lower(4):upper(4),
	960	& lower(5):upper(5),
	961	& lower(6):upper(6))
	962	& = Value
	963	C
	964	End Where
	965	END SELECT
	966	C
	967	return
	968	C
	969	End Subroutine GiveAgrif_SpecialValueToTab
	970	#endif
	971	C
	972	C
	973	#ifdef AGRIF_MPI
	974	C **************************************************************************
	975	CCC Subroutine Where_ValTabToTab_mpi
	976	C **************************************************************************
	977	C
	978	Subroutine Where_ValTabToTab_mpi(
	979	& Variable1,Variable2,
	980	& lower,upper,Value,nbdim)
	981	C
	982	CCC Description:
	983	CCC
	984	C
	985	C Declarations:
	986	C
	987
	988	C
	989	C Arguments
	990	C
	991	TYPE(AGRIF_VARIABLE), Pointer :: Variable1
	992	TYPE(AGRIF_VARIABLE), Pointer :: Variable2
	993	INTEGER :: nbdim
	994	INTEGER,DIMENSION(nbdim) :: lower,upper
	995	REAL :: Value
	996	INTEGER :: i,j,k,l,m,n
	997	C
	998	C Local variables
	999	C
	1000	SELECT CASE (nbdim)
	1001	CASE (1)
	1002	DO i = lower(1),upper(1)
	1003	IF (variable1%array1(i) == Value) then
	1004	variable1%array1(i)=Variable2%array1(i)
	1005	ENDIF
	1006	ENDDO
	1007	CASE (2)
	1008	DO j = lower(2),upper(2)
	1009	DO i = lower(1),upper(1)
	1010	IF (variable1%array2(i,j) == Value) then
	1011	variable1%array2(i,j)=Variable2%array2(i,j)
	1012	ENDIF
	1013	ENDDO
	1014	ENDDO
	1015	CASE (3)
	1016	DO k = lower(3),upper(3)
	1017	DO j = lower(2),upper(2)
	1018	DO i = lower(1),upper(1)
	1019	IF (variable1%array3(i,j,k) == Value) then
	1020	variable1%array3(i,j,k)=Variable2%array3(i,j,k)
	1021	ENDIF
	1022	ENDDO
	1023	ENDDO
	1024	ENDDO
	1025	CASE (4)
	1026	DO l = lower(4),upper(4)
	1027	DO k = lower(3),upper(3)
	1028	DO j = lower(2),upper(2)
	1029	DO i = lower(1),upper(1)
	1030	IF (variable1%array4(i,j,k,l) == Value) then
	1031	variable1%array4(i,j,k,l)=Variable2%array4(i,j,k,l)
	1032	ENDIF
	1033	ENDDO
	1034	ENDDO
	1035	ENDDO
	1036	ENDDO
	1037	CASE (5)
	1038	DO m = lower(5),upper(5)
	1039	DO l = lower(4),upper(4)
	1040	DO k = lower(3),upper(3)
	1041	DO j = lower(2),upper(2)
	1042	DO i = lower(1),upper(1)
	1043	IF (variable1%array5(i,j,k,l,m) == Value) then
	1044	variable1%array5(i,j,k,l,m)=Variable2%array5(i,j,k,l,m)
	1045	ENDIF
	1046	ENDDO
	1047	ENDDO
	1048	ENDDO
	1049	ENDDO
	1050	ENDDO
	1051	CASE (6)
	1052	DO n = lower(6),upper(6)
	1053	DO m = lower(5),upper(5)
	1054	DO l = lower(4),upper(4)
	1055	DO k = lower(3),upper(3)
	1056	DO j = lower(2),upper(2)
	1057	DO i = lower(1),upper(1)
	1058	IF (variable1%array6(i,j,k,l,m,n) == Value) then
	1059	variable1%array6(i,j,k,l,m,n)=Variable2%array6(i,j,k,l,m,n)
	1060	ENDIF
	1061	ENDDO
	1062	ENDDO
	1063	ENDDO
	1064	ENDDO
	1065	ENDDO
	1066	ENDDO
	1067	END SELECT
	1068	C
	1069	return
	1070	C
	1071	End Subroutine Where_ValTabToTab_mpi
	1072	#endif
	1073
	1074	C **************************************************************************
	1075	CCC Subroutine PreProcessToInterpOrUpdate
	1076	C **************************************************************************
	1077	C
	1078	Subroutine PreProcessToInterpOrUpdate(parent,child,
	1079	& petab_Child,
	1080	& pttab_Child,pttab_Parent,
	1081	& s_Child,s_Parent,
	1082	& ds_Child,ds_Parent,
	1083	& nbdim)
	1084	C
	1085	CCC Description:
	1086	CCC
	1087	C
	1088	C Declarations:
	1089	C
	1090	C arguments
	1091	TYPE(AGRIF_PVariable) :: parent ! Variable on the parent grid
	1092	TYPE(AGRIF_PVariable) :: child ! Variable on the child grid
	1093	INTEGER :: nbdim
	1094	INTEGER,DIMENSION(6) :: pttab_child
	1095	INTEGER,DIMENSION(6) :: petab_child
	1096	INTEGER,DIMENSION(6) :: pttab_parent
	1097	TYPE(AGRIF_Variable), Pointer :: root ! Pointer on the variable of the
	1098	! root grid
	1099	TYPE(Agrif_Grid), Pointer :: Agrif_Child_Gr,Agrif_Parent_Gr
	1100	REAL, DIMENSION(6) :: s_child,s_parent
	1101	REAL, DIMENSION(6) :: ds_child,ds_parent
	1102	C locals variables
	1103	INTEGER :: n
	1104
	1105	C
	1106	C Arguments
	1107	C
	1108
	1109	C
	1110	C Local variables
	1111	C
	1112	Agrif_Child_Gr => Agrif_Curgrid
	1113	Agrif_Parent_Gr => Agrif_Curgrid % parent
	1114	C
	1115	root => child % var % root_var
	1116	C
	1117	C Number of dimensions of the current grid
	1118	nbdim = root % nbdim
	1119	C
	1120	do n=1,nbdim
	1121	C
	1122	Select case(root % interptab(n))
	1123	C
	1124	C Value of interptab(n) can be either x,y,z or N for a no space
	1125	C DIMENSION
	1126	C
	1127	C The DIMENSION is 'x'
	1128	case('x')
	1129	C
	1130	pttab_Child(n) = root % point(1)
	1131	C
	1132	pttab_Parent(n) = root % point(1)
	1133	C
	1134	s_Child(n) = Agrif_Child_Gr % Agrif_x(1)
	1135	C
	1136	s_Parent(n) = Agrif_Parent_Gr % Agrif_x(1)
	1137	C
	1138	ds_Child(n) = Agrif_Child_Gr % Agrif_d(1)
	1139	C
	1140	ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(1)
	1141	C
	1142	if (root % posvar(n).EQ.1) then
	1143	C
	1144	petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(1)
	1145	C
	1146	else
	1147	C
	1148	petab_Child(n) = pttab_Child(n) +
	1149	& Agrif_Child_Gr%nb(1) - 1
	1150	C
	1151	s_Child(n) = s_Child(n) + ds_Child(n)/2.
	1152	C
	1153	s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
	1154	C
	1155	endif
	1156	C
	1157	C The DIMENSION is 'y'
	1158	case('y')
	1159	C
	1160	pttab_Child(n) = root % point(2)
	1161	C
	1162	pttab_Parent(n) = root % point(2)
	1163	C
	1164	s_Child(n) = Agrif_Child_Gr % Agrif_x(2)
	1165	C
	1166	s_Parent(n) = Agrif_Parent_Gr % Agrif_x(2)
	1167	C
	1168	ds_Child(n) = Agrif_Child_Gr % Agrif_d(2)
	1169	C
	1170	ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(2)
	1171	C
	1172	if (root % posvar(n).EQ.1) then
	1173	C
	1174	petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(2)
	1175	C
	1176	else
	1177	C
	1178	petab_Child(n) = pttab_Child(n) +
	1179	& Agrif_Child_Gr%nb(2) - 1
	1180	C
	1181	s_Child(n) = s_Child(n) + ds_Child(n)/2.
	1182	C
	1183	s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
	1184	C
	1185	endif
	1186
	1187	C
	1188	C The DIMENSION is 'z'
	1189	case('z')
	1190	C
	1191	pttab_Child(n) = root % point(3)
	1192	C
	1193	pttab_Parent(n) = root % point(3)
	1194	C
	1195	s_Child(n) = Agrif_Child_Gr % Agrif_x(3)
	1196	C
	1197	s_Parent(n) = Agrif_Parent_Gr % Agrif_x(3)
	1198	C
	1199	ds_Child(n) = Agrif_Child_Gr % Agrif_d(3)
	1200	C
	1201	ds_Parent(n) = Agrif_Parent_Gr % Agrif_d(3)
	1202	C
	1203	if (root % posvar(n).EQ.1) then
	1204	C
	1205	petab_Child(n) = pttab_Child(n) + Agrif_Child_Gr%nb(3)
	1206	C
	1207	else
	1208	C
	1209	petab_Child(n) = pttab_Child(n) +
	1210	& Agrif_Child_Gr%nb(3) - 1
	1211	C
	1212	s_Child(n) = s_Child(n) + ds_Child(n)/2.
	1213	C
	1214	s_Parent(n) = s_Parent(n) + ds_Parent(n)/2.
	1215	C
	1216	endif
	1217	C
	1218	C The DIMENSION is not space
	1219	case('N')
	1220	C
	1221	C The next coefficients are calculated in order to do a simple copy of
	1222	C values of the grid variable when the procedure of interpolation is
	1223	C called for this DIMENSION
	1224	C
	1225	Call Agrif_nbdim_Get_bound(child % var,
	1226	& pttab_Child(n),petab_Child(n),n,nbdim)
	1227	C
	1228	C No interpolation but only a copy of the values of the grid variable
	1229	C
	1230	pttab_Parent(n) = pttab_Child(n)
	1231	C
	1232	s_Child(n)=0.
	1233	C
	1234	s_Parent(n)=0.
	1235	C
	1236	ds_Child(n)=1.
	1237	C
	1238	ds_Parent(n)=1.
	1239	C
	1240	End select
	1241	C
	1242	enddo
	1243	C
	1244	return
	1245	C
	1246	End Subroutine PreProcessToInterpOrUpdate
	1247
	1248	#ifdef AGRIF_MPI
	1249	C
	1250	C **************************************************************************
	1251	CCC Subroutine GetLocalBoundaries
	1252	C **************************************************************************
	1253	C
	1254	Subroutine GetLocalBoundaries(tab1,tab2,i,lb,ub,deb,fin)
	1255	C
	1256	CCC Descritpion:
	1257	C
	1258	C
	1259	C Declarations:
	1260	C
	1261
	1262	C
	1263	C
	1264	C Scalar arguments
	1265	INTEGER :: tab1,tab2
	1266	INTEGER :: i
	1267	INTEGER :: lb,ub
	1268	INTEGER :: deb,fin
	1269	C
	1270	C Local scalars
	1271	INTEGER :: imin,imax
	1272	INTEGER :: i1,i2
	1273	C
	1274	C
	1275	Call AGRIF_InvLoc(lb,AGRIF_ProcRank,i,imin)
	1276	C
	1277	Call AGRIF_InvLoc(ub,AGRIF_ProcRank,i,imax)
	1278	C
	1279	C
	1280	if (imin > tab2) then
	1281	C
	1282	i1 = imax - imin
	1283	C
	1284	else
	1285	C
	1286	i1 = max(tab1 - imin,0)
	1287	C
	1288	endif
	1289	C
	1290	if (imax < tab1) then
	1291	C
	1292	i2 = -(imax - imin)
	1293	C
	1294	else
	1295	C
	1296	i2 = min(tab2 - imax,0)
	1297	C
	1298	endif
	1299	C
	1300	deb = lb + i1
	1301	C
	1302	fin = ub + i2
	1303	C
	1304	C
	1305	End Subroutine GetLocalBoundaries
	1306	C
	1307	#endif
	1308	C
	1309	C
	1310	#ifdef AGRIF_MPI
	1311	C
	1312	C **************************************************************************
	1313	CCC Subroutine Agrif_GlobtoLocInd
	1314	C **************************************************************************
	1315	C
	1316	Subroutine Agrif_GlobtoLocInd(tabarray,lboundl,uboundl,tab1,tab2,
	1317	& nbdim,rank)
	1318	C
	1319	CCC Description:
	1320	CCC For a global index located on the current processor, tabarray gives the
	1321	CCC corresponding local index
	1322	C
	1323	C
	1324	C Declarations:
	1325	C
	1326
	1327	C
	1328	C Arguments
	1329	INTEGER :: nbdim
	1330	INTEGER,DIMENSION(nbdim) :: tab1,tab2
	1331	INTEGER,DIMENSION(minval(tab1):maxval(tab2),nbdim,2 ) :: tabarray
	1332	INTEGER,DIMENSION(nbdim) :: lboundl,uboundl
	1333	INTEGER :: rank
	1334	C
	1335	C Local variables
	1336	INTEGER :: i,i1,k
	1337	C
	1338	C
	1339	tabarray(:,:,1) = 0
	1340	C
	1341	do i = 1,nbdim
	1342	C
	1343	Call Agrif_Invloc(lboundl(i),rank,i,i1)
	1344
	1345	do k=tab1(i)+lboundl(i)-i1,tab2(i)+lboundl(i)-i1
	1346	tabarray(k-lboundl(i)+i1,i,1)=1
	1347	tabarray(k-lboundl(i)+i1,i,2)=k
	1348	enddo
	1349
	1350	C
	1351	enddo
	1352	C
	1353	Return
	1354	C
	1355	C
	1356	End Subroutine Agrif_GlobtoLocInd
	1357
	1358	C
	1359	C **************************************************************************
	1360	CCC Subroutine Agrif_GlobtoLocInd2
	1361	C **************************************************************************
	1362	C
	1363	Subroutine Agrif_GlobtoLocInd2(tabarray,lboundl,uboundl,tab1,tab2,
	1364	& nbdim,rank,member)
	1365	C
	1366	CCC Description:
	1367	CCC For a global index located on the current processor, tabarray gives the
	1368	CCC corresponding local index
	1369	C
	1370	C
	1371	C Declarations:
	1372	C
	1373
	1374	C
	1375	C Arguments
	1376	INTEGER :: nbdim
	1377	INTEGER,DIMENSION(nbdim) :: tab1,tab2
	1378	INTEGER,DIMENSION(nbdim,2,2 ) :: tabarray
	1379	INTEGER,DIMENSION(nbdim) :: lboundl,uboundl
	1380	INTEGER :: rank
	1381	LOGICAL :: member
	1382	C
	1383	C Local variables
	1384	INTEGER :: i,i1,k
	1385	INTEGER :: nbloc(nbdim)
	1386	C
	1387	C
	1388	tabarray(:,1,:) = HUGE(1)
	1389	tabarray(:,2,:) = -HUGE(1)
	1390
	1391	nbloc = 0
	1392	C
	1393	do i = 1,nbdim
	1394	C
	1395	Call Agrif_Invloc(lboundl(i),rank,i,i1)
	1396
	1397	do k=tab1(i)+lboundl(i)-i1,tab2(i)+lboundl(i)-i1
	1398	IF ((k .GE. lboundl(i)) .AND. (k.LE.uboundl(i))) THEN
	1399	nbloc(i) = 1
	1400	tabarray(i,1,1) = min(tabarray(i,1,1),k-lboundl(i)+i1)
	1401	tabarray(i,2,1) = max(tabarray(i,2,1),k-lboundl(i)+i1)
	1402
	1403	tabarray(i,1,2) = min(tabarray(i,1,2),k)
	1404	tabarray(i,2,2) = max(tabarray(i,2,2),k)
	1405	ENDIF
	1406	enddo
	1407	C
	1408	enddo
	1409
	1410	member = .FALSE.
	1411	IF (sum(nbloc) == nbdim) member = .TRUE.
	1412	C
	1413	Return
	1414	C
	1415	C
	1416	End Subroutine Agrif_GlobtoLocInd2
	1417	C
	1418	#endif
	1419
	1420	End Module Agrif_Arrays

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

Download in other formats: