43 use vrbls4d, only: dust, salt, soot, waso, suso, no3, nh4, pp25, pp10
44 use vrbls3d, only: u, v, t, q, uh, vh, wh, pmid, pmidv, pint, alpint, zmid, &
45 zint, q2, omga, t_adj, ttnd, rswtt, rlwtt, exch_h, train, tcucn, &
46 el_pbl, cwm, f_ice, f_rain, f_rimef, qqw, qqi, qqr, qqs,qqg, qqni, qqnr, &
47 extcof55, cfr, dbz, dbzr, dbzi, dbzc, mcvg, nlice, nrain, o3, vdifftt, &
48 tcucns, vdiffmois, dconvmois, sconvmois, nradtt, o3vdiff, o3prod, &
49 o3tndy, mwpv, unknown, vdiffzacce, zgdrag, cnvctummixing, vdiffmacce, &
50 mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, cnvctdetmflx,&
51 cnvctzgdrag, cnvctmgdrag, icing_gfip, asy, ssa, duem, dusd, dudp, &
52 duwt, suem, susd, sudp, suwt, ocem, ocsd, ocdp, ocwt, bcem, bcsd, &
53 bcdp, bcwt, ssem, sssd, ssdp, sswt, ext, dpres, rhomid, effri, effrl, &
55 use vrbls2d, only: wspd10max, w_up_max, w_dn_max, w_mean, refd_max, up_heli_max, &
56 prate_max, fprate_max, swupt, &
57 up_heli_max16, grpl_max, up_heli, up_heli16, ltg1_max, ltg2_max, &
58 up_heli_min, up_heli_min16, up_heli_max02, up_heli_min02, up_heli_max03, &
59 up_heli_min03, rel_vort_max, rel_vort_max01, wspd10umax, wspd10vmax, &
60 refdm10c_max, hail_max2d, hail_maxk1, ltg3_max,rel_vort_maxhy1, &
61 nci_ltg, nca_ltg, nci_wq, nca_wq, nci_refd, &
62 u10, v10, tshltr, qshltr, mrshltr, smstav, ssroff, bgroff, &
63 nca_refd, vegfrc, acsnow, acsnom, cmc, sst, qz0, thz0, uz0, vz0, qs, ths,&
64 sno, snonc, snoavg, psfcavg, t10m, t10avg, akmsavg, akhsavg, u10max, &
65 v10max, u10h, v10h, akms, akhs, cuprec, acprec, ancprc, cuppt, &
66 rainc_bucket, rainnc_bucket, pcp_bucket, snow_bucket, qrmax, tmax, &
67 snownc, graupelnc, tsnow, qvg, qv2m, rswin, rlwin, rlwtoa, tg, sfcshx, &
68 fis, t500, cfracl, cfracm, cfrach, acfrst, acfrcv, hbot, potevp, &
69 sfclhx, htop, aswin, alwin, aswout, alwout, aswtoa, alwtoa, czen, czmean,&
70 sigt4, rswout, radot, ncfrst, ncfrcv, smstot, pctsno, pshltr, th10, &
71 q10, sr, prec, subshx, snopcx, sfcuvx, sfcevp, z0, ustar, pblh, mixht, &
72 twbs, qwbs, sfcexc, grnflx, soiltb, z1000, slp, pslp, f, albedo, albase, &
73 cldfra, cprate, cnvcfr, ivgtyp, hbotd, htopd, hbots, isltyp, htops, &
74 cldefi, islope, si, lspa, rswinc, vis, pd, mxsnal, epsr, sfcux, &
75 sfcvx, sfcuxi, sfcvxi, avgalbedo, avgcprate, avgprec, ptop, pbot, avgcfrach, avgcfracm, &
76 avgcfracl, avgtcdc, auvbin, auvbinc, ptopl, pbotl, ttopl, ptopm, &
77 pbotm, ttopm, ptoph, pboth, ttoph, sfcugs, sfcvgs, pblcfr, cldwork, &
78 gtaux, gtauy, mdltaux, mdltauy, runoff, maxtshltr, mintshltr, &
79 maxrhshltr, minrhshltr, dzice, alwinc, alwoutc, alwtoac, aswinc, &
80 aswoutc,aswtoac, aswintoa, smcwlt, suntime, fieldcapa, avisbeamswin, &
81 avisdiffswin, airbeamswin, airdiffswin, snowfall, dusmass, ducmass, &
82 dusmass25, susmass, sucmass, susmass25, sucmass25, ocsmass, occmass, &
83 ocsmass25, occmass25, bcsmass, bccmass, bcsmass25, bccmass25, &
84 sssmass, sscmass, sssmass25, sscmass25, ducmass25, &
85 dustcb, sscb, bccb, occb, sulfcb, dustallcb, ssallcb,dustpm,sspm, pp25cb,&
86 no3cb, nh4cb, dustpm10, pp10cb, maod, ti
87 use soil, only: smc, stc, sh2o, sldpth, rtdpth, sllevel
88 use masks, only: htm, vtm, hbm2, sm, sice, lmh, gdlat, gdlon, dx, dy, lmv
89 use ctlblk_mod, only: me, num_procs, jm, jsta, jend, jsta_m, jsta_m2,ista,iend , &
90 jend_m, jend_m2, iup, idn, icnt, im, idsp, jsta_2l, jend_2u,idsp2,icnt2, &
91 jvend_2u, lm, lp1, jsta_2l, jend_2u, nsoil, nbin_du, nbin_ss, &
92 nbin_bc, nbin_oc, nbin_su, nbin_no3, nbin_nh4, &
93 ista_m,iend_m,ista_m2,iend_m2, ista_m,iend_m,ista_m2,iend_m2, &
94 ileft,iright,ileftb,irightb,ibsize,ibsum, isxa,iexa,jsxa,jexa, &
95 icoords,ibcoords,bufs,ibufs, rbufs, rcoords,rbcoords, &
96 ista_2l, iend_2u,ivend_2u,numx,modelname
105 integer ierr,i,jsx,jex,isx,iex,j
106 integer size,ubound,lbound
107 integer isumm,isum ,ii,jj,isumm2
108 integer ,
allocatable :: ibuff(:)
109 real ,
allocatable :: rbuff(:)
110 integer,
allocatable :: ipole(:),ipoles(:,:)
111 real ,
allocatable :: rpole(:),rpoles(:,:)
117 write(*,*)
' NUM_PROCS,NUMX,NUMY = ',num_procs,numx,num_procs/numx
120 if ( num_procs > 1024 )
then
121 print *,
' too many MPI tasks, max is 1024, stopping'
122 call mpi_abort(mpi_comm_world,1,ierr)
128 if ( num_procs > jm/2 )
then
129 print *,
' too many MPI tasks, max is ',jm/2,
' stopping'
130 call mpi_abort(mpi_comm_world,1,ierr)
145 call para_range2(im,jm,numx,num_procs/numx,me,ista,iend,jsta,jend)
161 if(mod(me,numx)==0)
then
166 if (me>=(num_procs-numx))
then
171 if(mod(me+1,numx)==0)
then
182 if ( me == num_procs - 1 )
then
193 allocate(icoords(im,jm))
194 allocate(rcoords(im,jm))
195 allocate(ibuff(im*jm))
196 allocate(rbuff(im*jm))
199 icoords(i,j)=10000*i+j
200 rcoords(i,j)=4000*i+j
209 allocate(isxa(0:num_procs-1) )
210 allocate(jsxa(0:num_procs-1) )
211 allocate(iexa(0:num_procs-1) )
212 allocate(jexa(0:num_procs-1) )
213 do i = 0, num_procs - 1
214 call para_range2(im,jm,numx,num_procs/numx,i,isx,iex,jsx,jex)
215 icnt(i) = ((jex-jsx)+1)*((iex-isx)+1)
223 if(jsx .eq. 1 .or. jex .eq. jm)
then
224 icnt2(i) = (iex-isx+1)
229 if(jsx .eq. 1 .or. jex .eq. jm) isumm2=isumm2+(iex-isx+1)
239 ibuff(isum)=icoords(ii,jj)
240 rbuff(isum)=rcoords(ii,jj)
249 jsta_2l = max(jsta - 2, 1 )
250 jend_2u = min(jend + 2, jm )
251 if(modelname==
'GFS')
then
252 ista_2l=max(ista-2,0)
253 iend_2u=min(iend+2,im+1)
255 ista_2l=max(ista-2,1)
256 iend_2u=min(iend+2,im)
260 jvend_2u = min(jend + 2, jm+1 )
269 if(mod(me,numx) .eq. 0) print *,
' LEFT POINT',me
270 if(mod(me+1,numx) .eq. 0) print *,
' RIGHT POINT',me
271 if(mod(me,numx) .eq. 0) ileft=mpi_proc_null
272 if(mod(me,numx) .eq. 0) ileftb=me+numx-1
273 if(mod(me+1,numx) .eq. 0 .or. me .eq. num_procs-1) iright=mpi_proc_null
274 if(mod(me+1,numx) .eq. 0 .or. me .eq. num_procs-1) irightb=me-numx+1
275 if(me .ge. numx) idn=me-numx
276 if(me+1 .le. num_procs-numx) iup=me+numx
278 print 102,me,ileft,iright,iup,idn,num_procs,
'GWVX BOUNDS'
282 ibsize = ( (iend-ista) +1) * ( (jend-jsta)+1)
283 allocate(ibcoords(ista_2l:iend_2u,jsta_2l:jend_2u))
284 allocate(rbcoords(ista_2l:iend_2u,jsta_2l:jend_2u))
285 allocate(ibufs(ibsize))
286 allocate(rbufs(ibsize))
287 call mpi_scatterv(ibuff,icnt,idsp,mpi_integer &
288 ,ibufs,icnt(me),mpi_integer ,0,mpi_comm_world,j)
289 call mpi_scatterv(rbuff,icnt,idsp,mpi_real &
290 ,rbufs,icnt(me),mpi_real ,0,mpi_comm_world,j)
298 ibcoords(i,j)=ibufs(isum)
299 rbcoords(i,j)=rbufs(isum)
307 ii=ibcoords(i,j)/10000
308 jj=ibcoords( i,j)-(ii*10000)
309 if(ii .ne. i .or. jj .ne. j)
then
310 print *,i,j,ii,jj,ibcoords(i,j),
' GWVX FAIL '
317 allocate(ipoles(im,2),ipole(ista:iend))
318 allocate(rpoles(im,2),rpole(ista:iend))
323 if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) ipole(i)=ibcoords(i,1)
324 if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) rpole(i)=rbcoords(i,1)
325 if(me .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) ipole(i)=ibcoords(i,jm)
326 if(me .gt. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) rpole(i)=rbcoords(i,jm)
329 if(me .lt. num_procs/2. .and. jsx .eq. 1)
then
332 if(me .gt. num_procs/2. .and. jend_2u .ge. jm)
then
338 print 105,
' GWVX GATHER DISP ',icnt2(me),idsp2(me),me
341 call mpi_gatherv(ipole(ista),icnt2(me),mpi_integer, ipoles,icnt2,idsp2,mpi_integer,0,mpi_comm_world, ierr )
342 call mpi_gatherv(rpole(ista),icnt2(me),mpi_real , rpoles,icnt2,idsp2,mpi_real ,0,mpi_comm_world, ierr )
348 jj=rpoles(i,j) -ii*4000
349 if(ii .ne. i .or. jj .ne. 1 .and. jj .ne. jm )
then
350 write(*,169)
' IPOLES BAD POINT',rpoles(i,j),ii,i,jj,
' jm= ',jm
359 107
format(a20,10i10)
360 169
format(a25,f20.1,3i10,a10,4i10)
362 print *,
' me, jsta_2l, jend_2u = ',me,jsta_2l, jend_2u, &
363 'jvend_2u=',jvend_2u,
'im=',im,
'jm=',jm,
'lm=',lm, &
365 write(*,
'(A,5I10)')
'MPI_FIRST me,jsta,jend,ista,iend,=',me,jsta,jend,ista,iend
375 subroutine fullpole(a,rpoles)
377 use ctlblk_mod, only: num_procs, jend, iup, jsta, idn, mpi_comm_comp, im,modelname,numx,&
378 icoords,ibcoords,rbcoords,bufs,ibufs,me, &
379 jsta_2l,jend_2u,ileft,iright,ista_2l,iend_2u,ista,iend,jm,icnt2,idsp2
385 real,
intent(inout) :: a ( ista_2l:iend_2u,jsta_2l:jend_2u ),rpoles(im,2)
386 real,
allocatable :: rpole(:)
388 integer status(mpi_status_size)
390 integer size,ubound,lbound
391 integer i,ii,jj, ibl,ibu,jbl,jbu,icc,jcc
395 data iwest,ieast/0,0/
396 allocate(rpole(ista:iend))
399 if(me .lt. num_procs/2. .and. jsta_2l .le. 1 .and. icnt2(me) .gt. 0) rpole(i)=a(i,1)
400 if(me .ge. num_procs/2. .and. jend_2u .ge. jm .and. icnt2(me) .gt. 0) rpole(i)=a(i,jm)
403 call mpi_allgatherv(rpole(ista),icnt2(me),mpi_real,rpoles,icnt2,idsp2,mpi_real, mpi_comm_comp,ierr)
405 call mpi_barrier(mpi_comm_comp,ierr)
subroutine mpi_first()
SUBPROGRAM: MPI_FIRST SET UP MESSGAE PASSING INFO PRGRMMR: TUCCILLO ORG: IBM.