Context Navigation

calfis_p.F @ 1323

Last change on this file since 1323 was 1279, checked in by Laurent Fairhead, 15 years ago
Merged LMDZ4-dev branch changes r1241:1278 into the trunk Running trunk and LMDZ4-dev in LMDZOR configuration on local machine (sequential) and SX8 (4-proc) yields identical results (restart and restartphy are identical binarily) Log history from r1241 to r1278 is available by switching to source:LMDZ4/branches/LMDZ4-dev-20091210
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 25.6 KB

Rev	Line
[630]	1	!
[1279]	2	! $Id: calfis_p.F 1279 2009-12-10 09:02:56Z fairhead $
[630]	3	!
	4	C
	5	C
[1146]	6	SUBROUTINE calfis_p(lafin,
[1279]	7	$ jD_cur, jH_cur,
[630]	8	$ pucov,
	9	$ pvcov,
	10	$ pteta,
	11	$ pq,
	12	$ pmasse,
	13	$ pps,
	14	$ pp,
	15	$ ppk,
	16	$ pphis,
	17	$ pphi,
	18	$ pducov,
	19	$ pdvcov,
	20	$ pdteta,
	21	$ pdq,
	22	$ flxw,
	23	$ clesphy0,
	24	$ pdufi,
	25	$ pdvfi,
	26	$ pdhfi,
	27	$ pdqfi,
	28	$ pdpsfi)
[1279]	29	#ifdef CPP_EARTH
	30	! Ehouarn: For now, calfis_p needs Earth physics
[630]	31	c
	32	c Auteur : P. Le Van, F. Hourdin
	33	c .........
	34	USE dimphy
[774]	35	USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root
[1000]	36	USE parallel, ONLY : omp_chunk, using_mpi
[774]	37	USE mod_interface_dyn_phys
[630]	38	USE Write_Field
	39	Use Write_field_p
	40	USE Times
[764]	41	USE IOPHY
[1146]	42	USE infotrac
	43
[630]	44	IMPLICIT NONE
	45	c=======================================================================
	46	c
	47	c 1. rearrangement des tableaux et transformation
	48	c variables dynamiques > variables physiques
	49	c 2. calcul des termes physiques
	50	c 3. retransformation des tendances physiques en tendances dynamiques
	51	c
	52	c remarques:
	53	c ----------
	54	c
	55	c - les vents sont donnes dans la physique par leurs composantes
	56	c naturelles.
	57	c - la variable thermodynamique de la physique est une variable
	58	c intensive : T
	59	c pour la dynamique on prend T * ( preff / p(l) ) **kappa
	60	c - les deux seules variables dependant de la geometrie necessaires
	61	c pour la physique sont la latitude pour le rayonnement et
	62	c l'aire de la maille quand on veut integrer une grandeur
	63	c horizontalement.
	64	c - les points de la physique sont les points scalaires de la
	65	c la dynamique; numerotation:
	66	c 1 pour le pole nord
	67	c (jjm-1)*iim pour l'interieur du domaine
	68	c ngridmx pour le pole sud
	69	c ---> ngridmx=2+(jjm-1)*iim
	70	c
	71	c Input :
	72	c -------
	73	c ecritphy frequence d'ecriture (en jours)de histphy
	74	c pucov covariant zonal velocity
	75	c pvcov covariant meridional velocity
	76	c pteta potential temperature
	77	c pps surface pressure
	78	c pmasse masse d'air dans chaque maille
	79	c pts surface temperature (K)
	80	c callrad clef d'appel au rayonnement
	81	c
	82	c Output :
	83	c --------
	84	c pdufi tendency for the natural zonal velocity (ms-1)
	85	c pdvfi tendency for the natural meridional velocity
	86	c pdhfi tendency for the potential temperature
	87	c pdtsfi tendency for the surface temperature
	88	c
	89	c pdtrad radiative tendencies \ both input
	90	c pfluxrad radiative fluxes / and output
	91	c
	92	c=======================================================================
	93	c
	94	c-----------------------------------------------------------------------
	95	c
	96	c 0. Declarations :
	97	c ------------------
	98
	99	#include "dimensions.h"
	100	#include "paramet.h"
	101	#include "temps.h"
	102
[1146]	103	INTEGER ngridmx
[630]	104	PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm )
	105
	106	#include "comconst.h"
	107	#include "comvert.h"
	108	#include "comgeom2.h"
	109	#include "control.h"
[1000]	110	#ifdef CPP_MPI
[630]	111	include 'mpif.h'
[1000]	112	#endif
[630]	113	c Arguments :
	114	c -----------
	115	LOGICAL lafin
	116	REAL heure
	117
	118	REAL pvcov(iip1,jjm,llm)
	119	REAL pucov(iip1,jjp1,llm)
	120	REAL pteta(iip1,jjp1,llm)
	121	REAL pmasse(iip1,jjp1,llm)
[1146]	122	REAL pq(iip1,jjp1,llm,nqtot)
[630]	123	REAL pphis(iip1,jjp1)
	124	REAL pphi(iip1,jjp1,llm)
	125	c
	126	REAL pdvcov(iip1,jjm,llm)
	127	REAL pducov(iip1,jjp1,llm)
	128	REAL pdteta(iip1,jjp1,llm)
[1146]	129	REAL pdq(iip1,jjp1,llm,nqtot)
[630]	130	c
	131	REAL pps(iip1,jjp1)
	132	REAL pp(iip1,jjp1,llmp1)
	133	REAL ppk(iip1,jjp1,llm)
	134	c
	135	REAL pdvfi(iip1,jjm,llm)
	136	REAL pdufi(iip1,jjp1,llm)
	137	REAL pdhfi(iip1,jjp1,llm)
[1146]	138	REAL pdqfi(iip1,jjp1,llm,nqtot)
[630]	139	REAL pdpsfi(iip1,jjp1)
	140
	141	INTEGER longcles
	142	PARAMETER ( longcles = 20 )
	143	REAL clesphy0( longcles )
	144
	145
	146	c Local variables :
	147	c -----------------
	148
	149	INTEGER i,j,l,ig0,ig,iq,iiq
[764]	150	REAL,ALLOCATABLE,SAVE :: zpsrf(:)
	151	REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:)
	152	REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:)
[630]	153	c
[764]	154	REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:)
	155	REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:)
[630]	156	c
[764]	157	REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:)
	158	REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:)
[630]	159	c
[764]	160	REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:)
	161	REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:)
	162	REAL,ALLOCATABLE,SAVE :: zdpsrf(:)
[985]	163	REAL,SAVE,ALLOCATABLE :: flxwfi(:,:) ! Flux de masse verticale sur la grille physiq
	164
[630]	165	c
[764]	166	REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:)
	167	REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:)
	168	REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:)
	169	REAL,ALLOCATABLE,SAVE :: zphis_omp(:)
	170	REAL,ALLOCATABLE,SAVE :: presnivs_omp(:)
	171	REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:)
	172	REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:)
	173	REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:)
	174	REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:)
	175	REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:)
	176	REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:)
	177	REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:)
	178	REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:)
	179	REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:)
[985]	180	REAL,SAVE,ALLOCATABLE :: flxwfi_omp(:,:) ! Flux de masse verticale sur la grille physiq
[764]	181
	182	c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp,
	183	c$OMP+ presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp,
[985]	184	c$OMP+ zqfi_omp,zdufi_omp,zdvfi_omp,
	185	c$OMP+ zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp)
[764]	186
	187	LOGICAL,SAVE :: first_omp=.true.
	188	c$OMP THREADPRIVATE(first_omp)
	189
[630]	190	REAL zsin(iim),zcos(iim),z1(iim)
	191	REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
	192	REAL unskap, pksurcp
[764]	193	c
	194	cIM diagnostique PVteta, Amip2
	195	INTEGER ntetaSTD
	196	PARAMETER(ntetaSTD=3)
	197	REAL rtetaSTD(ntetaSTD)
	198	DATA rtetaSTD/350., 380., 405./
	199	REAL PVteta(klon,ntetaSTD)
	200
[960]	201	REAL flxw(iip1,jjp1,llm) ! Flux de masse verticale sur la grille dynamique
[630]	202
	203	REAL SSUM
	204
	205	LOGICAL firstcal, debut
	206	DATA firstcal/.true./
	207	SAVE firstcal,debut
[764]	208	c$OMP THREADPRIVATE(firstcal,debut)
[1279]	209	REAL, intent(in):: jD_cur, jH_cur
[630]	210
[764]	211	REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv
[630]	212	INTEGER :: ierr
[1000]	213	#ifdef CPP_MPI
[630]	214	INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status
[1000]	215	#else
	216	INTEGER,dimension(1,4) :: Status
	217	#endif
[630]	218	INTEGER, dimension(4) :: Req
[764]	219	REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:)
	220	integer :: k,kstart,kend
	221	INTEGER :: offset
[630]	222	c
	223	c-----------------------------------------------------------------------
	224	c
	225	c 1. Initialisations :
	226	c --------------------
	227	c
	228
[764]	229	klon=klon_mpi
	230
	231	PVteta(:,:)=0.
	232
[1279]	233	c
	234	IF ( firstcal ) THEN
	235	debut = .TRUE.
	236	IF (ngridmx.NE.2+(jjm-1)*iim) THEN
[630]	237	PRINT*,'STOP dans calfis'
	238	PRINT,'La dimension ngridmx doit etre egale a 2 + (jjm-1)iim'
	239	PRINT*,' ngridmx jjm iim '
	240	PRINT*,ngridmx,jjm,iim
	241	STOP
[1279]	242	ENDIF
[764]	243	c$OMP MASTER
	244	ALLOCATE(zpsrf(klon))
	245	ALLOCATE(zplev(klon,llm+1),zplay(klon,llm))
	246	ALLOCATE(zphi(klon,llm),zphis(klon))
	247	ALLOCATE(zufi(klon,llm), zvfi(klon,llm))
[1146]	248	ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot))
[764]	249	ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm))
	250	ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2))
	251	ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm))
[1146]	252	ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot))
[764]	253	ALLOCATE(zdpsrf(klon))
	254	ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm))
[985]	255	ALLOCATE(flxwfi(klon,llm))
[764]	256	c$OMP END MASTER
	257	c$OMP BARRIER
[630]	258	ELSE
	259	debut = .FALSE.
	260	ENDIF
	261
	262	c
	263	c
	264	c-----------------------------------------------------------------------
	265	c 40. transformation des variables dynamiques en variables physiques:
	266	c ---------------------------------------------------------------
	267
	268	c 41. pressions au sol (en Pascals)
	269	c ----------------------------------
	270
[764]	271	c$OMP MASTER
[630]	272	call start_timer(timer_physic)
[764]	273	c$OMP END MASTER
	274
	275	c$OMP MASTER
[1279]	276	!CDIR ON_ADB(index_i)
	277	!CDIR ON_ADB(index_j)
[630]	278	do ig0=1,klon
[774]	279	i=index_i(ig0)
	280	j=index_j(ig0)
[630]	281	zpsrf(ig0)=pps(i,j)
	282	enddo
[764]	283	c$OMP END MASTER
[630]	284
	285
	286	c 42. pression intercouches :
	287	c
	288	c -----------------------------------------------------------------
	289	c .... zplev definis aux (llm +1) interfaces des couches ....
	290	c .... zplay definis aux ( llm ) milieux des couches ....
	291	c -----------------------------------------------------------------
	292
	293	c ... Exner = cp * ( p(l) / preff ) ** kappa ....
	294	c
	295	unskap = 1./ kappa
	296	c
[961]	297	c print *,omp_rank,'klon--->',klon
[764]	298	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	299	DO l = 1, llmp1
[1279]	300	!CDIR ON_ADB(index_i)
	301	!CDIR ON_ADB(index_j)
[630]	302	do ig0=1,klon
[774]	303	i=index_i(ig0)
	304	j=index_j(ig0)
[630]	305	zplev( ig0,l ) = pp(i,j,l)
	306	enddo
	307	ENDDO
[764]	308	c$OMP END DO NOWAIT
[630]	309	c
	310	c
	311
	312	c 43. temperature naturelle (en K) et pressions milieux couches .
	313	c ---------------------------------------------------------------
[764]	314	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	315	DO l=1,llm
[1279]	316	!CDIR ON_ADB(index_i)
	317	!CDIR ON_ADB(index_j)
[630]	318	do ig0=1,klon
[774]	319	i=index_i(ig0)
	320	j=index_j(ig0)
[630]	321	pksurcp = ppk(i,j,l) / cpp
	322	zplay(ig0,l) = preff * pksurcp ** unskap
	323	ztfi(ig0,l) = pteta(i,j,l) * pksurcp
	324	enddo
	325
	326	ENDDO
[764]	327	c$OMP END DO NOWAIT
[630]	328
	329	c 43.bis traceurs
	330	c ---------------
	331	c
	332
[1146]	333	DO iq=1,nqtot
[630]	334	iiq=niadv(iq)
[764]	335	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	336	DO l=1,llm
[1279]	337	!CDIR ON_ADB(index_i)
	338	!CDIR ON_ADB(index_j)
[630]	339	do ig0=1,klon
[774]	340	i=index_i(ig0)
	341	j=index_j(ig0)
[630]	342	zqfi(ig0,l,iq) = pq(i,j,l,iiq)
	343	enddo
	344	ENDDO
[764]	345	c$OMP END DO NOWAIT
[630]	346	ENDDO
	347
	348
	349	c Geopotentiel calcule par rapport a la surface locale:
	350	c -----------------------------------------------------
	351
	352	CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi)
[764]	353
[630]	354	CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis)
[1146]	355
[764]	356	c$OMP BARRIER
[630]	357
[764]	358	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	359	DO l=1,llm
	360	DO ig=1,klon
	361	zphi(ig,l)=zphi(ig,l)-zphis(ig)
	362	ENDDO
	363	ENDDO
[960]	364	c$OMP END DO NOWAIT
	365
[630]	366
	367	c
	368	c 45. champ u:
	369	c ------------
	370
	371	kstart=1
	372	kend=klon
	373
[774]	374	if (is_north_pole) kstart=2
	375	if (is_south_pole) kend=klon-1
[630]	376
[764]	377	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	378	DO l=1,llm
[1279]	379	!CDIR ON_ADB(index_i)
	380	!CDIR ON_ADB(index_j)
	381	!CDIR SPARSE
[630]	382	do ig0=kstart,kend
[774]	383	i=index_i(ig0)
	384	j=index_j(ig0)
[630]	385	if (i==1) then
	386	zufi(ig0,l)= 0.5 *( pucov(iim,j,l)/cu(iim,j)
	387	$ + pucov(1,j,l)/cu(1,j) )
	388	else
	389	zufi(ig0,l)= 0.5*( pucov(i-1,j,l)/cu(i-1,j)
	390	$ + pucov(i,j,l)/cu(i,j) )
	391	endif
	392	enddo
	393	ENDDO
[764]	394	c$OMP END DO NOWAIT
[1279]	395
[630]	396	c 46.champ v:
	397	c -----------
[1279]	398
[764]	399	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	400	DO l=1,llm
[1279]	401	!CDIR ON_ADB(index_i)
	402	!CDIR ON_ADB(index_j)
[630]	403	DO ig0=kstart,kend
[774]	404	i=index_i(ig0)
	405	j=index_j(ig0)
[630]	406	zvfi(ig0,l)= 0.5 *( pvcov(i,j-1,l)/cv(i,j-1)
	407	$ + pvcov(i,j,l)/cv(i,j) )
	408
	409	ENDDO
	410	ENDDO
[764]	411	c$OMP END DO NOWAIT
[630]	412
	413	c 47. champs de vents aux pole nord
	414	c ------------------------------
	415	c U = 1 / pi * integrale [ v * cos(long) * d long ]
	416	c V = 1 / pi * integrale [ v * sin(long) * d long ]
	417
[774]	418	if (is_north_pole) then
[764]	419	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	420	DO l=1,llm
	421
	422	z1(1) =(rlonu(1)-rlonu(iim)+2.pi)pvcov(1,1,l)/cv(1,1)
	423	DO i=2,iim
	424	z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
	425	ENDDO
	426
	427	DO i=1,iim
	428	zcos(i) = COS(rlonv(i))*z1(i)
	429	zsin(i) = SIN(rlonv(i))*z1(i)
	430	ENDDO
	431
	432	zufi(1,l) = SSUM(iim,zcos,1)/pi
	433	zvfi(1,l) = SSUM(iim,zsin,1)/pi
	434
	435	ENDDO
[764]	436	c$OMP END DO NOWAIT
[630]	437	endif
	438
	439
	440	c 48. champs de vents aux pole sud:
	441	c ---------------------------------
	442	c U = 1 / pi * integrale [ v * cos(long) * d long ]
	443	c V = 1 / pi * integrale [ v * sin(long) * d long ]
	444
[774]	445	if (is_south_pole) then
[764]	446	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	447	DO l=1,llm
	448
	449	z1(1) =(rlonu(1)-rlonu(iim)+2.pi)pvcov(1,jjm,l)/cv(1,jjm)
	450	DO i=2,iim
[1279]	451	z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
[630]	452	ENDDO
	453
	454	DO i=1,iim
	455	zcos(i) = COS(rlonv(i))*z1(i)
	456	zsin(i) = SIN(rlonv(i))*z1(i)
	457	ENDDO
	458
	459	zufi(klon,l) = SSUM(iim,zcos,1)/pi
	460	zvfi(klon,l) = SSUM(iim,zsin,1)/pi
	461	ENDDO
[764]	462	c$OMP END DO NOWAIT
[630]	463	endif
	464
	465
[774]	466	IF (is_sequential) THEN
[764]	467	c
	468	cIM calcul PV a teta=350, 380, 405K
	469	CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta,
	470	$ ztfi,zplay,zplev,
	471	$ ntetaSTD,rtetaSTD,PVteta)
	472	c
	473	ENDIF
[960]	474
	475	c On change de grille, dynamique vers physiq, pour le flux de masse verticale
[630]	476	CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi)
	477
	478	c-----------------------------------------------------------------------
	479	c Appel de la physique:
	480	c ---------------------
	481
	482
[764]	483	c$OMP BARRIER
	484	if (first_omp) then
[774]	485	klon=klon_omp
[764]	486
	487	allocate(zplev_omp(klon,llm+1))
	488	allocate(zplay_omp(klon,llm))
	489	allocate(zphi_omp(klon,llm))
	490	allocate(zphis_omp(klon))
	491	allocate(presnivs_omp(llm))
	492	allocate(zufi_omp(klon,llm))
	493	allocate(zvfi_omp(klon,llm))
	494	allocate(ztfi_omp(klon,llm))
[1146]	495	allocate(zqfi_omp(klon,llm,nqtot))
[764]	496	allocate(zdufi_omp(klon,llm))
	497	allocate(zdvfi_omp(klon,llm))
	498	allocate(zdtfi_omp(klon,llm))
[1146]	499	allocate(zdqfi_omp(klon,llm,nqtot))
[764]	500	allocate(zdpsrf_omp(klon))
[985]	501	allocate(flxwfi_omp(klon,llm))
[764]	502	first_omp=.false.
	503	endif
	504
	505
[774]	506	klon=klon_omp
	507	offset=klon_omp_begin-1
[764]	508
	509	do l=1,llm+1
	510	do i=1,klon
	511	zplev_omp(i,l)=zplev(offset+i,l)
	512	enddo
	513	enddo
	514
	515	do l=1,llm
	516	do i=1,klon
	517	zplay_omp(i,l)=zplay(offset+i,l)
	518	enddo
	519	enddo
	520
	521	do l=1,llm
	522	do i=1,klon
	523	zphi_omp(i,l)=zphi(offset+i,l)
	524	enddo
	525	enddo
	526
	527	do i=1,klon
	528	zphis_omp(i)=zphis(offset+i)
	529	enddo
	530
	531
	532	do l=1,llm
	533	presnivs_omp(l)=presnivs(l)
	534	enddo
	535
	536	do l=1,llm
	537	do i=1,klon
	538	zufi_omp(i,l)=zufi(offset+i,l)
	539	enddo
	540	enddo
	541
	542	do l=1,llm
	543	do i=1,klon
	544	zvfi_omp(i,l)=zvfi(offset+i,l)
	545	enddo
	546	enddo
	547
	548	do l=1,llm
	549	do i=1,klon
	550	ztfi_omp(i,l)=ztfi(offset+i,l)
	551	enddo
	552	enddo
	553
[1146]	554	do iq=1,nqtot
[764]	555	do l=1,llm
	556	do i=1,klon
	557	zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq)
	558	enddo
	559	enddo
	560	enddo
	561
	562	do l=1,llm
	563	do i=1,klon
	564	zdufi_omp(i,l)=zdufi(offset+i,l)
	565	enddo
	566	enddo
	567
	568	do l=1,llm
	569	do i=1,klon
	570	zdvfi_omp(i,l)=zdvfi(offset+i,l)
	571	enddo
	572	enddo
	573
	574	do l=1,llm
	575	do i=1,klon
	576	zdtfi_omp(i,l)=zdtfi(offset+i,l)
	577	enddo
	578	enddo
	579
[1146]	580	do iq=1,nqtot
[764]	581	do l=1,llm
	582	do i=1,klon
	583	zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq)
	584	enddo
	585	enddo
	586	enddo
	587
	588	do i=1,klon
	589	zdpsrf_omp(i)=zdpsrf(offset+i)
	590	enddo
[985]	591
	592	do l=1,llm
	593	do i=1,klon
	594	flxwfi_omp(i,l)=flxwfi(offset+i,l)
	595	enddo
	596	enddo
[764]	597
	598	c$OMP BARRIER
	599
[1279]	600	if (planet_type=="earth") then
	601	#ifdef CPP_EARTH
[630]	602	CALL physiq (klon,
	603	. llm,
	604	. debut,
	605	. lafin,
[1279]	606	. jD_cur,
	607	. jH_cur,
[630]	608	. dtphys,
[764]	609	. zplev_omp,
	610	. zplay_omp,
	611	. zphi_omp,
	612	. zphis_omp,
	613	. presnivs_omp,
[630]	614	. clesphy0,
[764]	615	. zufi_omp,
	616	. zvfi_omp,
	617	. ztfi_omp,
	618	. zqfi_omp,
[960]	619	c#ifdef INCA
[985]	620	. flxwfi_omp,
[960]	621	c#endif
[764]	622	. zdufi_omp,
	623	. zdvfi_omp,
	624	. zdtfi_omp,
	625	. zdqfi_omp,
	626	. zdpsrf_omp,
	627	cIM diagnostique PVteta, Amip2
	628	. pducov,
	629	. PVteta)
[1279]	630	#endif
	631	endif !of if (planet_type=="earth")
[764]	632	c$OMP BARRIER
	633
	634	do l=1,llm+1
	635	do i=1,klon
	636	zplev(offset+i,l)=zplev_omp(i,l)
	637	enddo
	638	enddo
	639
	640	do l=1,llm
	641	do i=1,klon
	642	zplay(offset+i,l)=zplay_omp(i,l)
	643	enddo
	644	enddo
	645
	646	do l=1,llm
	647	do i=1,klon
	648	zphi(offset+i,l)=zphi_omp(i,l)
	649	enddo
	650	enddo
	651
	652
	653	do i=1,klon
	654	zphis(offset+i)=zphis_omp(i)
	655	enddo
	656
	657
	658	do l=1,llm
	659	presnivs(l)=presnivs_omp(l)
	660	enddo
	661
	662	do l=1,llm
	663	do i=1,klon
	664	zufi(offset+i,l)=zufi_omp(i,l)
	665	enddo
	666	enddo
	667
	668	do l=1,llm
	669	do i=1,klon
	670	zvfi(offset+i,l)=zvfi_omp(i,l)
	671	enddo
	672	enddo
	673
	674	do l=1,llm
	675	do i=1,klon
	676	ztfi(offset+i,l)=ztfi_omp(i,l)
	677	enddo
	678	enddo
	679
[1146]	680	do iq=1,nqtot
[764]	681	do l=1,llm
	682	do i=1,klon
	683	zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq)
	684	enddo
	685	enddo
	686	enddo
	687
	688	do l=1,llm
	689	do i=1,klon
	690	zdufi(offset+i,l)=zdufi_omp(i,l)
	691	enddo
	692	enddo
	693
	694	do l=1,llm
	695	do i=1,klon
	696	zdvfi(offset+i,l)=zdvfi_omp(i,l)
	697	enddo
	698	enddo
	699
	700	do l=1,llm
	701	do i=1,klon
	702	zdtfi(offset+i,l)=zdtfi_omp(i,l)
	703	enddo
	704	enddo
	705
[1146]	706	do iq=1,nqtot
[764]	707	do l=1,llm
	708	do i=1,klon
	709	zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq)
	710	enddo
	711	enddo
	712	enddo
	713
	714	do i=1,klon
	715	zdpsrf(offset+i)=zdpsrf_omp(i)
	716	enddo
	717
	718
	719	klon=klon_mpi
[630]	720	500 CONTINUE
[764]	721	c$OMP BARRIER
[630]	722
[764]	723	c$OMP MASTER
[630]	724	call stop_timer(timer_physic)
[764]	725	c$OMP END MASTER
[1000]	726
	727	IF (using_mpi) THEN
	728
[630]	729	if (MPI_rank>0) then
[764]	730
	731	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	732	DO l=1,llm
	733	du_send(1:iim,l)=zdufi(1:iim,l)
	734	dv_send(1:iim,l)=zdvfi(1:iim,l)
	735	ENDDO
	736	c$OMP END DO NOWAIT
	737
	738	c$OMP BARRIER
[1000]	739	#ifdef CPP_MPI
[764]	740	c$OMP MASTER
[985]	741	!$OMP CRITICAL (MPI)
[630]	742	call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401,
[764]	743	& COMM_LMDZ,Req(1),ierr)
[630]	744	call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402,
[764]	745	& COMM_LMDZ,Req(2),ierr)
[985]	746	!$OMP END CRITICAL (MPI)
[764]	747	c$OMP END MASTER
[1000]	748	#endif
[764]	749	c$OMP BARRIER
[630]	750
	751	endif
	752
	753	if (MPI_rank<MPI_Size-1) then
[764]	754	c$OMP BARRIER
[1000]	755	#ifdef CPP_MPI
[764]	756	c$OMP MASTER
[985]	757	!$OMP CRITICAL (MPI)
[630]	758	call MPI_IRECV(du_recv,iim*llm,MPI_REAL8,MPI_Rank+1,401,
[764]	759	& COMM_LMDZ,Req(3),ierr)
[630]	760	call MPI_IRECV(dv_recv,iim*llm,MPI_REAL8,MPI_Rank+1,402,
[764]	761	& COMM_LMDZ,Req(4),ierr)
[985]	762	!$OMP END CRITICAL (MPI)
[764]	763	c$OMP END MASTER
[1000]	764	#endif
[630]	765	endif
[764]	766
	767	c$OMP BARRIER
[1000]	768
	769
	770	#ifdef CPP_MPI
[764]	771	c$OMP MASTER
[985]	772	!$OMP CRITICAL (MPI)
[630]	773	if (MPI_rank>0 .and. MPI_rank< MPI_Size-1) then
	774	call MPI_WAITALL(4,Req(1),Status,ierr)
	775	else if (MPI_rank>0) then
	776	call MPI_WAITALL(2,Req(1),Status,ierr)
	777	else if (MPI_rank <MPI_Size-1) then
	778	call MPI_WAITALL(2,Req(3),Status,ierr)
	779	endif
[985]	780	!$OMP END CRITICAL (MPI)
[764]	781	c$OMP END MASTER
[1000]	782	#endif
	783
[764]	784	c$OMP BARRIER
	785
[1000]	786	ENDIF ! using_mpi
	787
	788
[764]	789	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	790	DO l=1,llm
	791
	792	zdufi2(1:klon,l)=zdufi(1:klon,l)
	793	zdufi2(klon+1:klon+iim,l)=du_recv(1:iim,l)
	794
	795	zdvfi2(1:klon,l)=zdvfi(1:klon,l)
	796	zdvfi2(klon+1:klon+iim,l)=dv_recv(1:iim,l)
	797
[774]	798	pdhfi(:,jj_begin,l)=0
	799	pdqfi(:,jj_begin,l,:)=0
	800	pdufi(:,jj_begin,l)=0
	801	pdvfi(:,jj_begin,l)=0
[764]	802
[774]	803	if (.not. is_south_pole) then
	804	pdhfi(:,jj_end,l)=0
	805	pdqfi(:,jj_end,l,:)=0
	806	pdufi(:,jj_end,l)=0
	807	pdvfi(:,jj_end,l)=0
[764]	808	endif
[630]	809
[764]	810	ENDDO
	811	c$OMP END DO NOWAIT
[630]	812
[764]	813	c$OMP MASTER
[774]	814	pdpsfi(:,jj_begin)=0
	815	if (.not. is_south_pole) then
	816	pdpsfi(:,jj_end)=0
[630]	817	endif
[764]	818	c$OMP END MASTER
[630]	819	c-----------------------------------------------------------------------
	820	c transformation des tendances physiques en tendances dynamiques:
	821	c ---------------------------------------------------------------
	822
	823	c tendance sur la pression :
	824	c -----------------------------------
	825	CALL gr_fi_dyn_p(1,klon,iip1,jjp1,zdpsrf,pdpsfi)
	826	c
	827	c 62. enthalpie potentielle
	828	c ---------------------
	829
	830	kstart=1
	831	kend=klon
	832
[774]	833	if (is_north_pole) kstart=2
	834	if (is_south_pole) kend=klon-1
[630]	835
[764]	836	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	837	DO l=1,llm
	838
[1279]	839	!CDIR ON_ADB(index_i)
	840	!CDIR ON_ADB(index_j)
	841	!cdir NODEP
[630]	842	do ig0=kstart,kend
[774]	843	i=index_i(ig0)
	844	j=index_j(ig0)
[630]	845	pdhfi(i,j,l) = cpp * zdtfi(ig0,l) / ppk(i,j,l)
	846	if (i==1) pdhfi(iip1,j,l) = cpp * zdtfi(ig0,l) / ppk(i,j,l)
	847	enddo
	848
[774]	849	if (is_north_pole) then
[630]	850	DO i=1,iip1
	851	pdhfi(i,1,l) = cpp * zdtfi(1,l) / ppk(i, 1 ,l)
	852	enddo
	853	endif
	854
[774]	855	if (is_south_pole) then
[630]	856	DO i=1,iip1
	857	pdhfi(i,jjp1,l) = cpp * zdtfi(klon,l)/ ppk(i,jjp1,l)
	858	ENDDO
	859	endif
	860	ENDDO
[764]	861	c$OMP END DO NOWAIT
[630]	862
	863	c 62. humidite specifique
	864	c ---------------------
[1279]	865	! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
	866	! DO iq=1,nqtot
	867	!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	868	! DO l=1,llm
	869	!!!cdir NODEP
	870	! do ig0=kstart,kend
	871	! i=index_i(ig0)
	872	! j=index_j(ig0)
	873	! pdqfi(i,j,l,iq) = zdqfi(ig0,l,iq)
	874	! if (i==1) pdqfi(iip1,j,l,iq) = zdqfi(ig0,l,iq)
	875	! enddo
	876	!
	877	! if (is_north_pole) then
	878	! do i=1,iip1
	879	! pdqfi(i,1,l,iq) = zdqfi(1,l,iq)
	880	! enddo
	881	! endif
	882	!
	883	! if (is_south_pole) then
	884	! do i=1,iip1
	885	! pdqfi(i,jjp1,l,iq) = zdqfi(klon,l,iq)
	886	! enddo
	887	! endif
	888	! ENDDO
	889	!c$OMP END DO NOWAIT
	890	! ENDDO
[630]	891
	892	c 63. traceurs
	893	c ------------
	894	C initialisation des tendances
[764]	895
	896	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	897	DO l=1,llm
	898	pdqfi(:,:,l,:)=0.
	899	ENDDO
	900	c$OMP END DO NOWAIT
	901
[630]	902	C
[1279]	903	!cdir NODEP
[1146]	904	DO iq=1,nqtot
[630]	905	iiq=niadv(iq)
[764]	906	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	907	DO l=1,llm
[1279]	908	!CDIR ON_ADB(index_i)
	909	!CDIR ON_ADB(index_j)
	910	!cdir NODEP
[630]	911	DO ig0=kstart,kend
[774]	912	i=index_i(ig0)
	913	j=index_j(ig0)
[630]	914	pdqfi(i,j,l,iiq) = zdqfi(ig0,l,iq)
	915	if (i==1) pdqfi(iip1,j,l,iiq) = zdqfi(ig0,l,iq)
	916	ENDDO
	917
[774]	918	IF (is_north_pole) then
[630]	919	DO i=1,iip1
	920	pdqfi(i,1,l,iiq) = zdqfi(1,l,iq)
	921	ENDDO
	922	ENDIF
	923
[774]	924	IF (is_south_pole) then
[630]	925	DO i=1,iip1
	926	pdqfi(i,jjp1,l,iiq) = zdqfi(klon,l,iq)
	927	ENDDO
	928	ENDIF
	929
	930	ENDDO
[764]	931	c$OMP END DO NOWAIT
[630]	932	ENDDO
	933
	934	c 65. champ u:
	935	c ------------
[764]	936	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	937	DO l=1,llm
[1279]	938	!CDIR ON_ADB(index_i)
	939	!CDIR ON_ADB(index_j)
	940	!cdir NODEP
[630]	941	do ig0=kstart,kend
[774]	942	i=index_i(ig0)
	943	j=index_j(ig0)
[630]	944
	945	if (i/=iim) then
	946	pdufi(i,j,l)=0.5(zdufi2(ig0,l)+zdufi2(ig0+1,l))cu(i,j)
	947	endif
	948
	949	if (i==1) then
	950	pdufi(iim,j,l)=0.5*( zdufi2(ig0,l)
	951	$ + zdufi2(ig0+iim-1,l))*cu(iim,j)
[764]	952	pdufi(iip1,j,l)=0.5(zdufi2(ig0,l)+zdufi2(ig0+1,l))cu(i,j)
[630]	953	endif
	954
	955	enddo
	956
[774]	957	if (is_north_pole) then
[630]	958	DO i=1,iip1
	959	pdufi(i,1,l) = 0.
	960	ENDDO
	961	endif
	962
[774]	963	if (is_south_pole) then
[630]	964	DO i=1,iip1
	965	pdufi(i,jjp1,l) = 0.
	966	ENDDO
	967	endif
	968
	969	ENDDO
[764]	970	c$OMP END DO NOWAIT
[630]	971
	972	c 67. champ v:
	973	c ------------
	974
	975	kstart=1
	976	kend=klon
	977
[774]	978	if (is_north_pole) kstart=2
	979	if (is_south_pole) kend=klon-1-iim
[630]	980
[764]	981	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	982	DO l=1,llm
[1279]	983	!CDIR ON_ADB(index_i)
	984	!CDIR ON_ADB(index_j)
	985	!cdir NODEP
[630]	986	do ig0=kstart,kend
[774]	987	i=index_i(ig0)
	988	j=index_j(ig0)
[630]	989	pdvfi(i,j,l)=0.5(zdvfi2(ig0,l)+zdvfi2(ig0+iim,l))cv(i,j)
	990	if (i==1) pdvfi(iip1,j,l) = 0.5*(zdvfi2(ig0,l)+
	991	$ zdvfi2(ig0+iim,l))
	992	$ *cv(i,j)
	993	enddo
	994
	995	ENDDO
[764]	996	c$OMP END DO NOWAIT
[630]	997
	998
	999	c 68. champ v pres des poles:
	1000	c ---------------------------
	1001	c v = U * cos(long) + V * SIN(long)
	1002
[774]	1003	if (is_north_pole) then
[764]	1004
	1005	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]	1006	DO l=1,llm
	1007
	1008	DO i=1,iim
	1009	pdvfi(i,1,l)=
	1010	$ zdufi(1,l)COS(rlonv(i))+zdvfi(1,l)SIN(rlonv(i))
	1011
	1012	pdvfi(i,1,l)=
	1013	$ 0.5(pdvfi(i,1,l)+zdvfi(i+1,l))cv(i,1)
	1014	ENDDO
	1015
	1016	pdvfi(iip1,1,l) = pdvfi(1,1,l)
	1017
	1018	ENDDO
[764]	1019	c$OMP END DO NOWAIT
[630]	1020
	1021	endif
	1022
[774]	1023	if (is_south_pole) then
[764]	1024
	1025	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1026	DO l=1,llm
[630]	1027
	1028	DO i=1,iim
	1029	pdvfi(i,jjm,l)=zdufi(klon,l)*COS(rlonv(i))
	1030	$ +zdvfi(klon,l)*SIN(rlonv(i))
	1031
	1032	pdvfi(i,jjm,l)=
	1033	$ 0.5(pdvfi(i,jjm,l)+zdvfi(klon-iip1+i,l))cv(i,jjm)
	1034	ENDDO
	1035
	1036	pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
	1037
	1038	ENDDO
[764]	1039	c$OMP END DO NOWAIT
[630]	1040
	1041	endif
	1042	c-----------------------------------------------------------------------
	1043
	1044	700 CONTINUE
	1045
	1046	firstcal = .FALSE.
	1047
[1279]	1048	#else
	1049	write(,) "calfis_p: for now can only work with parallel physics"
	1050	stop
	1051	#endif
	1052	! of #ifdef CPP_EARTH
[630]	1053	RETURN
	1054	END

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

Download in other formats:

Original Format