subroutine rms_spect(qe_ls,xe_ls,ye_ls,we_ls,re_ls,
x qo_ls,xo_ls,yo_ls,wo_ls,ro_ls,
x ls_nodes,max_ls_nodes)
cc
cc September 24, 2004
cc version of rms_spect with ntrac generalized from 3.
cc
cc May 2, 2003
cc version of rms_spect with ntrac re_ls ro_ls.
cc
cc April 10, 2003
cc version of rms_spect with gather for each level.
cc
cc
use resol_def
use layout1
use namelist_def ! hmhj
use mpi_def
implicit none
cc
real(kind=kind_evod) qe_ls(len_trie_ls,2)
real(kind=kind_evod) xe_ls(len_trie_ls,2,levs)
real(kind=kind_evod) ye_ls(len_trie_ls,2,levs)
real(kind=kind_evod) we_ls(len_trie_ls,2,levs)
real(kind=kind_evod) re_ls(len_trie_ls,2,levs,ntrac)
cc
real(kind=kind_evod) qo_ls(len_trio_ls,2)
real(kind=kind_evod) xo_ls(len_trio_ls,2,levs)
real(kind=kind_evod) yo_ls(len_trio_ls,2,levs)
real(kind=kind_evod) wo_ls(len_trio_ls,2,levs)
real(kind=kind_evod) ro_ls(len_trio_ls,2,levs,ntrac)
cc
!mjr real(kind=kind_evod) del(levs)
cc
integer ls_nodes(ls_dim,nodes)
integer max_ls_nodes(nodes)
cc
integer ierr,j,k,l,lenrec,level,locl,n,node
cc
integer indev
integer indod
cc
real(kind=kind_evod) fgbar(3+ntrac+1)
cc
real(kind=kind_evod) fgbar_sav(3,levs)
cc
real(kind=kind_evod) fgbar_ntrac(ntrac,levs)
cc
!mjr real(kind=kind_evod) vx
!mjr real(kind=kind_evod) vy
!mjr real(kind=kind_evod) vw
!mjr real(kind=kind_evod) vr
cc
integer kmq
integer kmx
integer kmy
integer kmw
integer kmr
cc
integer indlsev,jbasev
integer indlsod,jbasod
cc
include 'function2'
cc
real(kind=kind_mpi),allocatable :: trieo_ls_node (:,:,:)
real(kind=kind_mpi),allocatable :: trieo_ls_nodes(:,:,:,:)
cc
integer node_l_all(0:jcap)
integer jbasev_l_all(0:jcap)
integer jbasod_l_all(0:jcap)
cc
real(kind=kind_evod) cons0,cons0p5 !constant
cc
cons0 = 0.d0 !constant
cons0p5 = 0.5d0 !constant
cc
kmq = 1 ! qe/o_ls
cc
kmx = 1+kmq ! xe/o_ls
kmy = 2+kmq ! ye/o_ls
kmw = 3+kmq ! we/o_ls
kmr = 4+kmq ! re/o_ls
cc
allocate ( trieo_ls_node ( len_trie_ls_max+len_trio_ls_max,
x 2, 3+ntrac+kmq ) )
cc
if ( me .eq. 0 ) then
allocate ( trieo_ls_nodes ( len_trie_ls_max+len_trio_ls_max,
x 2, 3+ntrac+kmq, nodes ) )
else
allocate ( trieo_ls_nodes ( 2, 2, 2, 2 ) )
endif
cc
do j=1,len_trie_ls
cc
trieo_ls_node(j,1,kmq) = qe_ls(j,1)
trieo_ls_node(j,2,kmq) = qe_ls(j,2)
cc
enddo
cc
do j=1,len_trio_ls
cc
trieo_ls_node(j+len_trie_ls_max,1,kmq) = qo_ls(j,1)
trieo_ls_node(j+len_trie_ls_max,2,kmq) = qo_ls(j,2)
cc
enddo
cc
do 2000 level=1,levs ! xxxxxxxxxxxxxxxxxxxx begin big level loop
cc
if ( level .eq. 2 ) then
cc
kmq = 0 ! qe/o_ls
cc
kmx = 1+kmq ! xe/o_ls
kmy = 2+kmq ! ye/o_ls
kmw = 3+kmq ! we/o_ls
kmr = 4+kmq ! re/o_ls
cc
if ( me .eq. 0 ) then
deallocate ( trieo_ls_nodes )
allocate ( trieo_ls_nodes ( len_trie_ls_max+len_trio_ls_max,
x 2, 3+ntrac+kmq, nodes ) )
endif
cc
endif
cc
do j=1,len_trie_ls
cc
trieo_ls_node(j,1,kmx) = xe_ls(j,1,level)
trieo_ls_node(j,2,kmx) = xe_ls(j,2,level)
cc
trieo_ls_node(j,1,kmy) = ye_ls(j,1,level)
trieo_ls_node(j,2,kmy) = ye_ls(j,2,level)
cc
trieo_ls_node(j,1,kmw) = we_ls(j,1,level)
trieo_ls_node(j,2,kmw) = we_ls(j,2,level)
cc
do k=1,ntrac
trieo_ls_node(j,1,kmr+k-1) = re_ls(j,1,level,k)
trieo_ls_node(j,2,kmr+k-1) = re_ls(j,2,level,k)
enddo
cc
enddo
cc
do j=1,len_trio_ls
cc
trieo_ls_node(j+len_trie_ls_max,1,kmx) = xo_ls(j,1,level)
trieo_ls_node(j+len_trie_ls_max,2,kmx) = xo_ls(j,2,level)
cc
trieo_ls_node(j+len_trie_ls_max,1,kmy) = yo_ls(j,1,level)
trieo_ls_node(j+len_trie_ls_max,2,kmy) = yo_ls(j,2,level)
cc
trieo_ls_node(j+len_trie_ls_max,1,kmw) = wo_ls(j,1,level)
trieo_ls_node(j+len_trie_ls_max,2,kmw) = wo_ls(j,2,level)
cc
do k=1,ntrac
trieo_ls_node(j+len_trie_ls_max,1,kmr+k-1) = ro_ls(j,1,level,k)
trieo_ls_node(j+len_trie_ls_max,2,kmr+k-1) = ro_ls(j,2,level,k)
enddo
cc
enddo
cc
lenrec = (len_trie_ls_max+len_trio_ls_max) * 2 * (3+ntrac+kmq)
cc
ccmr call mpi_barrier(mpi_comm_world,ierr)
cc
call mpi_gather( trieo_ls_node , lenrec, mpi_r_mpi,
x trieo_ls_nodes, lenrec, mpi_r_mpi,
x 0, mc_comp, ierr)
cc
ccmr call mpi_barrier(mpi_comm_world,ierr)
cc
if ( me .ne. 0 ) go to 2000
cc
do node=1,nodes
cc
jbasev=0
jbasod=len_trie_ls_max
ccmr do l = 0, jcap
do locl=1,max_ls_nodes(node)
l=ls_nodes(locl,node)
cc
node_l_all(l) = node
jbasev_l_all(l) = jbasev
jbasod_l_all(l) = jbasod
cc
jbasev=jbasev+(jcap+3-l)/2
jbasod=jbasod+(jcap+2-l)/2
end do
cc
end do
cc
do k=1,3+ntrac+kmq
cc
ccmr fgbar(k) = 0. !constant
fgbar(k) = cons0 !constant
cc
l=0
node = node_l_all(l)
jbasev = jbasev_l_all(l)
jbasod = jbasod_l_all(l)
cc
indev=indlsev(0,l)
indod=indlsod(1,l)
do n=0, jcap
if(mod(n+l,2).eq.0) then
fgbar(k) =
x fgbar(k) + trieo_ls_nodes(indev,1,k,node)
x * trieo_ls_nodes(indev,1,k,node)
indev=indev+1
else
fgbar(k) =
x fgbar(k) + trieo_ls_nodes(indod,1,k,node)
x * trieo_ls_nodes(indod,1,k,node)
indod=indod+1
endif
end do
cc
indev=indlsev(0,l)
indod=indlsod(1,l)
do n=0, jcap
if(mod(n+l,2).eq.0) then
fgbar(k) =
x fgbar(k) + trieo_ls_nodes(indev,2,k,node)
x * trieo_ls_nodes(indev,2,k,node)
indev=indev+1
else
fgbar(k) =
x fgbar(k) + trieo_ls_nodes(indod,2,k,node)
x * trieo_ls_nodes(indod,2,k,node)
indod=indod+1
endif
end do
cc
ccmr fgbar(k)=fgbar(k)*0.5 !constant
fgbar(k)=fgbar(k)*cons0p5 !constant
cc
do l=1, jcap
node = node_l_all(l)
jbasev = jbasev_l_all(l)
jbasod = jbasod_l_all(l)
cc
indev=indlsev(l ,l)
indod=indlsod(l+1,l)
do n=l, jcap
if(mod(n+l,2).eq.0) then
fgbar(k) =
x fgbar(k) + trieo_ls_nodes(indev,1,k,node)
x * trieo_ls_nodes(indev,1,k,node)
indev=indev+1
else
fgbar(k) =
x fgbar(k) + trieo_ls_nodes(indod,1,k,node)
x * trieo_ls_nodes(indod,1,k,node)
indod=indod+1
endif
end do
cc
indev=indlsev(l ,l)
indod=indlsod(l+1,l)
do n=l, jcap
if(mod(n+l,2).eq.0) then
fgbar(k) =
x fgbar(k) + trieo_ls_nodes(indev,2,k,node)
x * trieo_ls_nodes(indev,2,k,node)
indev=indev+1
else
fgbar(k) =
x fgbar(k) + trieo_ls_nodes(indod,2,k,node)
x * trieo_ls_nodes(indod,2,k,node)
indod=indod+1
endif
end do
cc
end do
cc
fgbar(k) = sqrt(fgbar(k))
cc
end do
cc
ccmr vx=0.e0 !constant
!mjr vx=cons0 !constant
ccmr vy=0.e0 !constant
!mjr vy=cons0 !constant
ccmr vw=0.e0 !constant
!mjr vw=cons0 !constant
ccmr vr=0.e0 !constant
!mjr vr=cons0 !constant
cc
!mjr do k=1,levs
!mjr vx=vx+fgbar(kmx+k-1)*del(k)
!mjr vy=vy+fgbar(kmy+k-1)*del(k)
!mjr vw=vw+fgbar(kmw+k-1)*del(k)
!mjr vr=vr+fgbar(kmr+k-1)*del(k)
!mjr end do
cc
if ( level .eq. 1 ) then
cc
if ( gen_coord_hybrid ) then ! hmhj
print 101,fgbar(kmq) ! hmhj
101 format(/ 1x,3x, ' rms_spect ps= ',1(es17.10,1x) /) ! hmhj
else ! hmhj
print 100,fgbar(kmq)
100 format(/ 1x,3x, ' rms_spect rms_ln(ps)= ',1(es17.10,1x) /)
endif ! hmhj
cc
print 50
50 format(1x,3x,
x ' rms_spect div',
x ' vort',
x ' temp')
cc
endif
cc
fgbar_sav(1,level) = fgbar(kmx)
fgbar_sav(2,level) = fgbar(kmw)
fgbar_sav(3,level) = fgbar(kmy)
!mjr fgbar_sav(4,level) = fgbar(kmr)
!mjr fgbar_sav(5,level) = fgbar(kmr+1)
!mjr fgbar_sav(6,level) = fgbar(kmr+2)
cc
do k=1,ntrac
fgbar_ntrac(k,level) = fgbar(kmr+k-1)
enddo
cc
print 200,level,
x fgbar(kmx), fgbar(kmw), fgbar(kmy)
ccmr x , ( fgbar(kmr+k-1), k=1,ntrac )
200 format(1x,i3,6(2x,es17.10))
cc
2000 continue ! xxxxxxxxxxxxxxxxxxxx end big level loop
cc
if ( me .eq. 0 ) then ! yyyyyyyyyyyy begin ntrac print
cc
print 52
52 format(/ 1x,3x,
x ' rms_spect mixratio',
x ' ozone',
x ' cld_liqo')
cc
do level=1,levs
print 200, level, (fgbar_ntrac(k,level),
x k=1,min(3,ntrac))
enddo
cc
cc----------------------------------------------------------------------
cc
do j=4,ntrac,4
cc
print 53, (k, ntrac, k=j,min(j+3,ntrac))
53 format(/ 1x,3x, 6(2x,i3,' of ntrac =',i3:))
cc
do level=1,levs
print 200, level, (fgbar_ntrac(k,level),
x k=j,min(j+3,ntrac))
enddo
cc
enddo
cc
cc----------------------------------------------------------------------
cc
print 54
54 format(/ ' fin rms_spect ' /)
cc
endif ! yyyyyyyyyyyy end ntrac print
cc
deallocate ( trieo_ls_node )
deallocate ( trieo_ls_nodes )
cc
return
end