Context Navigation

leapfrog_p.F @ 16

Last change on this file since 16 was 8, checked in by emillour, 15 years ago

Debut de mise a jour de la dynamique parallele par rapport aux modifs dans la partie sequentielle.

Mais NON TESTE , car pas (encore) possibilite de compiler et faire tourner cas simple (type newtonien sans physique).

Voir commit_v8.log pour les details.

Ehouarn

File size: 57.5 KB

Rev	Line
[1]	1	!
[7]	2	! $Id: leapfrog_p.F 1446 2010-10-22 09:27:25Z emillour $
[1]	3	!
	4	c
	5	c
	6
	7	SUBROUTINE leapfrog_p(ucov,vcov,teta,ps,masse,phis,q,clesphy0,
	8	& time_0)
	9
	10	USE misc_mod
	11	USE parallel
	12	USE times
	13	USE mod_hallo
	14	USE Bands
	15	USE Write_Field
	16	USE Write_Field_p
	17	USE vampir
	18	USE timer_filtre, ONLY : print_filtre_timer
	19	USE infotrac
	20	USE guide_p_mod, ONLY : guide_main
	21	USE getparam
	22	USE control_mod
	23
	24	IMPLICIT NONE
	25
	26	c ...... Version du 10/01/98 ..........
	27
	28	c avec coordonnees verticales hybrides
	29	c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
	30
	31	c=======================================================================
	32	c
	33	c Auteur: P. Le Van /L. Fairhead/F.Hourdin
	34	c -------
	35	c
	36	c Objet:
	37	c ------
	38	c
	39	c GCM LMD nouvelle grille
	40	c
	41	c=======================================================================
	42	c
	43	c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv
	44	c et possibilite d'appeler une fonction f(y) a derivee tangente
	45	c hyperbolique a la place de la fonction a derivee sinusoidale.
	46
	47	c ... Possibilite de choisir le shema pour l'advection de
	48	c q , en modifiant iadv dans traceur.def (10/02) .
	49	c
	50	c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
	51	c Pour Van-Leer iadv=10
	52	c
	53	c-----------------------------------------------------------------------
	54	c Declarations:
	55	c -------------
	56
	57	#include "dimensions.h"
	58	#include "paramet.h"
	59	#include "comconst.h"
	60	#include "comdissnew.h"
	61	#include "comvert.h"
	62	#include "comgeom.h"
	63	#include "logic.h"
	64	#include "temps.h"
	65	#include "ener.h"
	66	#include "description.h"
	67	#include "serre.h"
	68	!#include "com_io_dyn.h"
	69	#include "iniprint.h"
	70	#include "academic.h"
	71
	72	INTEGER longcles
	73	PARAMETER ( longcles = 20 )
	74	REAL clesphy0( longcles )
	75
	76	real zqmin,zqmax
	77	INTEGER nbetatmoy, nbetatdem,nbetat
	78
	79	c variables dynamiques
	80	REAL :: vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
	81	REAL :: teta(ip1jmp1,llm) ! temperature potentielle
	82	REAL :: q(ip1jmp1,llm,nqtot) ! champs advectes
	83	REAL :: ps(ip1jmp1) ! pression au sol
	84	REAL,SAVE :: p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches
	85	REAL,SAVE :: pks(ip1jmp1) ! exner au sol
	86	REAL,SAVE :: pk(ip1jmp1,llm) ! exner au milieu des couches
	87	REAL,SAVE :: pkf(ip1jmp1,llm) ! exner filt.au milieu des couches
	88	REAL :: masse(ip1jmp1,llm) ! masse d'air
	89	REAL :: phis(ip1jmp1) ! geopotentiel au sol
	90	REAL,SAVE :: phi(ip1jmp1,llm) ! geopotentiel
	91	REAL,SAVE :: w(ip1jmp1,llm) ! vitesse verticale
[8]	92	! ADAPTATION GCM POUR CP(T)
	93	REAL,SAVE :: temp(ip1jmp1,llm) ! temperature
	94	REAL,SAVE :: tsurpk(ip1jmp1,llm) ! cpp*T/pk
[1]	95
	96	c variables dynamiques intermediaire pour le transport
	97	REAL,SAVE :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse
	98
	99	c variables dynamiques au pas -1
	100	REAL,SAVE :: vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
	101	REAL,SAVE :: tetam1(ip1jmp1,llm),psm1(ip1jmp1)
	102	REAL,SAVE :: massem1(ip1jmp1,llm)
	103
	104	c tendances dynamiques
	105	REAL,SAVE :: dv(ip1jm,llm),du(ip1jmp1,llm)
	106	REAL,SAVE :: dteta(ip1jmp1,llm),dp(ip1jmp1)
	107	REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq
	108
	109	c tendances de la dissipation
	110	REAL,SAVE :: dvdis(ip1jm,llm),dudis(ip1jmp1,llm)
	111	REAL,SAVE :: dtetadis(ip1jmp1,llm)
	112
	113	c tendances physiques
	114	REAL,SAVE :: dvfi(ip1jm,llm),dufi(ip1jmp1,llm)
	115	REAL,SAVE :: dtetafi(ip1jmp1,llm)
	116	REAL,SAVE :: dpfi(ip1jmp1)
	117	REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi
	118
	119	c variables pour le fichier histoire
	120	REAL dtav ! intervalle de temps elementaire
	121
	122	REAL tppn(iim),tpps(iim),tpn,tps
	123	c
	124	INTEGER itau,itaufinp1,iav
	125	! INTEGER iday ! jour julien
	126	REAL time
	127
	128	REAL SSUM
	129	REAL time_0
	130	REAL,SAVE :: finvmaold(ip1jmp1,llm)
	131
	132	cym LOGICAL lafin
	133	LOGICAL :: lafin
	134	INTEGER ij,iq,l
	135	INTEGER ik
	136
	137	real time_step, t_wrt, t_ops
	138
	139	! jD_cur: jour julien courant
	140	! jH_cur: heure julienne courante
	141	REAL :: jD_cur, jH_cur
	142	INTEGER :: an, mois, jour
	143	REAL :: secondes
	144
	145	LOGICAL first,callinigrads
	146
	147	data callinigrads/.true./
	148	character*10 string10
	149
	150	REAL,SAVE :: alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
	151	REAL,SAVE :: flxw(ip1jmp1,llm) ! flux de masse verticale
	152
	153	c+jld variables test conservation energie
	154	REAL,SAVE :: ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
	155	C Tendance de la temp. potentiel d (theta)/ d t due a la
	156	C tansformation d'energie cinetique en energie thermique
	157	C cree par la dissipation
	158	REAL,SAVE :: dtetaecdt(ip1jmp1,llm)
	159	REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm)
	160	REAL,SAVE :: vnat(ip1jm,llm),unat(ip1jmp1,llm)
	161	REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec
	162	CHARACTER*15 ztit
	163	! INTEGER ip_ebil_dyn ! PRINT level for energy conserv. diag.
	164	! SAVE ip_ebil_dyn
	165	! DATA ip_ebil_dyn/0/
	166	c-jld
	167
	168	character*80 dynhist_file, dynhistave_file
	169	character*20 modname
	170	character*80 abort_message
	171
	172
	173	logical,PARAMETER :: dissip_conservative=.TRUE.
	174
	175	INTEGER testita
	176	PARAMETER (testita = 9)
	177
	178	logical , parameter :: flag_verif = .false.
	179
	180	c declaration liees au parallelisme
	181	INTEGER :: ierr
	182	LOGICAL :: FirstCaldyn
	183	LOGICAL :: FirstPhysic
	184	INTEGER :: ijb,ije,j,i
	185	type(Request) :: TestRequest
	186	type(Request) :: Request_Dissip
	187	type(Request) :: Request_physic
	188	REAL,SAVE :: dvfi_tmp(iip1,llm),dufi_tmp(iip1,llm)
	189	REAL,SAVE :: dtetafi_tmp(iip1,llm)
	190	REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi_tmp
	191	REAL,SAVE :: dpfi_tmp(iip1)
	192
	193	INTEGER :: true_itau
	194	LOGICAL :: verbose=.true.
	195	INTEGER :: iapptrac
	196	INTEGER :: AdjustCount
	197	! INTEGER :: var_time
	198	LOGICAL :: ok_start_timer=.FALSE.
	199	LOGICAL, SAVE :: firstcall=.TRUE.
	200
	201	c$OMP MASTER
	202	ItCount=0
	203	c$OMP END MASTER
	204	true_itau=0
	205	FirstCaldyn=.TRUE.
	206	FirstPhysic=.TRUE.
	207	iapptrac=0
	208	AdjustCount = 0
	209	lafin=.false.
	210
	211	itaufin = nday*day_step
	212	itaufinp1 = itaufin +1
	213	modname="leapfrog_p"
	214
	215	itau = 0
	216	! iday = day_ini+itau/day_step
	217	! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
	218	! IF(time.GT.1.) THEN
	219	! time = time-1.
	220	! iday = iday+1
	221	! ENDIF
	222
	223	c Allocate variables depending on dynamic variable nqtot
	224	c$OMP MASTER
	225	IF (firstcall) THEN
	226	firstcall=.FALSE.
	227	ALLOCATE(dq(ip1jmp1,llm,nqtot))
	228	ALLOCATE(dqfi(ip1jmp1,llm,nqtot))
	229	ALLOCATE(dqfi_tmp(iip1,llm,nqtot))
	230	END IF
	231	c$OMP END MASTER
	232	c$OMP BARRIER
	233
	234	c-----------------------------------------------------------------------
	235	c On initialise la pression et la fonction d'Exner :
	236	c --------------------------------------------------
	237
	238	c$OMP MASTER
[7]	239	dq(:,:,:)=0.
[1]	240	CALL pression ( ip1jmp1, ap, bp, ps, p )
	241	CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
	242	c$OMP END MASTER
	243	c-----------------------------------------------------------------------
	244	c Debut de l'integration temporelle:
	245	c ----------------------------------
	246	c et du parallelisme !!
	247
	248	1 CONTINUE
	249
	250	jD_cur = jD_ref + day_ini - day_ref + int (itau * dtvr / daysec)
	251	jH_cur = jH_ref + &
	252	& (itau * dtvr / daysec - int(itau * dtvr / daysec))
	253
	254
	255	#ifdef CPP_IOIPSL
	256	if (ok_guide) then
	257	!$OMP MASTER
	258	call guide_main(itau,ucov,vcov,teta,q,masse,ps)
	259	!$OMP END MASTER
	260	!$OMP BARRIER
	261	endif
	262	#endif
	263
	264	c
	265	c IF( MOD( itau, 10* day_step ).EQ.0 ) THEN
	266	c CALL test_period ( ucov,vcov,teta,q,p,phis )
	267	c PRINT *,' ---- Test_period apres continue OK ! -----', itau
	268	c ENDIF
	269	c
	270	cym CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
	271	cym CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
	272	cym CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
	273	cym CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
	274	cym CALL SCOPY( ip1jmp1, ps , 1, psm1 , 1 )
	275
	276	if (FirstCaldyn) then
	277	c$OMP MASTER
	278	ucovm1=ucov
	279	vcovm1=vcov
	280	tetam1= teta
	281	massem1= masse
	282	psm1= ps
	283
	284	finvmaold = masse
	285	CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
	286	c$OMP END MASTER
	287	c$OMP BARRIER
	288	else
	289	! Save fields obtained at previous time step as '...m1'
	290	ijb=ij_begin
	291	ije=ij_end
	292
	293	c$OMP MASTER
	294	psm1 (ijb:ije) = ps (ijb:ije)
	295	c$OMP END MASTER
	296
	297	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	298	DO l=1,llm
	299	ije=ij_end
	300	ucovm1 (ijb:ije,l) = ucov (ijb:ije,l)
	301	tetam1 (ijb:ije,l) = teta (ijb:ije,l)
	302	massem1 (ijb:ije,l) = masse (ijb:ije,l)
	303	finvmaold(ijb:ije,l)=masse(ijb:ije,l)
	304
	305	if (pole_sud) ije=ij_end-iip1
	306	vcovm1(ijb:ije,l) = vcov (ijb:ije,l)
	307
	308
	309	ENDDO
	310	c$OMP ENDDO
	311
	312
	313	CALL filtreg_p ( finvmaold ,jj_begin,jj_end,jjp1,
	314	. llm, -2,2, .TRUE., 1 )
	315
	316	endif ! of if (FirstCaldyn)
	317
	318	forward = .TRUE.
	319	leapf = .FALSE.
	320	dt = dtvr
	321
	322	c ... P.Le Van .26/04/94 ....
	323
	324	cym CALL SCOPY ( ijp1llm, masse, 1, finvmaold, 1 )
	325	cym CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
	326
	327	cym ne sert a rien
	328	cym call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
	329
	330	2 CONTINUE
	331
	332	c$OMP MASTER
	333	ItCount=ItCount+1
	334	if (MOD(ItCount,1)==1) then
	335	debug=.true.
	336	else
	337	debug=.false.
	338	endif
	339	c$OMP END MASTER
	340	c-----------------------------------------------------------------------
	341
	342	c date:
	343	c -----
	344
	345
	346	c gestion des appels de la physique et des dissipations:
	347	c ------------------------------------------------------
	348	c
	349	c ... P.Le Van ( 6/02/95 ) ....
	350
	351	apphys = .FALSE.
	352	statcl = .FALSE.
	353	conser = .FALSE.
	354	apdiss = .FALSE.
	355	c idissip=1
	356	IF( purmats ) THEN
	357	! Purely Matsuno time stepping
	358	IF( MOD(itau,iconser) .EQ.0.AND. forward ) conser = .TRUE.
	359	IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE.
	360	IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward
	361	s .and. iflag_phys.EQ.1 ) apphys = .TRUE.
	362	ELSE
	363	! Leapfrog/Matsuno time stepping
	364	IF( MOD(itau ,iconser) .EQ. 0 ) conser = .TRUE.
	365	IF( MOD(itau+1,idissip) .EQ. 0 ) apdiss = .TRUE.
	366	IF( MOD(itau+1,iphysiq).EQ.0.AND.iflag_phys.EQ.1) apphys=.TRUE.
	367	END IF
	368
	369	! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
	370	! supress dissipation step
	371	if (llm.eq.1) then
	372	apdiss=.false.
	373	endif
	374
	375	cym ---> Pour le moment
	376	cym apphys = .FALSE.
	377	statcl = .FALSE.
	378	conser = .FALSE. ! ie: no output of control variables to stdout in //
	379
	380	if (firstCaldyn) then
	381	c$OMP MASTER
	382	call SetDistrib(jj_Nb_Caldyn)
	383	c$OMP END MASTER
	384	c$OMP BARRIER
	385	firstCaldyn=.FALSE.
	386	cym call InitTime
	387	c$OMP MASTER
	388	call Init_timer
	389	c$OMP END MASTER
	390	endif
	391
	392	c$OMP MASTER
	393	IF (ok_start_timer) THEN
	394	CALL InitTime
	395	ok_start_timer=.FALSE.
	396	ENDIF
	397	c$OMP END MASTER
	398
	399	if (Adjust) then
	400	c$OMP MASTER
	401	AdjustCount=AdjustCount+1
	402	if (iapptrac==iapp_tracvl .and. (forward. OR . leapf)
	403	& .and. itau/iphysiq>2 .and. Adjustcount>30) then
	404	AdjustCount=0
	405	call allgather_timer_average
	406
	407	if (Verbose) then
	408
	409	print ,'********************************'
	410	print ,'*** TIMER CALDYN ****'
	411	do i=0,mpi_size-1
	412	print *,'proc',i,' : Nb Bandes :',jj_nb_caldyn(i),
	413	& ' : temps moyen :',
	414	& timer_average(jj_nb_caldyn(i),timer_caldyn,i),
	415	& '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i)
	416	enddo
	417
	418	print ,'********************************'
	419	print ,'*** TIMER VANLEER ****'
	420	do i=0,mpi_size-1
	421	print *,'proc',i,' : Nb Bandes :',jj_nb_vanleer(i),
	422	& ' : temps moyen :',
	423	& timer_average(jj_nb_vanleer(i),timer_vanleer,i),
	424	& '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i)
	425	enddo
	426
	427	print ,'********************************'
	428	print ,'*** TIMER DISSIP ****'
	429	do i=0,mpi_size-1
	430	print *,'proc',i,' : Nb Bandes :',jj_nb_dissip(i),
	431	& ' : temps moyen :',
	432	& timer_average(jj_nb_dissip(i),timer_dissip,i),
	433	& '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i)
	434	enddo
	435
	436	if (mpi_rank==0) call WriteBands
	437
	438	endif
	439
	440	call AdjustBands_caldyn
	441	if (mpi_rank==0) call WriteBands
	442
	443	call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
	444	& jj_Nb_caldyn,0,0,TestRequest)
	445	call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm,
	446	& jj_Nb_caldyn,0,0,TestRequest)
	447	call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
	448	& jj_Nb_caldyn,0,0,TestRequest)
	449	call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm,
	450	& jj_Nb_caldyn,0,0,TestRequest)
	451	call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
	452	& jj_Nb_caldyn,0,0,TestRequest)
	453	call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm,
	454	& jj_Nb_caldyn,0,0,TestRequest)
	455	call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm,
	456	& jj_Nb_caldyn,0,0,TestRequest)
	457	call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm,
	458	& jj_Nb_caldyn,0,0,TestRequest)
	459	call Register_SwapFieldHallo(ps,ps,ip1jmp1,1,
	460	& jj_Nb_caldyn,0,0,TestRequest)
	461	call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1,
	462	& jj_Nb_caldyn,0,0,TestRequest)
	463	call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm,
	464	& jj_Nb_caldyn,0,0,TestRequest)
	465	call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
	466	& jj_Nb_caldyn,0,0,TestRequest)
	467	call Register_SwapFieldHallo(pks,pks,ip1jmp1,1,
	468	& jj_Nb_caldyn,0,0,TestRequest)
	469	call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
	470	& jj_Nb_caldyn,0,0,TestRequest)
	471	call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
	472	& jj_Nb_caldyn,0,0,TestRequest)
	473	call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm,
	474	& jj_Nb_caldyn,0,0,TestRequest)
	475
	476	do j=1,nqtot
	477	call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm,
	478	& jj_nb_caldyn,0,0,TestRequest)
	479	enddo
[8]	480	! ADAPTATION GCM POUR CP(T)
	481	call Register_SwapFieldHallo(temp,temp,ip1jmp1,llm,
	482	& jj_Nb_caldyn,0,0,TestRequest)
	483	call Register_SwapFieldHallo(tsurpk,tsurpk,ip1jmp1,llm,
	484	& jj_Nb_caldyn,0,0,TestRequest)
[1]	485
	486	call SetDistrib(jj_nb_caldyn)
	487	call SendRequest(TestRequest)
	488	call WaitRequest(TestRequest)
	489
	490	call AdjustBands_dissip
	491	call AdjustBands_physic
	492
	493	endif
	494	c$OMP END MASTER
	495	endif
	496
	497
	498
	499	c-----------------------------------------------------------------------
	500	c calcul des tendances dynamiques:
	501	c --------------------------------
	502	c$OMP BARRIER
	503	c$OMP MASTER
	504	call VTb(VThallo)
	505	c$OMP END MASTER
	506
	507	call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,TestRequest)
	508	call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,TestRequest)
	509	call Register_Hallo(teta,ip1jmp1,llm,1,1,1,1,TestRequest)
	510	call Register_Hallo(ps,ip1jmp1,1,1,2,2,1,TestRequest)
	511	call Register_Hallo(pkf,ip1jmp1,llm,1,1,1,1,TestRequest)
	512	call Register_Hallo(pk,ip1jmp1,llm,1,1,1,1,TestRequest)
	513	call Register_Hallo(pks,ip1jmp1,1,1,1,1,1,TestRequest)
	514	call Register_Hallo(p,ip1jmp1,llmp1,1,1,1,1,TestRequest)
[8]	515	! ADAPTATION GCM POUR CP(T)
	516	call Register_Hallo(temp,ip1jmp1,llm,1,1,1,1,TestRequest)
	517	call Register_Hallo(tsurpk,ip1jmp1,llm,1,1,1,1,TestRequest)
[1]	518
	519	c do j=1,nqtot
	520	c call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1,
	521	c * TestRequest)
	522	c enddo
	523
	524	call SendRequest(TestRequest)
	525	c$OMP BARRIER
	526	call WaitRequest(TestRequest)
	527
	528	c$OMP MASTER
	529	call VTe(VThallo)
	530	c$OMP END MASTER
	531	c$OMP BARRIER
	532
	533	if (debug) then
	534	!$OMP BARRIER
	535	!$OMP MASTER
	536	call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
	537	call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
	538	call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
	539	call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
	540	call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/)))
	541	call WriteField_p('pk',reshape(pk,(/iip1,jmp1,llm/)))
	542	call WriteField_p('pks',reshape(pks,(/iip1,jmp1/)))
	543	call WriteField_p('pkf',reshape(pkf,(/iip1,jmp1,llm/)))
	544	call WriteField_p('phis',reshape(phis,(/iip1,jmp1/)))
	545	do j=1,nqtot
	546	call WriteField_p('q'//trim(int2str(j)),
	547	. reshape(q(:,:,j),(/iip1,jmp1,llm/)))
	548	enddo
	549	!$OMP END MASTER
	550	c$OMP BARRIER
	551	endif
	552
	553
	554	True_itau=True_itau+1
	555
[8]	556	! ADAPTATION GCM POUR CP(T)
	557	call tpot2t_p(ip1jmp1,llm,teta,temp,pk)
	558	ijb=ij_begin
	559	ije=ij_end
	560	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	561	do l=1,llm
	562	tsurpk(ijb:ije,llm)=cpp*temp(ijb:ije,llm)/pk(ijb:ije,llm)
	563	enddo
	564	!$OMP END DO
	565
[1]	566	IF (prt_level>9) THEN
	567	WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau
	568	ENDIF
	569
	570
	571	call start_timer(timer_caldyn)
	572
[8]	573	! ADAPTATION GCM POUR CP(T)
	574	! CALL geopot_p ( ip1jmp1, teta , pk , pks, phis , phi )
	575	CALL geopot_p ( ip1jmp1, tsurpk , pk , pks, phis , phi )
[1]	576
	577	call VTb(VTcaldyn)
	578	c$OMP END MASTER
	579	! var_time=time+iday-day_ini
	580
	581	c$OMP BARRIER
	582	! CALL FTRACE_REGION_BEGIN("caldyn")
	583	time = jD_cur + jH_cur
[8]	584	! ADAPTATION GCM POUR CP(T)
	585	! CALL caldyn_p
	586	! $ ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
	587	! $ phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
[1]	588	CALL caldyn_p
[8]	589	$ ( itau,ucov,vcov,teta,ps,masse,pk,pkf,tsurpk,phis,
[1]	590	$ phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
	591
	592	! CALL FTRACE_REGION_END("caldyn")
	593
	594	c$OMP MASTER
	595	call VTe(VTcaldyn)
	596	c$OMP END MASTER
	597
	598	cc$OMP BARRIER
	599	cc$OMP MASTER
	600	! call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/)))
	601	! call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/)))
	602	! call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/)))
	603	! call WriteField_p('dp',reshape(dp,(/iip1,jmp1/)))
	604	! call WriteField_p('w',reshape(w,(/iip1,jmp1,llm/)))
	605	! call WriteField_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/)))
	606	! call WriteField_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/)))
	607	! call WriteField_p('p',reshape(p,(/iip1,jmp1,llmp1/)))
	608	! call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/)))
	609	! call WriteField_p('pk',reshape(pk,(/iip1,jmp1,llm/)))
	610	cc$OMP END MASTER
	611
	612	c-----------------------------------------------------------------------
	613	c calcul des tendances advection des traceurs (dont l'humidite)
	614	c -------------------------------------------------------------
	615
	616	IF( forward. OR . leapf ) THEN
	617	cc$OMP PARALLEL DEFAULT(SHARED)
	618	c
	619	CALL caladvtrac_p(q,pbaru,pbarv,
	620	* p, masse, dq, teta,
	621	. flxw,pk, iapptrac)
	622
[7]	623	C Stokage du flux de masse pour traceurs OFF-LINE
	624	IF (offline .AND. .NOT. adjust) THEN
	625	CALL fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis,
	626	. dtvr, itau)
	627	ENDIF
[1]	628
	629	ENDIF ! of IF( forward. OR . leapf )
	630	cc$OMP END PARALLEL
	631
	632	c-----------------------------------------------------------------------
	633	c integrations dynamique et traceurs:
	634	c ----------------------------------
	635
	636	c$OMP MASTER
	637	call VTb(VTintegre)
	638	c$OMP END MASTER
	639	c call WriteField_p('ucovm1',reshape(ucovm1,(/iip1,jmp1,llm/)))
	640	c call WriteField_p('vcovm1',reshape(vcovm1,(/iip1,jjm,llm/)))
	641	c call WriteField_p('tetam1',reshape(tetam1,(/iip1,jmp1,llm/)))
	642	c call WriteField_p('psm1',reshape(psm1,(/iip1,jmp1/)))
	643	c call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
	644	c call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
	645	c call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
	646	c call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
	647	cc$OMP PARALLEL DEFAULT(SHARED)
	648	c$OMP BARRIER
	649	! CALL FTRACE_REGION_BEGIN("integrd")
	650
	651	CALL integrd_p ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
	652	$ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis ,
	653	$ finvmaold )
	654
	655	! CALL FTRACE_REGION_END("integrd")
	656	c$OMP BARRIER
	657	cc$OMP MASTER
	658	c call WriteField_p('ucovm1',reshape(ucovm1,(/iip1,jmp1,llm/)))
	659	c call WriteField_p('vcovm1',reshape(vcovm1,(/iip1,jjm,llm/)))
	660	c call WriteField_p('tetam1',reshape(tetam1,(/iip1,jmp1,llm/)))
	661	c call WriteField_p('psm1',reshape(psm1,(/iip1,jmp1/)))
	662	c call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
	663	c call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
	664	c call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
	665	c call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/)))
	666	c
	667	c call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
	668	c do j=1,nqtot
	669	c call WriteField_p('q'//trim(int2str(j)),
	670	c . reshape(q(:,:,j),(/iip1,jmp1,llm/)))
	671	c call WriteField_p('dq'//trim(int2str(j)),
	672	c . reshape(dq(:,:,j),(/iip1,jmp1,llm/)))
	673	c enddo
	674	cc$OMP END MASTER
	675
	676
	677	c$OMP MASTER
	678	call VTe(VTintegre)
	679	c$OMP END MASTER
	680	c .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd)
	681	c
	682	c-----------------------------------------------------------------------
	683	c calcul des tendances physiques:
	684	c -------------------------------
	685	c ######## P.Le Van ( Modif le 6/02/95 ) ###########
	686	c
	687	IF( purmats ) THEN
	688	IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
	689	ELSE
	690	IF( itau+1. EQ. itaufin ) lafin = .TRUE.
	691	ENDIF
	692
	693	cc$OMP END PARALLEL
	694
	695	c
	696	c
	697	IF( apphys ) THEN
	698	c
	699	c ....... Ajout P.Le Van ( 17/04/96 ) ...........
	700	c
	701	cc$OMP PARALLEL DEFAULT(SHARED)
	702	cc$OMP+ PRIVATE(rdaym_ini,rdayvrai,ijb,ije)
	703
	704	c$OMP MASTER
	705	call suspend_timer(timer_caldyn)
	706
	707	if (prt_level >= 10) then
	708	write(lunout,*)
	709	& 'leapfrog_p: Entree dans la physique : Iteration No ',true_itau
	710	endif
	711	c$OMP END MASTER
	712
	713	CALL pression_p ( ip1jmp1, ap, bp, ps, p )
	714
	715	c$OMP BARRIER
	716	CALL exner_hyb_p( ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
	717	c$OMP BARRIER
	718	jD_cur = jD_ref + day_ini - day_ref
	719	$ + int (itau * dtvr / daysec)
	720	jH_cur = jH_ref + &
	721	& (itau * dtvr / daysec - int(itau * dtvr / daysec))
	722	! call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
	723
	724	c rajout debug
	725	c lafin = .true.
	726
	727
[8]	728	c Interface avec les routines de phylmd (phymars ... )
[1]	729	c -----------------------------------------------------
	730
	731	c+jld
	732
	733	c Diagnostique de conservation de l'energie : initialisation
	734	IF (ip_ebil_dyn.ge.1 ) THEN
	735	ztit='bil dyn'
	736	! Ehouarn: be careful, diagedyn is Earth-specific (includes ../phylmd/..)!
	737	IF (planet_type.eq."earth") THEN
	738	CALL diagedyn(ztit,2,1,1,dtphys
	739	& , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
	740	ENDIF
	741	ENDIF
	742	c-jld
	743	c$OMP BARRIER
	744	c$OMP MASTER
	745	call VTb(VThallo)
	746	c$OMP END MASTER
	747
	748	call SetTag(Request_physic,800)
	749
	750	call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
	751	* jj_Nb_physic,2,2,Request_physic)
	752
	753	call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
	754	* jj_Nb_physic,2,2,Request_physic)
	755
	756	call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
	757	* jj_Nb_physic,2,2,Request_physic)
	758
	759	call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm,
	760	* jj_Nb_physic,1,2,Request_physic)
	761
	762	call Register_SwapFieldHallo(p,p,ip1jmp1,llmp1,
	763	* jj_Nb_physic,2,2,Request_physic)
	764
	765	call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
	766	* jj_Nb_physic,2,2,Request_physic)
	767
	768	call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
	769	* jj_Nb_physic,2,2,Request_physic)
	770
	771	call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
	772	* jj_Nb_physic,2,2,Request_physic)
	773
	774	call Register_SwapFieldHallo(w,w,ip1jmp1,llm,
	775	* jj_Nb_physic,2,2,Request_physic)
	776
	777	c call SetDistrib(jj_nb_vanleer)
	778	do j=1,nqtot
	779
	780	call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm,
	781	* jj_Nb_physic,2,2,Request_physic)
	782	enddo
	783
	784	call Register_SwapFieldHallo(flxw,flxw,ip1jmp1,llm,
	785	* jj_Nb_physic,2,2,Request_physic)
	786
	787	call SendRequest(Request_Physic)
	788	c$OMP BARRIER
	789	call WaitRequest(Request_Physic)
	790
	791	c$OMP BARRIER
	792	c$OMP MASTER
	793	call SetDistrib(jj_nb_Physic)
	794	call VTe(VThallo)
	795
	796	call VTb(VTphysiq)
	797	c$OMP END MASTER
	798	c$OMP BARRIER
	799
	800	cc$OMP MASTER
	801	c call WriteField_p('ucovfi',reshape(ucov,(/iip1,jmp1,llm/)))
	802	c call WriteField_p('vcovfi',reshape(vcov,(/iip1,jjm,llm/)))
	803	c call WriteField_p('tetafi',reshape(teta,(/iip1,jmp1,llm/)))
	804	c call WriteField_p('pfi',reshape(p,(/iip1,jmp1,llmp1/)))
	805	c call WriteField_p('pkfi',reshape(pk,(/iip1,jmp1,llm/)))
	806	cc$OMP END MASTER
	807	cc$OMP BARRIER
	808	! CALL FTRACE_REGION_BEGIN("calfis")
	809	CALL calfis_p(lafin ,jD_cur, jH_cur,
	810	$ ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
	811	$ du,dv,dteta,dq,
	812	$ flxw,
	813	$ clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi )
	814	! CALL FTRACE_REGION_END("calfis")
	815	ijb=ij_begin
	816	ije=ij_end
	817	if ( .not. pole_nord) then
	818	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	819	DO l=1,llm
	820	dufi_tmp(1:iip1,l) = dufi(ijb:ijb+iim,l)
	821	dvfi_tmp(1:iip1,l) = dvfi(ijb:ijb+iim,l)
	822	dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)
	823	dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)
	824	ENDDO
	825	c$OMP END DO NOWAIT
	826
	827	c$OMP MASTER
	828	dpfi_tmp(1:iip1) = dpfi(ijb:ijb+iim)
	829	c$OMP END MASTER
	830	endif ! of if ( .not. pole_nord)
	831
	832	c$OMP BARRIER
	833	c$OMP MASTER
	834	call SetDistrib(jj_nb_Physic_bis)
	835
	836	call VTb(VThallo)
	837	c$OMP END MASTER
	838	c$OMP BARRIER
	839
	840	call Register_Hallo(dufi,ip1jmp1,llm,
	841	* 1,0,0,1,Request_physic)
	842
	843	call Register_Hallo(dvfi,ip1jm,llm,
	844	* 1,0,0,1,Request_physic)
	845
	846	call Register_Hallo(dtetafi,ip1jmp1,llm,
	847	* 1,0,0,1,Request_physic)
	848
	849	call Register_Hallo(dpfi,ip1jmp1,1,
	850	* 1,0,0,1,Request_physic)
	851
	852	do j=1,nqtot
	853	call Register_Hallo(dqfi(1,1,j),ip1jmp1,llm,
	854	* 1,0,0,1,Request_physic)
	855	enddo
	856
	857	call SendRequest(Request_Physic)
	858	c$OMP BARRIER
	859	call WaitRequest(Request_Physic)
	860
	861	c$OMP BARRIER
	862	c$OMP MASTER
	863	call VTe(VThallo)
	864
	865	call SetDistrib(jj_nb_Physic)
	866	c$OMP END MASTER
	867	c$OMP BARRIER
	868	ijb=ij_begin
	869	if (.not. pole_nord) then
	870
	871	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	872	DO l=1,llm
	873	dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
	874	dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l)
	875	dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)
	876	& +dtetafi_tmp(1:iip1,l)
	877	dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:)
	878	& + dqfi_tmp(1:iip1,l,:)
	879	ENDDO
	880	c$OMP END DO NOWAIT
	881
	882	c$OMP MASTER
	883	dpfi(ijb:ijb+iim) = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
	884	c$OMP END MASTER
	885
	886	endif ! of if (.not. pole_nord)
	887	c$OMP BARRIER
	888	cc$OMP MASTER
	889	c call WriteField_p('dufi',reshape(dufi,(/iip1,jmp1,llm/)))
	890	c call WriteField_p('dvfi',reshape(dvfi,(/iip1,jjm,llm/)))
	891	c call WriteField_p('dtetafi',reshape(dtetafi,(/iip1,jmp1,llm/)))
	892	c call WriteField_p('dpfi',reshape(dpfi,(/iip1,jmp1/)))
	893	cc$OMP END MASTER
	894	c
	895	c do j=1,nqtot
	896	c call WriteField_p('dqfi'//trim(int2str(j)),
	897	c . reshape(dqfi(:,:,j),(/iip1,jmp1,llm/)))
	898	c enddo
	899
	900	c ajout des tendances physiques:
	901	c ------------------------------
	902	IF (ok_strato) THEN
	903	CALL top_bound_p( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
	904	ENDIF
	905
	906	CALL addfi_p( dtphys, leapf, forward ,
	907	$ ucov, vcov, teta , q ,ps ,
	908	$ dufi, dvfi, dtetafi , dqfi ,dpfi )
	909
	910	c$OMP BARRIER
	911	c$OMP MASTER
	912	call VTe(VTphysiq)
	913
	914	call VTb(VThallo)
	915	c$OMP END MASTER
	916
	917	call SetTag(Request_physic,800)
	918	call Register_SwapField(ucov,ucov,ip1jmp1,llm,
	919	* jj_Nb_caldyn,Request_physic)
	920
	921	call Register_SwapField(vcov,vcov,ip1jm,llm,
	922	* jj_Nb_caldyn,Request_physic)
	923
	924	call Register_SwapField(teta,teta,ip1jmp1,llm,
	925	* jj_Nb_caldyn,Request_physic)
	926
	927	call Register_SwapField(masse,masse,ip1jmp1,llm,
	928	* jj_Nb_caldyn,Request_physic)
	929
	930	call Register_SwapField(p,p,ip1jmp1,llmp1,
	931	* jj_Nb_caldyn,Request_physic)
	932
	933	call Register_SwapField(pk,pk,ip1jmp1,llm,
	934	* jj_Nb_caldyn,Request_physic)
	935
	936	call Register_SwapField(phis,phis,ip1jmp1,1,
	937	* jj_Nb_caldyn,Request_physic)
	938
	939	call Register_SwapField(phi,phi,ip1jmp1,llm,
	940	* jj_Nb_caldyn,Request_physic)
	941
	942	call Register_SwapField(w,w,ip1jmp1,llm,
	943	* jj_Nb_caldyn,Request_physic)
	944
	945	do j=1,nqtot
	946
	947	call Register_SwapField(q(1,1,j),q(1,1,j),ip1jmp1,llm,
	948	* jj_Nb_caldyn,Request_physic)
	949
	950	enddo
	951
	952	call SendRequest(Request_Physic)
	953	c$OMP BARRIER
	954	call WaitRequest(Request_Physic)
	955
	956	c$OMP BARRIER
	957	c$OMP MASTER
	958	call VTe(VThallo)
	959	call SetDistrib(jj_Nb_caldyn)
	960	c$OMP END MASTER
	961	c$OMP BARRIER
	962	c
	963	c Diagnostique de conservation de l'energie : difference
	964	IF (ip_ebil_dyn.ge.1 ) THEN
	965	ztit='bil phys'
	966	CALL diagedyn(ztit,2,1,1,dtphys
	967	e , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
	968	ENDIF
	969
	970	cc$OMP MASTER
	971	c if (debug) then
	972	c call WriteField_p('ucovfi',reshape(ucov,(/iip1,jmp1,llm/)))
	973	c call WriteField_p('vcovfi',reshape(vcov,(/iip1,jjm,llm/)))
	974	c call WriteField_p('tetafi',reshape(teta,(/iip1,jmp1,llm/)))
	975	c endif
	976	cc$OMP END MASTER
	977
	978
	979	c-jld
	980	c$OMP MASTER
	981	call resume_timer(timer_caldyn)
	982	if (FirstPhysic) then
	983	ok_start_timer=.TRUE.
	984	FirstPhysic=.false.
	985	endif
	986	c$OMP END MASTER
	987	ENDIF ! of IF( apphys )
	988
	989	IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
	990	! Academic case : Simple friction and Newtonan relaxation
	991	! -------------------------------------------------------
	992	ijb=ij_begin
	993	ije=ij_end
	994	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	995	do l=1,llm
	996	teta(ijb:ije,l)=teta(ijb:ije,l)-dtvr*
	997	& (teta(ijb:ije,l)-tetarappel(ijb:ije,l))*
	998	& (knewt_g+knewt_t(l)*clat4(ijb:ije))
	999	enddo ! of do l=1,llm
	1000	!$OMP END DO
	1001
	1002	call Register_Hallo(ucov,ip1jmp1,llm,0,1,1,0,Request_Physic)
	1003	call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Request_Physic)
	1004	call SendRequest(Request_Physic)
	1005	c$OMP BARRIER
	1006	call WaitRequest(Request_Physic)
	1007	c$OMP BARRIER
	1008	call friction_p(ucov,vcov,dtvr)
	1009	!$OMP BARRIER
	1010
	1011	! Sponge layer (if any)
	1012	IF (ok_strato) THEN
	1013	! set dufi,dvfi,... to zero
	1014	ijb=ij_begin
	1015	ije=ij_end
	1016	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1017	do l=1,llm
	1018	dufi(ijb:ije,l)=0
	1019	dtetafi(ijb:ije,l)=0
	1020	dqfi(ijb:ije,l,1:nqtot)=0
	1021	enddo
	1022	!$OMP END DO
	1023	!$OMP SINGLE
	1024	dpfi(ijb:ije)=0
	1025	!$OMP END SINGLE
	1026	ijb=ij_begin
	1027	ije=ij_end
	1028	if (pole_sud) ije=ije-iip1
	1029	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1030	do l=1,llm
	1031	dvfi(ijb:ije,l)=0
	1032	enddo
	1033	!$OMP END DO
	1034
	1035	CALL top_bound_p(vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
	1036	CALL addfi_p( dtvr, leapf, forward ,
	1037	$ ucov, vcov, teta , q ,ps ,
	1038	$ dufi, dvfi, dtetafi , dqfi ,dpfi )
	1039	!$OMP BARRIER
	1040	ENDIF ! of IF (ok_strato)
	1041	ENDIF ! of IF(iflag_phys.EQ.2)
	1042
	1043
	1044	CALL pression_p ( ip1jmp1, ap, bp, ps, p )
	1045	c$OMP BARRIER
	1046	CALL exner_hyb_p( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
	1047	c$OMP BARRIER
	1048
	1049	cc$OMP END PARALLEL
	1050
	1051	c-----------------------------------------------------------------------
	1052	c dissipation horizontale et verticale des petites echelles:
	1053	c ----------------------------------------------------------
	1054
	1055	IF(apdiss) THEN
	1056	cc$OMP PARALLEL DEFAULT(SHARED)
	1057	cc$OMP+ PRIVATE(ijb,ije,tppn,tpn,tpps,tps)
	1058	c$OMP MASTER
	1059	call suspend_timer(timer_caldyn)
	1060
	1061	c print*,'Entree dans la dissipation : Iteration No ',true_itau
	1062	c calcul de l'energie cinetique avant dissipation
	1063	c print *,'Passage dans la dissipation'
	1064
	1065	call VTb(VThallo)
	1066	c$OMP END MASTER
	1067
	1068	c$OMP BARRIER
	1069
	1070	call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
	1071	* jj_Nb_dissip,1,1,Request_dissip)
	1072
	1073	call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
	1074	* jj_Nb_dissip,1,1,Request_dissip)
	1075
	1076	call Register_SwapField(teta,teta,ip1jmp1,llm,
	1077	* jj_Nb_dissip,Request_dissip)
	1078
	1079	call Register_SwapField(p,p,ip1jmp1,llmp1,
	1080	* jj_Nb_dissip,Request_dissip)
	1081
	1082	call Register_SwapField(pk,pk,ip1jmp1,llm,
	1083	* jj_Nb_dissip,Request_dissip)
	1084
	1085	call SendRequest(Request_dissip)
	1086	c$OMP BARRIER
	1087	call WaitRequest(Request_dissip)
	1088
	1089	c$OMP BARRIER
	1090	c$OMP MASTER
	1091	call SetDistrib(jj_Nb_dissip)
	1092	call VTe(VThallo)
	1093	call VTb(VTdissipation)
	1094	call start_timer(timer_dissip)
	1095	c$OMP END MASTER
	1096	c$OMP BARRIER
	1097
	1098	call covcont_p(llm,ucov,vcov,ucont,vcont)
	1099	call enercin_p(vcov,ucov,vcont,ucont,ecin0)
	1100
	1101	c dissipation
[8]	1102	! ADAPTATION GCM POUR CP(T)
	1103	call tpot2t_p(ip1jmp1,llm,teta,temp,pk)
[1]	1104
	1105	! CALL FTRACE_REGION_BEGIN("dissip")
	1106	CALL dissip_p(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
	1107	! CALL FTRACE_REGION_END("dissip")
	1108
	1109	ijb=ij_begin
	1110	ije=ij_end
	1111	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1112	DO l=1,llm
	1113	ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
[8]	1114	dudis(ijb:ije,l)=dudis(ijb:ije,l)/dtdiss ! passage en (m/s)/s
[1]	1115	ENDDO
	1116	c$OMP END DO NOWAIT
	1117	if (pole_sud) ije=ije-iip1
	1118	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1119	DO l=1,llm
	1120	vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
[8]	1121	dvdis(ijb:ije,l)=dvdis(ijb:ije,l)/dtdiss ! passage en (m/s)/s
[1]	1122	ENDDO
	1123	c$OMP END DO NOWAIT
	1124
	1125
	1126	c------------------------------------------------------------------------
	1127	if (dissip_conservative) then
	1128	C On rajoute la tendance due a la transform. Ec -> E therm. cree
	1129	C lors de la dissipation
	1130	c$OMP BARRIER
	1131	c$OMP MASTER
	1132	call suspend_timer(timer_dissip)
	1133	call VTb(VThallo)
	1134	c$OMP END MASTER
	1135	call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,Request_Dissip)
	1136	call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Request_Dissip)
	1137	call SendRequest(Request_Dissip)
	1138	c$OMP BARRIER
	1139	call WaitRequest(Request_Dissip)
	1140	c$OMP MASTER
	1141	call VTe(VThallo)
	1142	call resume_timer(timer_dissip)
	1143	c$OMP END MASTER
	1144	c$OMP BARRIER
	1145	call covcont_p(llm,ucov,vcov,ucont,vcont)
	1146	call enercin_p(vcov,ucov,vcont,ucont,ecin)
	1147
	1148	ijb=ij_begin
	1149	ije=ij_end
	1150	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1151	do l=1,llm
	1152	do ij=ijb,ije
[8]	1153	! ADAPTATION GCM POUR CP(T)
	1154	! dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
	1155	! dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
	1156	temp(ij,l)=temp(ij,l) +
	1157	& (ecin0(ij,l)-ecin(ij,l))/cpdet(temp(ij,l))
	1158	enddo
	1159	enddo
	1160	c$OMP END DO
	1161	call t2tpot_p(ip1jmp1,llm,temp,ztetaec,pk)
	1162	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1163	do l=1,llm
	1164	do ij=ijb,ije
	1165	dtetaecdt(ij,l)=ztetaec(ij,l)-teta(ij,l)
[1]	1166	dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
	1167	enddo
	1168	enddo
[8]	1169	c$OMP END DO NOWAIT
[1]	1170	endif ! of if (dissip_conservative)
	1171
	1172	ijb=ij_begin
	1173	ije=ij_end
	1174	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1175	do l=1,llm
	1176	do ij=ijb,ije
	1177	teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
[8]	1178	dtetadis(ij,l)=dtetadis(ij,l)/dtdiss ! passage en K/s
[1]	1179	enddo
	1180	enddo
	1181	c$OMP END DO NOWAIT
	1182	c------------------------------------------------------------------------
	1183
	1184
	1185	c ....... P. Le Van ( ajout le 17/04/96 ) ...........
	1186	c ... Calcul de la valeur moyenne, unique de h aux poles .....
	1187	c
	1188
	1189	ijb=ij_begin
	1190	ije=ij_end
	1191
	1192	if (pole_nord) then
	1193	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1194	DO l = 1, llm
	1195	DO ij = 1,iim
	1196	tppn(ij) = aire( ij ) * teta( ij ,l)
	1197	ENDDO
	1198	tpn = SSUM(iim,tppn,1)/apoln
	1199
	1200	DO ij = 1, iip1
	1201	teta( ij ,l) = tpn
	1202	ENDDO
	1203	ENDDO
	1204	c$OMP END DO NOWAIT
	1205
	1206	c$OMP MASTER
	1207	DO ij = 1,iim
	1208	tppn(ij) = aire( ij ) * ps ( ij )
	1209	ENDDO
	1210	tpn = SSUM(iim,tppn,1)/apoln
	1211
	1212	DO ij = 1, iip1
	1213	ps( ij ) = tpn
	1214	ENDDO
	1215	c$OMP END MASTER
	1216	endif
	1217
	1218	if (pole_sud) then
	1219	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1220	DO l = 1, llm
	1221	DO ij = 1,iim
	1222	tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
	1223	ENDDO
	1224	tps = SSUM(iim,tpps,1)/apols
	1225
	1226	DO ij = 1, iip1
	1227	teta(ij+ip1jm,l) = tps
	1228	ENDDO
	1229	ENDDO
	1230	c$OMP END DO NOWAIT
	1231
	1232	c$OMP MASTER
	1233	DO ij = 1,iim
	1234	tpps(ij) = aire(ij+ip1jm) * ps (ij+ip1jm)
	1235	ENDDO
	1236	tps = SSUM(iim,tpps,1)/apols
	1237
	1238	DO ij = 1, iip1
	1239	ps(ij+ip1jm) = tps
	1240	ENDDO
	1241	c$OMP END MASTER
	1242	endif
	1243
	1244
	1245	c$OMP BARRIER
	1246	c$OMP MASTER
	1247	call VTe(VTdissipation)
	1248
	1249	call stop_timer(timer_dissip)
	1250
	1251	call VTb(VThallo)
	1252	c$OMP END MASTER
	1253	call Register_SwapField(ucov,ucov,ip1jmp1,llm,
	1254	* jj_Nb_caldyn,Request_dissip)
	1255
	1256	call Register_SwapField(vcov,vcov,ip1jm,llm,
	1257	* jj_Nb_caldyn,Request_dissip)
	1258
	1259	call Register_SwapField(teta,teta,ip1jmp1,llm,
	1260	* jj_Nb_caldyn,Request_dissip)
	1261
	1262	call Register_SwapField(p,p,ip1jmp1,llmp1,
	1263	* jj_Nb_caldyn,Request_dissip)
	1264
	1265	call Register_SwapField(pk,pk,ip1jmp1,llm,
	1266	* jj_Nb_caldyn,Request_dissip)
	1267
	1268	call SendRequest(Request_dissip)
	1269	c$OMP BARRIER
	1270	call WaitRequest(Request_dissip)
	1271
	1272	c$OMP BARRIER
	1273	c$OMP MASTER
	1274	call SetDistrib(jj_Nb_caldyn)
	1275	call VTe(VThallo)
	1276	call resume_timer(timer_caldyn)
	1277	c print *,'fin dissipation'
	1278	c$OMP END MASTER
	1279	c$OMP BARRIER
	1280	END IF ! of IF(apdiss)
	1281
	1282	cc$OMP END PARALLEL
	1283
	1284	c ajout debug
	1285	c IF( lafin ) then
	1286	c abort_message = 'Simulation finished'
	1287	c call abort_gcm(modname,abort_message,0)
	1288	c ENDIF
	1289
	1290	c ********************************************************************
	1291	c ********************************************************************
	1292	c .... fin de l'integration dynamique et physique pour le pas itau ..
	1293	c ********************************************************************
	1294	c ********************************************************************
	1295
	1296	c preparation du pas d'integration suivant ......
	1297	cym call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
	1298	cym call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
	1299	c$OMP MASTER
	1300	call stop_timer(timer_caldyn)
	1301	c$OMP END MASTER
	1302	IF (itau==itaumax) then
	1303	c$OMP MASTER
	1304	call allgather_timer_average
	1305
	1306	if (mpi_rank==0) then
	1307
	1308	print ,'********************************'
	1309	print ,'*** TIMER CALDYN ****'
	1310	do i=0,mpi_size-1
	1311	print *,'proc',i,' : Nb Bandes :',jj_nb_caldyn(i),
	1312	& ' : temps moyen :',
	1313	& timer_average(jj_nb_caldyn(i),timer_caldyn,i)
	1314	enddo
	1315
	1316	print ,'********************************'
	1317	print ,'*** TIMER VANLEER ****'
	1318	do i=0,mpi_size-1
	1319	print *,'proc',i,' : Nb Bandes :',jj_nb_vanleer(i),
	1320	& ' : temps moyen :',
	1321	& timer_average(jj_nb_vanleer(i),timer_vanleer,i)
	1322	enddo
	1323
	1324	print ,'********************************'
	1325	print ,'*** TIMER DISSIP ****'
	1326	do i=0,mpi_size-1
	1327	print *,'proc',i,' : Nb Bandes :',jj_nb_dissip(i),
	1328	& ' : temps moyen :',
	1329	& timer_average(jj_nb_dissip(i),timer_dissip,i)
	1330	enddo
	1331
	1332	print ,'********************************'
	1333	print ,'*** TIMER PHYSIC ****'
	1334	do i=0,mpi_size-1
	1335	print *,'proc',i,' : Nb Bandes :',jj_nb_physic(i),
	1336	& ' : temps moyen :',
	1337	& timer_average(jj_nb_physic(i),timer_physic,i)
	1338	enddo
	1339
	1340	endif
	1341
	1342	print ,'Taille du Buffer MPI (REAL8)',MaxBufferSize
	1343	print ,'Taille du Buffer MPI utilise (REAL8)',MaxBufferSize_Used
	1344	print *, 'Temps total ecoule sur la parallelisation :',DiffTime()
	1345	print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime()
	1346	CALL print_filtre_timer
	1347	call fin_getparam
	1348	call finalize_parallel
	1349	c$OMP END MASTER
	1350	c$OMP BARRIER
	1351	RETURN
	1352	ENDIF
	1353
	1354	IF ( .NOT.purmats ) THEN
	1355	c ........................................................
	1356	c .............. schema matsuno + leapfrog ..............
	1357	c ........................................................
	1358
	1359	IF(forward. OR. leapf) THEN
	1360	itau= itau + 1
	1361	! iday= day_ini+itau/day_step
	1362	! time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
	1363	! IF(time.GT.1.) THEN
	1364	! time = time-1.
	1365	! iday = iday+1
	1366	! ENDIF
	1367	ENDIF
	1368
	1369
	1370	IF( itau. EQ. itaufinp1 ) then
	1371
	1372	if (flag_verif) then
	1373	write(79,*) 'ucov',ucov
	1374	write(80,*) 'vcov',vcov
	1375	write(81,*) 'teta',teta
	1376	write(82,*) 'ps',ps
	1377	write(83,*) 'q',q
	1378	WRITE(85,*) 'q1 = ',q(:,:,1)
	1379	WRITE(86,*) 'q3 = ',q(:,:,3)
	1380	endif
	1381
	1382
	1383	c$OMP MASTER
	1384	call fin_getparam
	1385	call finalize_parallel
	1386	c$OMP END MASTER
	1387	abort_message = 'Simulation finished'
	1388	call abort_gcm(modname,abort_message,0)
	1389	RETURN
	1390	ENDIF
	1391	c-----------------------------------------------------------------------
	1392	c ecriture du fichier histoire moyenne:
	1393	c -------------------------------------
	1394
	1395	IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
	1396	c$OMP BARRIER
	1397	IF(itau.EQ.itaufin) THEN
	1398	iav=1
	1399	ELSE
	1400	iav=0
	1401	ENDIF
	1402	#ifdef CPP_IOIPSL
	1403	IF (ok_dynzon) THEN
	1404	call Register_Hallo(vcov,ip1jm,llm,1,0,0,1,TestRequest)
	1405	call SendRequest(TestRequest)
	1406	c$OMP BARRIER
	1407	call WaitRequest(TestRequest)
	1408	c$OMP BARRIER
	1409	c$OMP MASTER
	1410	! CALL writedynav_p(histaveid, itau,vcov ,
	1411	! , ucov,teta,pk,phi,q,masse,ps,phis)
	1412
	1413	c ATTENTION!!! bilan_dyn_p ne marche probablement pas avec OpenMP
[8]	1414	! CALL bilan_dyn_p(2,dtvriperiod,dtvrday_step*periodav,
	1415	! , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
	1416	c les traceurs ne sont pas sortis, trop lourd.
	1417	c Peut changer eventuellement si besoin.
	1418	CALL bilan_dyn_p(dtvriperiod,dtvrday_step*periodav,
	1419	& ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,
	1420	& du,dudis,duspg,dufi)
[1]	1421	c$OMP END MASTER
	1422	ENDIF !ok_dynzon
	1423	#endif
	1424	IF (ok_dyn_ave) THEN
	1425	!$OMP MASTER
	1426	#ifdef CPP_IOIPSL
	1427	! Ehouarn: Gather fields and make master send to output
	1428	call Gather_Field(vcov,ip1jm,llm,0)
	1429	call Gather_Field(ucov,ip1jmp1,llm,0)
	1430	call Gather_Field(teta,ip1jmp1,llm,0)
	1431	call Gather_Field(pk,ip1jmp1,llm,0)
	1432	call Gather_Field(phi,ip1jmp1,llm,0)
	1433	do iq=1,nqtot
	1434	call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
	1435	enddo
	1436	call Gather_Field(masse,ip1jmp1,llm,0)
	1437	call Gather_Field(ps,ip1jmp1,1,0)
	1438	call Gather_Field(phis,ip1jmp1,1,0)
	1439	if (mpi_rank==0) then
	1440	CALL writedynav(itau,vcov,
	1441	& ucov,teta,pk,phi,q,masse,ps,phis)
	1442	endif
	1443	#endif
	1444	!$OMP END MASTER
	1445	ENDIF ! of IF (ok_dyn_ave)
	1446	ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin))
	1447
	1448	c-----------------------------------------------------------------------
	1449	c ecriture de la bande histoire:
	1450	c ------------------------------
	1451
	1452	IF( MOD(itau,iecri).EQ.0) THEN
	1453	! Ehouarn: output only during LF or Backward Matsuno
	1454	if (leapf.or.(.not.leapf.and.(.not.forward))) then
	1455	c$OMP BARRIER
	1456	c$OMP MASTER
	1457	nbetat = nbetatdem
[8]	1458
	1459	! ADAPTATION GCM POUR CP(T)
	1460	call tpot2t_p(ip1jmp1,llm,teta,temp,pk)
	1461	ijb=ij_begin
	1462	ije=ij_end
	1463	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1464	do l=1,llm
	1465	tsurpk(ijb:ije,llm)=cpp*temp(ijb:ije,llm)/pk(ijb:ije,llm)
	1466	enddo
	1467	!$OMP END DO
	1468	! CALL geopot_p(ip1jmp1,teta,pk,pks,phis,phi)
	1469	CALL geopot_p ( ip1jmp1, tsurpk , pk , pks, phis , phi )
[1]	1470
	1471	cym unat=0.
	1472
	1473	ijb=ij_begin
	1474	ije=ij_end
	1475
	1476	if (pole_nord) then
	1477	ijb=ij_begin+iip1
	1478	unat(1:iip1,:)=0.
	1479	endif
	1480
	1481	if (pole_sud) then
	1482	ije=ij_end-iip1
	1483	unat(ij_end-iip1+1:ij_end,:)=0.
	1484	endif
	1485
	1486	do l=1,llm
	1487	unat(ijb:ije,l)=ucov(ijb:ije,l)/cu(ijb:ije)
	1488	enddo
	1489
	1490	ijb=ij_begin
	1491	ije=ij_end
	1492	if (pole_sud) ije=ij_end-iip1
	1493
	1494	do l=1,llm
	1495	vnat(ijb:ije,l)=vcov(ijb:ije,l)/cv(ijb:ije)
	1496	enddo
	1497
	1498	#ifdef CPP_IOIPSL
	1499	if (ok_dyn_ins) then
	1500	! Ehouarn: Gather fields and make master write to output
	1501	call Gather_Field(vcov,ip1jm,llm,0)
	1502	call Gather_Field(ucov,ip1jmp1,llm,0)
	1503	call Gather_Field(teta,ip1jmp1,llm,0)
	1504	call Gather_Field(phi,ip1jmp1,llm,0)
	1505	do iq=1,nqtot
	1506	call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
	1507	enddo
	1508	call Gather_Field(masse,ip1jmp1,llm,0)
	1509	call Gather_Field(ps,ip1jmp1,1,0)
	1510	call Gather_Field(phis,ip1jmp1,1,0)
	1511	if (mpi_rank==0) then
	1512	CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
	1513	endif
	1514	! CALL writehist_p(histid,histvid, itau,vcov,
	1515	! & ucov,teta,phi,q,masse,ps,phis)
	1516	! or use writefield_p
	1517	! call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
	1518	! call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
	1519	! call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
	1520	! call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
	1521	endif ! of if (ok_dyn_ins)
	1522	#endif
	1523	! For some Grads outputs of fields
	1524	if (output_grads_dyn) then
	1525	! Ehouarn: hope this works the way I think it does:
	1526	call Gather_Field(unat,ip1jmp1,llm,0)
	1527	call Gather_Field(vnat,ip1jm,llm,0)
	1528	call Gather_Field(teta,ip1jmp1,llm,0)
	1529	call Gather_Field(ps,ip1jmp1,1,0)
	1530	do iq=1,nqtot
	1531	call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
	1532	enddo
	1533	if (mpi_rank==0) then
	1534	#include "write_grads_dyn.h"
	1535	endif
	1536	endif ! of if (output_grads_dyn)
	1537	c$OMP END MASTER
	1538	endif ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
	1539	ENDIF ! of IF(MOD(itau,iecri).EQ.0)
	1540
	1541	IF(itau.EQ.itaufin) THEN
	1542
	1543	c$OMP BARRIER
	1544	c$OMP MASTER
	1545
[8]	1546	if (planet_type.eq."mars") then
	1547	! POUR MARS, METTRE UNE FONCTION A PART, genre dynredem1_mars
	1548	abort_message = 'dynredem1_mars A FAIRE'
	1549	call abort_gcm(modname,abort_message,0)
	1550	else
[1]	1551	! Write an Earth-format restart file
	1552	CALL dynredem1_p("restart.nc",0.0,
	1553	& vcov,ucov,teta,q,masse,ps)
[8]	1554	endif ! of if (planet_type.eq."mars")
[1]	1555
	1556	! CLOSE(99)
	1557	c$OMP END MASTER
	1558	ENDIF ! of IF (itau.EQ.itaufin)
	1559
	1560	c-----------------------------------------------------------------------
	1561	c gestion de l'integration temporelle:
	1562	c ------------------------------------
	1563
	1564	IF( MOD(itau,iperiod).EQ.0 ) THEN
	1565	GO TO 1
	1566	ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN
	1567
	1568	IF( forward ) THEN
	1569	c fin du pas forward et debut du pas backward
	1570
	1571	forward = .FALSE.
	1572	leapf = .FALSE.
	1573	GO TO 2
	1574
	1575	ELSE
	1576	c fin du pas backward et debut du premier pas leapfrog
	1577
	1578	leapf = .TRUE.
	1579	dt = 2.*dtvr
	1580	GO TO 2
	1581	END IF
	1582	ELSE
	1583
	1584	c ...... pas leapfrog .....
	1585
	1586	leapf = .TRUE.
	1587	dt = 2.*dtvr
	1588	GO TO 2
	1589	END IF ! of IF (MOD(itau,iperiod).EQ.0)
	1590	! ELSEIF (MOD(itau-1,iperiod).EQ.0)
	1591
	1592
	1593	ELSE ! of IF (.not.purmats)
	1594
	1595	c ........................................................
	1596	c .............. schema matsuno ...............
	1597	c ........................................................
	1598	IF( forward ) THEN
	1599
	1600	itau = itau + 1
	1601	! iday = day_ini+itau/day_step
	1602	! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
	1603	!
	1604	! IF(time.GT.1.) THEN
	1605	! time = time-1.
	1606	! iday = iday+1
	1607	! ENDIF
	1608
	1609	forward = .FALSE.
	1610	IF( itau. EQ. itaufinp1 ) then
	1611	c$OMP MASTER
	1612	call fin_getparam
	1613	call finalize_parallel
	1614	c$OMP END MASTER
	1615	abort_message = 'Simulation finished'
	1616	call abort_gcm(modname,abort_message,0)
	1617	RETURN
	1618	ENDIF
	1619	GO TO 2
	1620
	1621	ELSE ! of IF(forward) i.e. backward step
	1622
	1623	IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
	1624	IF(itau.EQ.itaufin) THEN
	1625	iav=1
	1626	ELSE
	1627	iav=0
	1628	ENDIF
	1629	#ifdef CPP_IOIPSL
	1630	IF (ok_dynzon) THEN
	1631	c$OMP BARRIER
	1632	call Register_Hallo(vcov,ip1jm,llm,1,0,0,1,TestRequest)
	1633	call SendRequest(TestRequest)
	1634	c$OMP BARRIER
	1635	call WaitRequest(TestRequest)
	1636	c$OMP BARRIER
	1637	c$OMP MASTER
	1638	! CALL writedynav_p(histaveid, itau,vcov ,
	1639	! , ucov,teta,pk,phi,q,masse,ps,phis)
[8]	1640	! CALL bilan_dyn_p(2,dtvriperiod,dtvrday_step*periodav,
	1641	! , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
	1642	c les traceurs ne sont pas sortis, trop lourd.
	1643	c Peut changer eventuellement si besoin.
	1644	CALL bilan_dyn_p(dtvriperiod,dtvrday_step*periodav,
	1645	& ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,
	1646	& du,dudis,duspg,dufi)
	1647
[1]	1648	c$OMP END MASTER
	1649	END IF !ok_dynzon
	1650	#endif
	1651	IF (ok_dyn_ave) THEN
	1652	!$OMP MASTER
	1653	#ifdef CPP_IOIPSL
	1654	! Ehouarn: Gather fields and make master send to output
	1655	call Gather_Field(vcov,ip1jm,llm,0)
	1656	call Gather_Field(ucov,ip1jmp1,llm,0)
	1657	call Gather_Field(teta,ip1jmp1,llm,0)
	1658	call Gather_Field(pk,ip1jmp1,llm,0)
	1659	call Gather_Field(phi,ip1jmp1,llm,0)
	1660	do iq=1,nqtot
	1661	call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
	1662	enddo
	1663	call Gather_Field(masse,ip1jmp1,llm,0)
	1664	call Gather_Field(ps,ip1jmp1,1,0)
	1665	call Gather_Field(phis,ip1jmp1,1,0)
	1666	if (mpi_rank==0) then
	1667	CALL writedynav(itau,vcov,
	1668	& ucov,teta,pk,phi,q,masse,ps,phis)
	1669	endif
	1670	#endif
	1671	!$OMP END MASTER
	1672	ENDIF ! of IF (ok_dyn_ave)
	1673
	1674	ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
	1675
	1676
	1677	IF(MOD(itau,iecri ).EQ.0) THEN
	1678	c IF(MOD(itau,iecri*day_step).EQ.0) THEN
	1679	c$OMP BARRIER
	1680	c$OMP MASTER
	1681	nbetat = nbetatdem
[8]	1682	! ADAPTATION GCM POUR CP(T)
	1683	call tpot2t_p(ip1jmp1,llm,teta,temp,pk)
	1684	ijb=ij_begin
	1685	ije=ij_end
	1686	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
	1687	do l=1,llm
	1688	tsurpk(ijb:ije,llm)=cpp*temp(ijb:ije,llm)/
	1689	& pk(ijb:ije,llm)
	1690	enddo
	1691	!$OMP END DO
	1692	! CALL geopot_p(ip1jmp1,teta,pk,pks,phis,phi)
	1693	CALL geopot_p(ip1jmp1,tsurpk,pk,pks,phis,phi)
[1]	1694
	1695	cym unat=0.
	1696	ijb=ij_begin
	1697	ije=ij_end
	1698
	1699	if (pole_nord) then
	1700	ijb=ij_begin+iip1
	1701	unat(1:iip1,:)=0.
	1702	endif
	1703
	1704	if (pole_sud) then
	1705	ije=ij_end-iip1
	1706	unat(ij_end-iip1+1:ij_end,:)=0.
	1707	endif
	1708
	1709	do l=1,llm
	1710	unat(ijb:ije,l)=ucov(ijb:ije,l)/cu(ijb:ije)
	1711	enddo
	1712
	1713	ijb=ij_begin
	1714	ije=ij_end
	1715	if (pole_sud) ije=ij_end-iip1
	1716
	1717	do l=1,llm
	1718	vnat(ijb:ije,l)=vcov(ijb:ije,l)/cv(ijb:ije)
	1719	enddo
	1720
	1721	#ifdef CPP_IOIPSL
	1722	if (ok_dyn_ins) then
	1723	! Ehouarn: Gather fields and make master send to output
	1724	call Gather_Field(vcov,ip1jm,llm,0)
	1725	call Gather_Field(ucov,ip1jmp1,llm,0)
	1726	call Gather_Field(teta,ip1jmp1,llm,0)
	1727	call Gather_Field(phi,ip1jmp1,llm,0)
	1728	do iq=1,nqtot
	1729	call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
	1730	enddo
	1731	call Gather_Field(masse,ip1jmp1,llm,0)
	1732	call Gather_Field(ps,ip1jmp1,1,0)
	1733	call Gather_Field(phis,ip1jmp1,1,0)
	1734	if (mpi_rank==0) then
	1735	CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis)
	1736	endif
	1737	! CALL writehist_p(histid, histvid, itau,vcov ,
	1738	! & ucov,teta,phi,q,masse,ps,phis)
	1739	endif ! of if (ok_dyn_ins)
	1740	#endif
	1741	! For some Grads output (but does it work?)
	1742	if (output_grads_dyn) then
	1743	call Gather_Field(unat,ip1jmp1,llm,0)
	1744	call Gather_Field(vnat,ip1jm,llm,0)
	1745	call Gather_Field(teta,ip1jmp1,llm,0)
	1746	call Gather_Field(ps,ip1jmp1,1,0)
	1747	do iq=1,nqtot
	1748	call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
	1749	enddo
	1750	c
	1751	if (mpi_rank==0) then
	1752	#include "write_grads_dyn.h"
	1753	endif
	1754	endif ! of if (output_grads_dyn)
	1755
	1756	c$OMP END MASTER
	1757	ENDIF ! of IF(MOD(itau,iecri).EQ.0)
	1758
	1759	IF(itau.EQ.itaufin) THEN
[8]	1760	if (planet_type.eq."mars") then
	1761	! POUR MARS, METTRE UNE FONCTION A PART, genre dynredem1_mars
	1762	abort_message = 'dynredem1_mars A FAIRE'
	1763	call abort_gcm(modname,abort_message,0)
	1764	else
[1]	1765	c$OMP MASTER
	1766	CALL dynredem1_p("restart.nc",0.0,
	1767	. vcov,ucov,teta,q,masse,ps)
	1768	c$OMP END MASTER
[8]	1769	endif ! of if (planet_type.eq."mars")
[1]	1770	ENDIF ! of IF(itau.EQ.itaufin)
	1771
	1772	forward = .TRUE.
	1773	GO TO 1
	1774
	1775	ENDIF ! of IF (forward)
	1776
	1777	END IF ! of IF(.not.purmats)
	1778	c$OMP MASTER
	1779	call fin_getparam
	1780	call finalize_parallel
	1781	c$OMP END MASTER
	1782	RETURN
	1783	END

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

Download in other formats:

Original Format