Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

atm_comm.F @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 19.4 KB

Line
1	MODULE ATM_cc
2
3	USE CMP_COMM, ONLY: &
4
5	& MPI_COMM_Atmos => COMM_local, &
6
7	& Coupler_id, &
8	& component_master_rank_local, &
9	& process_rank_local, &
10	& component_nprocs, &
11	& ibuffer, &
12
13	& MPI_INTEGER,MPI_STATUS_SIZE, &
14	& kind_REAL,kind_alt_REAL, &
15	& MPI_kind_REAL,MPI_kind_alt_REAL
16
17	implicit none
18
19	integer,parameter:: ND=2
20	integer Ocean_spec /-1/, WM_id /-10/
21	integer NSF
22	integer NSF_WM
23	real dtc, & !<- Coupling period
24	& dta, & !<- AM time step ("physical")
25	& dta2dtc !<- AM time step / Coupling period
26	integer i_dtc2dta /100/ !<- Coupling period / AM time step
27	integer & !,dimension(ND)::
28	&ims,ime,jms,jme,its,ite,jts,jte,ids,idf,jds,jdf, NGP
29	integer kms,kme,kts,kte,kds,kde
30	integer,parameter:: kind_R=kind_alt_REAL
31	!c integer,parameter:: kind_tiling=kind_R
32	integer,parameter:: kind_sfcflux=kind_R, &
33	& kind_SST=kind_R, &
34	& kind_SLM=kind_R, &
35	& kind_lonlat=kind_R
36	integer MPI_kind_R, &
37	&MPI_kind_sfcflux,MPI_kind_SST,MPI_kind_SLM,MPI_kind_lonlat
38	integer n_ts(ND) /0,0/, gid
39	integer rc /5/
40	real,parameter:: &
41	& SLM_OS_value=1., &!<-must be real open sea mask value in AM
42	& unrealistically_low_SST=0.01, & ! <- must be unreal low but >=0.,
43	! see interp. --- check!
44	& unrealistically_low_SV=-1.E30, &
45	! <- must be negative unreal low surface flux
46	! or other surface value to be sent
47	! to Coupler, see Coupler code
48	& unrealistically_low_SF=unrealistically_low_SV, & !<- same thing
49	& unrealistically_low_SVp=0.99*unrealistically_low_SV
50
51	logical initialized /.false./
52	logical PHYS,zeroSF,nrmSF,sendSF,getSST
53
54	TYPE SST_ARRAY
55	real(kind=kind_SST),dimension(:,:),pointer:: a
56	END TYPE SST_ARRAY
57	TYPE SF_ARRAY
58	real(kind=kind_sfcflux),dimension(:,:,:),pointer:: a
59	END TYPE SF_ARRAY
60
61	TYPE (SST_ARRAY), dimension(ND):: SST_cc
62	TYPE (SF_ARRAY), dimension(ND):: sf
63
64	character*12 sgid
65
66	!Controls:
67	integer nunit_announce /6/, VerbLev /3/
68
69	SAVE
70
71	END MODULE ATM_cc
72	!C
73	!C***********************************************************************
74	!C
75	SUBROUTINE ATM_CMP_START(atm_comm)
76
77	USE ATM_cc
78
79	implicit none
80
81	integer atm_comm
82
83	integer Atmos_id /1/, Atmos_master_rank_local /0/, Atmos_spec /1/
84	integer ibuf(1),ierr
85	character*20 s
86	!C
87
88	!<-id of OM as a component of the coupled system
89	call CMP_INIT(Atmos_id,1)
90	!<-"flexibility level"
91	if (Coupler_id.ge.0) VerbLev=min(VerbLev,ibuffer(4))
92	write(s,'(i2)') VerbLev
93
94	call CMP_INTRO(Atmos_master_rank_local)
95	call ATM_ANNOUNCE('back from CMP_INTRO, VerbLev='//s,2)
96
97	initialized=.true.
98
99	call CMP_INTEGER_SEND(Atmos_spec,1)
100
101	call CMP_gnr_RECV(Ocean_spec,1,MPI_INTEGER)
102	write(s,'(i2)') Ocean_spec
103	call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, OM spec is '//s,2)
104	call MPI_BCAST(Ocean_spec,1,MPI_INTEGER, &
105	&component_master_rank_local,MPI_COMM_Atmos,ierr)
106	call ATM_ANNOUNCE('ATM_CMP_START: Ocean_spec broadcast',2)
107
108	call CMP_gnr_RECV(WM_id,1,MPI_INTEGER)
109	write(s,'(i2)') WM_id
110	call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, WM id is '//s,2)
111	call MPI_BCAST(WM_id,1,MPI_INTEGER, &
112	&component_master_rank_local,MPI_COMM_Atmos,ierr)
113	call ATM_ANNOUNCE('ATM_CMP_START: WM_id broadcast',2)
114	if (WM_id.gt.0) then
115	NSF_WM=2
116	else
117	NSF_WM=0
118	end if
119
120	if (Ocean_spec.eq.1) then
121	NSF=4+NSF_WM
122	else if (Ocean_spec.eq.2) then
123	NSF=8+NSF_WM
124	else if (Ocean_spec.eq.0) then
125	NSF=NSF_WM
126	else if (Coupler_id.ge.0) then
127	call GLOB_ABORT(Ocean_spec-1, &
128	& 'ATM_CMP_START received wrong Ocean_spec value, aborted',rc)
129	else
130	Ocean_spec=1
131	NSF=4
132	call ATM_ANNOUNCE('AM is standalone: Ocean_spec=1, NSF=4'// &
133	& ' assigned (as if for POM coupling)',2)
134	end if
135
136	if (kind_R.eq.kind_REAL) then
137	MPI_kind_R=MPI_kind_REAL
138	else
139	MPI_kind_R=MPI_kind_alt_REAL
140	end if
141	if (kind_sfcflux.eq.kind_REAL) then
142	MPI_kind_sfcflux=MPI_kind_REAL
143	else
144	MPI_kind_sfcflux=MPI_kind_alt_REAL
145	end if
146	if (kind_SST.eq.kind_REAL) then
147	MPI_kind_SST=MPI_kind_REAL
148	else
149	MPI_kind_SST=MPI_kind_alt_REAL
150	end if
151	if (kind_SLM.eq.kind_REAL) then
152	MPI_kind_SLM=MPI_kind_REAL
153	else
154	MPI_kind_SLM=MPI_kind_alt_REAL
155	end if
156	if (kind_lonlat.eq.kind_REAL) then
157	MPI_kind_lonlat=MPI_kind_REAL
158	else
159	MPI_kind_lonlat=MPI_kind_alt_REAL
160	end if
161
162	atm_comm=MPI_COMM_Atmos
163
164	return
165	END
166	!C
167	!C***********************************************************************
168	!C
169	SUBROUTINE ATM_INIT_CHECK(s)
170
171	USE ATM_cc, ONLY: initialized,rc
172
173	implicit none
174
175	character() s
176
177	if (.not. initialized) call GLOB_ABORT(1,s,rc)
178
179	return
180	END
181	!C
182	!C***********************************************************************
183	!C
184	subroutine ATM_TSTEP_INIT(NTSD,NPHS,gid_,dta_, &
185	&ids_,idf_,jds_,jdf_,its_,ite_,jts_,jte_,ims_,ime_,jms_,jme_, &
186	!<-"domain" !<-"tile" !<-"memory" (tile+halo)
187	&kds_,kde_,kts_,kte_,kms_,kme_, &
188	&HLON,HLAT,VLON,VLAT, &
189	&SLM, &
190	&i_parent_start,j_parent_start)
191
192	USE ATM_cc
193
194	implicit none
195
196	integer NTSD,NPHS,gid_
197	real dta_
198	integer ids_,idf_,jds_,jdf_,its_,ite_,jts_,jte_, &
199	&ims_,ime_,jms_,jme_,kds_,kde_,kts_,kte_,kms_,kme_
200	real(kind=kind_lonlat),dimension(ims_:ime_,jms_:jme_):: &
201	&HLON,HLAT,VLON,VLAT
202	real(kind=kind_SLM),dimension(ims_:ime_,jms_:jme_):: SLM
203	integer i_parent_start,j_parent_start
204
205	integer KDT,buf(2) /0,0/
206	character*24 s
207	character*80 s1
208
209	SAVE
210	!C
211
212	gid=gid_
213	call GLOB_ABORT((gid-1)*(gid-2), &
214	&'Abort: in ATM_TSTEP_INIT gid is neither 1 nor 2',rc)
215	KDT=NTSD/NPHS+1
216	PHYS=MOD(NTSD,NPHS).eq.0 ! .and. gid.eq.1 <-removed to bring MG in
217	dta=dta_
218
219	write(s1,'("gid=",i1," NTSD=",i5," NPHS=",i3," KDT=",i5,'// &
220	&'" PHYS=",L1)') gid,NTSD,NPHS,KDT,PHYS
221	call ATM_ANNOUNCE('ATM_TSTEP_INIT entered: '//trim(s1),3)
222
223	!c IF (n_ts.eq.-1 .and. PHYS) THEN
224	!c PHYS=.false.
225	!c n_ts=0 ! init. value must be -1 . But if PHYS does not need
226	!c ! this correction, init. value must be 0 (whereas this
227	!c ! IF statement may stay)
228	!c END IF
229	if (.not.PHYS) then
230	zeroSF=.false.
231	nrmSF=.false.
232	sendSF=.false.
233	RETURN
234	end if
235
236	n_ts(gid)=n_ts(gid)+1 ! init. value must be 0 *0*
237	write(s,'(2i8)') KDT,n_ts(gid)
238	write(sgid,'(" grid id = ",i1)') gid
239	call ATM_ANNOUNCE('ATM_TSTEP_INIT working:'// &
240	&sgid//'; KDT, n_ts: '//s,3)
241	call GLOB_ABORT(KDT-n_ts(gid), &
242	&'Abort: in ATM_TSTEP_INIT KDT, n_ts(gid) differ '//s,rc)
243
244	call ATM_RECVdtc
245
246	zeroSF=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
247	nrmSF=(n_ts(gid)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)
248	sendSF=(n_ts(gid)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)
249	!<-check, this depends
250	! on where ATM_SENDFLUXES is called.
251	! MOD(n_ts,i_dtc2dta).eq.0 should
252	! be good for calling it after
253	! ATM_DOFLUXES at the same t.s.
254
255	ids=ids_
256	idf=idf_
257	jds=jds_
258	jdf=jdf_
259	its=its_
260	ite=ite_
261	jts=jts_
262	jte=jte_
263	ims=ims_
264	ime=ime_
265	jms=jms_
266	jme=jme_
267
268	kds=kds_
269	kde=kde_
270	kts=kts_
271	kms=kms_
272	kme=kme_
273	kte=kte_
274
275	NGP=(idf-ids+1)*(jdf-jds+1)
276
277	call ATM_ANNOUNCE('ATM_TSTEP_INIT to allocate sf, SST_cc',3)
278
279	IF (n_ts(gid).eq.1) THEN
280	allocate(sf(gid)%a(ims:ime,jms:jme,NSF))
281	allocate(SST_cc(gid)%a(ims:ime,jms:jme))
282	END IF
283
284	if (gid.eq.2) then
285	write(s,'(2i8)') i_parent_start,j_parent_start
286	if (zeroSF) then
287	buf(1)=i_parent_start
288	buf(2)=j_parent_start
289	call CMP_INTEGER_SEND(buf,2)
290	call ATM_ANNOUNCE( &
291	& 'ATM_TSTEP_INIT: i_parent_start, j_parent_start sent '//s,3)
292	else
293	call GLOB_ABORT(abs(i_parent_start-buf(1))+abs(j_parent_start- &
294	& buf(2)),'NESTED GRID MOVED DURING C TIME STEP: ABORTED '// &
295	& s,rc)
296	end if
297	end if
298
299	CALL ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
300
301	CALL ATM_SENDSLM(SLM)
302
303	if (VerbLev.ge.2) print*,'AM: ATM_TSTEP_INIT: returning ',gid, &
304	&n_ts(gid),ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme,NGP,NSF
305
306	RETURN
307	end
308	!C
309	!C***********************************************************************
310	!C
311	SUBROUTINE ATM_RECVdtc
312
313	USE ATM_cc
314
315	implicit none
316
317	real(kind=kind_R) buf(1),dtc2dta
318	integer ierr,i
319	logical first/.true./
320	character*20 s
321	SAVE
322	!C
323
324	write(s,'(1pe20.12)') dta
325	call ATM_ANNOUNCE('ATM_RECVdtc: AM time step dta='//s,3)
326
327	IF (first) THEN
328	call ATM_ANNOUNCE( &
329	& 'ATM_RECVdtc: to receive C time step; AM time step dta='//s,2)
330
331	call CMP_gnr_RECV(buf,1,MPI_kind_R)
332
333	call MPI_BCAST(buf,1,MPI_kind_R, &
334	& component_master_rank_local,MPI_COMM_Atmos,ierr)
335	call ATM_ANNOUNCE('ATM_RECVdtc: C time step broadcast',2)
336	dtc=buf(1)
337
338	if (Coupler_id.lt.0) then
339	if (gid.eq.1) then
340	dtc=dta*2 ! just having in mind that with gid=1
341	else ! dta value is 5 times its value with
342	dtc=dta*10 ! gid=2 (at this moment, 270s and 54s
343	end if ! respectively)
344	write(s,'(1pe20.12)') dtc
345	call ATM_ANNOUNCE('ATM_RECVdtc: C time step assigned '// &
346	& trim(s)//' : standalone mode',2)
347	else
348	write(s,'(1pe20.12)') buf
349	call ATM_ANNOUNCE( &
350	& 'ATM_RECVdtc: C time step dtc='//s//' received',2)
351	end if
352	END IF
353
354	dtc2dta=dtc/dta
355	i_dtc2dta=nint(dtc2dta)
356	if (abs(i_dtc2dta-dtc2dta).gt.1.E-5) call GLOB_ABORT(1, &
357	&'AM: ABORTED: dtc is not a multiple of dta',1)
358
359	i=3
360	if (n_ts(gid).eq.1) i=2
361	if (i_dtc2dta.eq.0) then
362	i_dtc2dta=4
363	call ATM_ANNOUNCE('ratio of C/AM time steps =0, assigned 4 .'// &
364	& ' This should only occur in standalone mode and ONLY IF dtc '// &
365	& 'HAS NOT BEEN ASSIGNED A POSITIVE VALUE: ATTENTION ',i)
366	else
367	write(s,'(i2)') i_dtc2dta
368	call ATM_ANNOUNCE('ratio of C/AM time steps: '//trim(s),i)
369	end if
370
371	dta2dtc=1./i_dtc2dta
372
373	first=.false.
374
375	RETURN
376	END
377	!C
378	!C***********************************************************************
379	!C
380	SUBROUTINE ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
381
382	USE ATM_cc
383
384	implicit none
385
386	real(kind=kind_lonlat),dimension(ims:ime,jms:jme):: &
387	&HLON,HLAT,VLON,VLAT
388
389	real(kind=kind_lonlat),dimension(ids:idf,jds:jdf):: &
390	&ALONt,ALATt,ALONv,ALATv
391
392	integer buf(2)
393	!C
394
395	!c IF (gid.ne.1) RETURN ! only "parent grid" dim. and coor. are sent
396
397	IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
398
399	!temporarily excluded if (Coupler_id.lt.0) return ! <- standalone mode
400
401	buf(1)=idf-ids+1
402	buf(2)=jdf-jds+1
403	call ATM_ANNOUNCE('to send grid dimensions,'//sgid,1)
404	call CMP_INTEGER_SEND(buf,2)
405	call ATM_ANNOUNCE('grid dimensions sent,'//sgid,1)
406
407	!c IF (gid.eq.1) THEN ! only "parent grid" coordinates are sent
408
409	call ASSEMBLE(ALONt,HLON,kind_lonlat)
410	call ASSEMBLE(ALATt,HLAT,kind_lonlat)
411	call ASSEMBLE(ALONv,VLON,kind_lonlat)
412	call ASSEMBLE(ALATv,VLAT,kind_lonlat)
413
414	call ATM_ANNOUNCE('(BP) to send grid arrays (4 MPI calls)',2)
415
416	call CMP_gnr_SEND(ALONt,NGP,MPI_kind_lonlat)
417	call CMP_gnr_SEND(ALATt,NGP,MPI_kind_lonlat)
418	call CMP_gnr_SEND(ALONv,NGP,MPI_kind_lonlat)
419	call CMP_gnr_SEND(ALATv,NGP,MPI_kind_lonlat)
420
421	call ATM_ANNOUNCE('the 4 grid arrays sent',1)
422
423	!c END IF
424
425	call ATM_ANNOUNCE('(BP) ATM_SENDGRIDS: returning',2)
426
427	return
428	END
429	!C
430	!C***********************************************************************
431	!C
432	SUBROUTINE ATM_SENDSLM(SLM)
433
434	USE ATM_cc
435
436	implicit none
437
438	real(kind=kind_SLM),dimension(ims:ime,jms:jme):: SLM
439
440	real(kind=kind_SLM),dimension(ids:idf,jds:jdf):: SLM_g
441	integer buf(2)
442	!C
443
444	!c IF (gid.ne.1) RETURN ! only "parent grid" mask is sent
445	IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
446
447	!temporarily excluded if (Coupler_id.lt.0) return ! <- standalone mode
448
449	call ASSEMBLE(SLM_g,SLM,kind_SLM)
450
451	call ATM_ANNOUNCE('(BP) to send SLM',2)
452
453	call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
454	call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
455	! Coupler requires as many copies of mask as there are grids
456
457	call ATM_ANNOUNCE('(BP) ATM_SENDSLM: returning',2)
458
459	return
460	END
461	!C
462	!C***********************************************************************
463	!C
464	SUBROUTINE ATM_GETSST(SST,SLM)
465
466	USE ATM_cc
467
468	implicit none
469
470	real(kind=kind_SST) SST(ims:ime,jms:jme)
471	real(kind=kind_SLM) SLM(ims:ime,jms:jme)
472
473	integer i,j
474	real(kind=kind_SST) SST_g(ids:idf,jds:jdf)
475	!C
476
477	IF (.not.PHYS) RETURN
478
479	call ATM_ANNOUNCE('ATM_GETSST entered (PHYS=.true.)',3)
480
481	getSST=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
482	if (getSST.neqv.zeroSF) then
483	call GLOB_ABORT(1,'getSST differs from zeroSF, which screws'// &
484	& ' up the design for exchanges with C',rc)
485	end if
486
487	if (getSST) then
488	if (n_ts(gid).eq.1 .and. gid.eq.1) then
489	call ATM_ANNOUNCE('ATM_GETSST: to send ref. SST'//sgid,2)
490	call ASSEMBLE(SST_g,SST,kind_SST)
491	call CMP_gnr_SEND(SST_g,NGP,MPI_kind_SST)
492	call ATM_ANNOUNCE('ATM_GETSST: ref. SST sent'//sgid,2)
493	end if
494	call ATM_ANNOUNCE('ATM_GETSST: to receive SST',3)
495	call CMP_gnr_RECV(SST_g,NGP,MPI_kind_SST)
496	call DISASSEMBLE(SST_g,SST_cc(gid)%a,kind_SST)
497	call ATM_ANNOUNCE('ATM_GETSST: SST received',3)
498	end if
499
500	if (Coupler_id.lt.0) return ! <- standalone mode
501
502	do j=jts,jte
503	do i=its,ite
504	if (abs(SLM(i,j)-SLM_OS_value).lt.0.01) then
505	! i.e. if it is OS (open sea) AMGP
506	!
507	if (SST_cc(gid)%a(i,j).gt.unrealistically_low_SST) &
508	! i.e. if there is a valid
509	! result of interpolation from
510	! OMG for this AMGP
511	& SST(i,j)=SST_cc(gid)%a(i,j)
512	end if
513	end do
514	end do
515
516	return
517	END
518	!C
519	!C***********************************************************************
520	!C
521	SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
522	!c &USTAR,U10,V10,PINT,PREC)
523	&TX,TY,PINT,PREC,U10,V10)
524
525	USE ATM_cc
526
527	implicit none
528
529	real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: &
530	&TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PINT,PREC,U10,V10
531	!c &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,USTAR,U10,V10,PINT,PREC
532	! Act. arg. for PINT is a 3d array - so this only is OK if
533	! Ps=Act.arg.(:,:.1) - actually, Ps=PINT(:,1,:)
534
535	real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: SWR,R
536	real dtainv
537	!C
538
539	IF (.not.PHYS) RETURN
540	! Debug insertion:->
541	!c if (PREC(ims+3,jms+3).ne.0 .or. PREC(ims+5,jms+5).ne.0) then
542	!c print*,'ATM_DOFLUXES,gid,n_ts(gid),PREC(3,3),PREC(5,5): ',
543	!c & gid,n_ts(gid),PREC(ims+3,jms+3),PREC(ims+5,jms+5)
544	!c end if
545	! <-:Debug insertion
546
547	call ATM_ANNOUNCE('ATM_DOFLUXES entered',3)
548
549	dtainv=1./dta
550
551	if (zeroSF) sf(gid)%a=0.
552
553	SWR=-RSWIN+RSWOUT ! Check sign! here SWR is meant to be
554	! positive upward
555	!c sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)-TX
556	!c sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)-TY
557	!c ! <- signs for stress components are changed
558	!c ! so it is -stress
559
560	!c R=SWR+RADOT-RLWIN ! Check sign! here R (net radiation)
561	! is meant to be positive upward
562
563	!oooooooooooooooooooooooooooooo
564	IF (Ocean_spec.eq.1) THEN
565	!oooooooooooooooooooooooooooooo
566	sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)-TWBS-QWBS+RADOT-RLWIN
567	! -TWBS (-QWBS) is supposed to
568	! be sensible (latent) heat flux,
569	! positive upward
570	sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)+SWR
571	sf(gid)%a(:,:,NSF-NSF_WM-1)=sf(gid)%a(:,:,NSF-NSF_WM-1)-TX
572	sf(gid)%a(:,:,NSF-NSF_WM)=sf(gid)%a(:,:,NSF-NSF_WM)-TY
573	! <- signs for stress components are changed
574	!ooooooooooooooooooooooooooooooooooo
575	ELSE IF (Ocean_spec.eq.2) THEN
576	!ooooooooooooooooooooooooooooooooooo
577	sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)+PREC
578	sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)-TWBS
579	sf(gid)%a(:,:,3)=sf(gid)%a(:,:,3)-QWBS
580	sf(gid)%a(:,:,4)=sf(gid)%a(:,:,4)+PINT-101300.
581	sf(gid)%a(:,:,5)=sf(gid)%a(:,:,5)-SWR-RADOT+RLWIN
582	sf(gid)%a(:,:,6)=sf(gid)%a(:,:,6)-SWR
583
584	sf(gid)%a(:,:,NSF-NSF_WM-1)=sf(gid)%a(:,:,NSF-NSF_WM-1)+TX
585	sf(gid)%a(:,:,NSF-NSF_WM)=sf(gid)%a(:,:,NSF-NSF_WM)+TY
586	! <- signs for stress components are NOT changed
587	if (nrmSF) then
588	sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)*dtainv
589	! so this will be m/s; check what OM wants
590	end if
591	!ooooooooooo
592	END IF
593	!ooooooooooo
594
595
596	!wwwwwwwwwwwwwwwwwwwwwwwww
597	IF (WM_id.gt.0) THEN
598	!wwwwwwwwwwwwwwwwwwwwwwwww
599	sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)+U10
600	sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)+V10
601	!wwwwwwwwwww
602	END IF
603	!wwwwwwwwwww
604
605	if (nrmSF) then
606	sf(gid)%a=sf(gid)%a*dta2dtc
607	end if
608
609	call ATM_ANNOUNCE('ATM_DOFLUXES to return',3)
610
611	return
612	END
613	!C
614	!C***********************************************************************
615	!C
616	SUBROUTINE ATM_SENDFLUXES
617
618	USE ATM_cc
619
620	implicit none
621
622	real(kind=kind_sfcflux) F(ids:idf,jds:jdf)
623	integer n
624	!C
625
626	if (.not.PHYS) RETURN
627
628	if (.not.sendSF) then
629	call ATM_ANNOUNCE( &
630	& 'ATM_SENDLUXES entered with PHYS but not sendSF: returning'// &
631	& sgid,3)
632	RETURN
633	end if
634
635	call ATM_ANNOUNCE('In ATM_SENDLUXES'//sgid,3)
636
637	do n=1,NSF
638	call ASSEMBLE(F,sf(gid)%a(:,:,n),kind_sfcflux)
639	call CMP_gnr_SEND(F,NGP,MPI_kind_sfcflux)
640	end do
641
642	call ATM_ANNOUNCE('ATM_SENDFLUXES to return'//sgid,3)
643
644	return
645	END
646	!C
647	!C***********************************************************************
648	!C
649	SUBROUTINE ATM_ANNOUNCE(s,DbgLev)
650
651	USE ATM_cc, ONLY: nunit_announce,VerbLev,MPI_COMM_Atmos
652
653	implicit none
654
655	character() s
656	integer DbgLev
657
658	integer ierr
659	!C
660	if (DbgLev.le.VerbLev) then
661	if (s(1:5).eq.'(BP) ') then
662	call MPI_BARRIER(MPI_COMM_Atmos,ierr)
663	end if
664	CALL CMP_ANNOUNCE(nunit_announce,'AM: '//s)
665	end if
666
667	return
668	END

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

Download in other formats:

Original Format