module zrnmi_mod
!$$$ module documentation block
! . . . .
! module: zrnmi_mod
!
! abstract: Contains all routines necessary for regional normal mode
! projection/initialization. These tools are used to
! implement weak and strong dynamic constraints.
!
! The normal modes are based on double sine series
! expansions, following briere, ??add ref here.
!
! In this version, fields are first multiplied by a boundary
! function which smoothly reduces fields to zero at first point outside domain.
!
! program history log:
! 2006-11-03 parrish
! 2008-03-26 safford -- rm unused vars, add subroutine doc blocks
! 2011-07-04 todling - fixes to run either single or double precision
!
! subroutines included:
! sub zrnmi_initialize ---
! sub zrnmi_sd2x0 --- setup to convert from subdomains to x direction
! sub zrnmi_sd2x1 --- additional setup
! sub zrnmi_x2sd1 --- additional setup
! sub zrnmi_sd2x2 --- subdomains to x
! sub zrnmi_sd2x3 --- subdomains to x
! sub zrnmi_x2sd --- x to subdomains
! sub zrnmi_x2sd2 --- x to subdomains
! sub zrnmi_x2sd3 --- x to subdomains
!
! following required for finite difference derivatives and laplacians
! sub zrnmi_sd2y0 --- setup to convert from subdomains to y direction
! sub zrnmi_sd2y1 --- additional setup
! sub zrnmi_y2sd1 --- additional setup
! sub zrnmi_sd2y2 --- subdomains to y
! sub zrnmi_y2sd2 --- y to subdomains
!
! sub zrnmi_x_strans0 - initialize constants for x transforms
! sub zrnmi_x_strans - sin trans in x direction from grid to spectral
!
! sub zrnmi_uvm2dzmhat
! sub zrnmi_uvm2dzmhat_ad
! sub zrnmi_pcmhat2uvm
! sub zrnmi_pcmhat2uvm_orig
! sub zrnmi_pcmhat2uvm_ad_orig
! sub zrnmi_pcmhat2uvm_ad
!
! sub zrnmi_x2y0 - setup to convert from x to y
! sub zrnmi_x2y1 - additional setup for x to y
! sub zrnmi_x2y3 - x to y
! sub zrnmi_y2x3 - y to x
!
! sub zrnmi_y_strans0 - initialize constants for y transforms
! sub zrnmi_y_strans - almost copy of zrnmi_x_strans
!
! sub zrnmi_delx_general
! * sub zrnmi_delx - equivalent(*) to delx_reg in psichi2uv_reg.f90, but more scalable
! * sub zrnmi_delx_ad - equivalent(*) to tdelx_reg in psichi2uvt_reg.f90, but more scalable
! sub zrnmi_dely_general
! * sub zrnmi_dely - equivalent(*) to dely_reg in psichi2uv_reg.f90, but more scalable
! * sub zrnmi_dely_ad - equivalent(*) to tdely_reg in psichi2uvt_reg.f90, but more scalable
! (*) : except corner points are treated differently.
!
! sub zrnmi_uv2dz
! sub zrnmi_uv2dz_ad
! sub zrnmi_pc2uv_orig
! sub zrnmi_pc2uv_ad_orig
! sub zrnmi_constants
! sub zrnmi_strong_bal_correction
! sub zrnmi_strong_bal_correction_ad
! sub zrnmi_filter_uvm
! sub zrnmi_filter_uvm_ad
! sub zrnmi_filter_uvm2
! sub zrnmi_filter_uvm2_ad
! sub zrnmi_uvm2uvmhat
! sub zrnmi_uvm2uvmhat_ad
! sub zrnmi_uvmhat2uvm
! sub zrnmi_uvmhat2uvm_ad
!
! Variable Definitions:
!
! attributes:
! language: f90
! machine: ibm RS/6000 SP
!
!$$$ end documentation block
use kinds, only: r_kind,i_kind
use constants, only: pi
implicit none
! set default to private
private
! set subroutines to public
public :: zrnmi_initialize
public :: zrnmi_sd2x0
public :: zrnmi_sd2x1
public :: zrnmi_x2sd1
public :: zrnmi_sd2x2
public :: zrnmi_sd2x3
public :: zrnmi_x2sd
public :: zrnmi_x2sd2
public :: zrnmi_x2sd3
public :: zrnmi_sd2y0
public :: zrnmi_sd2y1
public :: zrnmi_y2sd1
public :: zrnmi_sd2y2
public :: zrnmi_y2sd2
public :: zrnmi_x_strans0
public :: zrnmi_x_strans
public :: zrnmi_uvm2dzmhat
public :: zrnmi_uvm2dzmhat_ad
public :: zrnmi_pcmhat2uvm
public :: zrnmi_pcmhat2uvm_orig
public :: zrnmi_pcmhat2uvm_ad_orig
public :: zrnmi_pcmhat2uvm_ad
public :: zrnmi_x2y0
public :: zrnmi_x2y1
public :: zrnmi_x2y3
public :: zrnmi_y2x3
public :: zrnmi_y_strans0
public :: zrnmi_y_strans
public :: zrnmi_delx_general
public :: zrnmi_delx
public :: zrnmi_delx_ad
public :: zrnmi_dely_general
public :: zrnmi_dely
public :: zrnmi_dely_ad
public :: zrnmi_uv2dz
public :: zrnmi_uv2dz_ad
public :: zrnmi_pc2uv_orig
public :: zrnmi_pc2uv_ad_orig
public :: zrnmi_constants
public :: zrnmi_strong_bal_correction
public :: zrnmi_strong_bal_correction_ad
public :: zrnmi_filter_uvm
public :: zrnmi_filter_uvm_ad
public :: zrnmi_filter_uvm2
public :: zrnmi_filter_uvm2_ad
public :: zrnmi_uvm2uvmhat
public :: zrnmi_uvm2uvmhat_ad
public :: zrnmi_uvmhat2uvm
public :: zrnmi_uvmhat2uvm_ad
integer(i_kind) nx,ny
integer(i_kind) nvert
! communication info for sd <--> x strips
integer(i_kind) ny_0,ny_1
integer(i_kind),allocatable::list_sd2x(:,:) ! list_sd2x(1,j) = y index for x strip j
! list_sd2x(2,j) = vert index for x strip j
! list_sd2x(3,j) = pe of this y/vert index strip
integer(i_kind),dimension(:),allocatable::nsend_sd2x,nrecv_sd2x,ndsend_sd2x,ndrecv_sd2x
integer(i_kind) nallsend_sd2x,nallrecv_sd2x
integer(i_kind),allocatable:: info_send_sd2x(:,:),info_recv_sd2x(:,:)
integer(i_kind),dimension(:),allocatable::nsend_x2sd,nrecv_x2sd,ndsend_x2sd,ndrecv_x2sd
integer(i_kind) nallsend_x2sd,nallrecv_x2sd
integer(i_kind),allocatable:: info_send_x2sd(:,:),info_recv_x2sd(:,:)
! communication info for sd <--> y strips
integer(i_kind) nx_0,nx_1
integer(i_kind),allocatable::list_sd2y(:,:) ! list_sd2y(1,j) = x index for y strip j
! list_sd2y(2,j) = vert index for y strip j
! list_sd2y(3,j) = pe of this x/vert index strip
integer(i_kind),dimension(:),allocatable::nsend_sd2y,nrecv_sd2y,ndsend_sd2y,ndrecv_sd2y
integer(i_kind) nallsend_sd2y,nallrecv_sd2y
integer(i_kind),allocatable:: info_send_sd2y(:,:),info_recv_sd2y(:,:)
integer(i_kind),dimension(:),allocatable::nsend_y2sd,nrecv_y2sd,ndsend_y2sd,ndrecv_y2sd
integer(i_kind) nallsend_y2sd,nallrecv_y2sd
integer(i_kind),allocatable:: info_send_y2sd(:,:),info_recv_y2sd(:,:)
! x sine transform info
real(r_kind),allocatable:: sinx(:,:)
! communication info for x <--> y strips
integer(i_kind) mx_0,mx_1
integer(i_kind),allocatable::list_x2y(:,:) ! list_x2y(1,j) = x index for y strip j
! list_x2y(2,j) = vert index for y strip j
! list_x2y(3,j) = pe of this x/vert index strip
integer(i_kind),dimension(:),allocatable::nsend_x2y,nrecv_x2y,ndsend_x2y,ndrecv_x2y
integer(i_kind) nallsend_x2y,nallrecv_x2y
integer(i_kind),allocatable:: info_send_x2y(:,:),info_recv_x2y(:,:)
! y sine transform info
real(r_kind),allocatable:: siny(:,:)
! constants for gravity projection operators
real(r_kind),allocatable,dimension(:,:):: am2,f_sm2_am2,sm2,a2_p0_sm2,f_p0_sm2,p0_sm2
real(r_kind) fbar
real(r_kind),allocatable,dimension(:,:):: pmask
real(r_kind) zrnmi_period_max,zrnmi_period_width
contains
subroutine zrnmi_initialize(mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_initialize
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
!
! output argument list:
!
! attributes:
! language: f90
! machine: ibm RS/6000 SP
!
!$$$ end documentation block
use mod_strong, only: period_max,period_width
use mod_vtrans, only: nvmodes_keep
implicit none
integer(i_kind),intent(in ) :: mype
zrnmi_period_max=period_max
zrnmi_period_width=period_width
nvert=nvmodes_keep
call zrnmi_sd2x0(mype)
call zrnmi_sd2x1(mype)
call zrnmi_x2sd1(mype)
call zrnmi_sd2y0(mype)
call zrnmi_sd2y1(mype)
call zrnmi_y2sd1(mype)
call zrnmi_x_strans0
call zrnmi_x2y0(mype)
call zrnmi_x2y1(mype)
call zrnmi_y_strans0
call zrnmi_constants(mype)
end subroutine zrnmi_initialize
subroutine zrnmi_sd2x0(mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_sd2x0
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block
!
! input argument list:
! mype - mpi task id
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
! create x (y strips) subdivision for use with sine transform in x direction
! output:
! ny_0,ny_1: range of y/vert index on processor mype
! 1 <= ny_0 <= ny_1 <= ny*nvert
! if npe > ny*nvert, then will have ny_0 = -1, ny_1 = -2 on some processors,
! and ny_0=ny_1 on the remaining ny*nvert processors
!
! list_sd2x(3,ny*nvert): global definition of contents of each y/vert strip
! list_sd2x(1,j) = y index for x strip j
! list_sd2x(2,j) = vert level for x strip j
! list_sd2x(3,j) = pe of this y/vert strip
use gridmod, only: nlon,nlat
use mpimod, only: npe
implicit none
integer(i_kind),intent(in ) :: mype
integer(i_kind) i,k,kchk,kk,n,nn,ny_this,ny_tot
! set analysis grid dimensions
nx=nlon
ny=nlat
allocate(list_sd2x(3,ny*nvert))
ny_tot=ny*nvert
ny_this=ny_tot/npe
if(mod(ny_tot,npe)/=0) ny_this=ny_this+1
if(mod(ny_tot,npe)==0) then
kchk=npe
else
kchk=mod(ny_tot,npe)
end if
nn=0
do k=1,nvert
do i=1,ny
nn=nn+1
list_sd2x(1,nn)=i
list_sd2x(2,nn)=k
list_sd2x(3,nn)=-1
end do
end do
if(mype == 0) write(6,*)' nn,ny_tot,ny,nvert=',nn,ny_tot,ny,nvert
ny_0=-1
ny_1=-2
nn=0
do n=1,npe
if(n <= kchk) then
kk=ny_this
else
kk=ny_this-1
end if
if(kk > 0) then
if(mype+1 == n) then
ny_0=nn+1
ny_1=nn+kk
end if
do k=1,kk
nn=nn+1
list_sd2x(3,nn)=n
end do
end if
end do
end subroutine zrnmi_sd2x0
subroutine zrnmi_sd2x1(mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_sd2x1
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
! continue with setup for subdomain to lat strip interchanges
use gridmod, only: lon2,lat2,jstart,istart
use mpimod, only: npe,mpi_comm_world,ierror,mpi_integer4
implicit none
integer(i_kind),intent(in ) :: mype
integer(i_kind) list2(ny,nvert)
integer(i_kind) i,ii,ii0,iy,ivert,j,mm1,nn,nxloc,ipe,iym,ix,mpi_string1
integer(i_kind) ny_tot
allocate(nsend_sd2x(npe),nrecv_sd2x(npe),ndsend_sd2x(npe+1),ndrecv_sd2x(npe+1))
mm1=mype+1
ny_tot=ny*nvert
nn=0
list2=0
do j=1,ny_tot
iy=list_sd2x(1,j)
ivert=list_sd2x(2,j)
if(list2(iy,ivert) /= 0) then
if(mype == 0) write(0,*)' problem in zrnmi_sd2x1'
call mpi_finalize(i)
stop
end if
list2(iy,ivert)=j
end do
! obtain counts of points to send to each pe from this pe
nsend_sd2x=0
nxloc=lon2-2
do ivert=1,nvert
do i=2,lat2-1
iy=i+istart(mm1)-2
j=list2(iy,ivert)
ipe=list_sd2x(3,j)
nsend_sd2x(ipe)=nsend_sd2x(ipe)+nxloc
end do
end do
ndsend_sd2x(1)=0
do i=2,npe+1
ndsend_sd2x(i)=ndsend_sd2x(i-1)+nsend_sd2x(i-1)
end do
nallsend_sd2x=ndsend_sd2x(npe+1)
allocate(info_send_sd2x(3,nallsend_sd2x))
nsend_sd2x=0
do ivert=1,nvert
do i=2,lat2-1
iy=i+istart(mm1)-2
iym=list2(iy,ivert)
ipe=list_sd2x(3,iym)
do ii=2,lon2-1
ix=ii+jstart(mm1)-2
nsend_sd2x(ipe)=nsend_sd2x(ipe)+1
ii0=ndsend_sd2x(ipe)+nsend_sd2x(ipe)
info_send_sd2x(1,ii0)=ix
info_send_sd2x(2,ii0)=iym
info_send_sd2x(3,ii0)=ivert
end do
end do
end do
call mpi_alltoall(nsend_sd2x,1,mpi_integer4,nrecv_sd2x,1,mpi_integer4,mpi_comm_world,ierror)
ndrecv_sd2x(1)=0
do i=2,npe+1
ndrecv_sd2x(i)=ndrecv_sd2x(i-1)+nrecv_sd2x(i-1)
end do
nallrecv_sd2x=ndrecv_sd2x(npe+1)
allocate(info_recv_sd2x(3,nallrecv_sd2x))
call mpi_type_contiguous(3,mpi_integer4,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
call mpi_alltoallv(info_send_sd2x,nsend_sd2x,ndsend_sd2x,mpi_string1, &
info_recv_sd2x,nrecv_sd2x,ndrecv_sd2x,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
end subroutine zrnmi_sd2x1
subroutine zrnmi_x2sd1(mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_x2sd1
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
! use mpi_alltoallv to move u_x (y strips) to u_sd (subdomains)
use kinds, only: r_kind,i_kind
use gridmod, only: jstart,istart,ilat1,jlon1
use mpimod, only: npe,mpi_comm_world,ierror,mpi_integer4
implicit none
integer(i_kind),intent(in ) :: mype
integer(i_kind) i,iy,ivert,j,k,mm1,ipe,ix,mpi_string1,nn
allocate(nsend_x2sd(npe),nrecv_x2sd(npe),ndsend_x2sd(npe+1),ndrecv_x2sd(npe+1))
mm1=mype+1
! 1. for each pe, gather up list of points from this set of lat strips destined
! for subdomain of pe
do ipe=1,npe
nn=0
do k=ny_0,ny_1
iy=list_sd2x(1,k)
ivert=list_sd2x(2,k)
i=iy-istart(ipe)+2
if(i >= 1.and.i <= ilat1(ipe)+2) then
do j=1,jlon1(ipe)+2
ix=j+jstart(ipe)-2
if(ix >= 1.and.ix <= nx) nn=nn+1
end do
end if
end do
nsend_x2sd(ipe)=nn
end do
ndsend_x2sd(1)=0
do i=2,npe+1
ndsend_x2sd(i)=ndsend_x2sd(i-1)+nsend_x2sd(i-1)
end do
nallsend_x2sd=ndsend_x2sd(npe+1)
allocate(info_send_x2sd(3,nallsend_x2sd))
nn=0
do ipe=1,npe
do k=ny_0,ny_1
iy=list_sd2x(1,k)
ivert=list_sd2x(2,k)
i=iy-istart(ipe)+2
if(i >= 1.and.i <= ilat1(ipe)+2) then
do j=1,jlon1(ipe)+2
ix=j+jstart(ipe)-2
if(ix >= 1.and.ix <= nx) then
nn=nn+1
info_send_x2sd(1,nn)=ix
info_send_x2sd(2,nn)=j
info_send_x2sd(3,nn)=k
end if
end do
end if
end do
end do
call mpi_alltoall(nsend_x2sd,1,mpi_integer4,nrecv_x2sd,1,mpi_integer4,mpi_comm_world,ierror)
ndrecv_x2sd(1)=0
do i=2,npe+1
ndrecv_x2sd(i)=ndrecv_x2sd(i-1)+nrecv_x2sd(i-1)
end do
nallrecv_x2sd=ndrecv_x2sd(npe+1)
allocate(info_recv_x2sd(3,nallrecv_x2sd))
call mpi_type_contiguous(3,mpi_integer4,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
call mpi_alltoallv(info_send_x2sd,nsend_x2sd,ndsend_x2sd,mpi_string1, &
info_recv_x2sd,nrecv_x2sd,ndrecv_x2sd,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
end subroutine zrnmi_x2sd1
subroutine zrnmi_sd2x2(u1_sd,u2_sd,u1_x,u2_x,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_sd2x2
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! u1_sd,u2_sd
!
! output argument list:
! u1_x,u2_x
!
! attributes:
! language: f90
! machine:
!
!$$$
! use mpi_alltoallv to move u_sd (subdomains) to u_x (y strips)
use kinds, only: r_kind,i_kind
use gridmod, only: lon2,lat2,jstart,istart
use mpimod, only: mpi_comm_world,ierror,mpi_rtype
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(in ) :: u1_sd,u2_sd
real(r_kind),dimension(nx,ny_0:ny_1) ,intent( out) :: u1_x,u2_x
integer(i_kind) iy,iym,ix,ivert,j,mm1,mpi_string1
real(r_kind),allocatable::sendbuf(:,:),recvbuf(:,:)
mm1=mype+1
allocate(sendbuf(2,nallsend_sd2x))
do j=1,nallsend_sd2x
ix=info_send_sd2x(1,j)
iym=info_send_sd2x(2,j)
iy=list_sd2x(1,iym)
ivert=list_sd2x(2,iym)
sendbuf(1,j)=u1_sd(iy-istart(mm1)+2,ix-jstart(mm1)+2,ivert)
sendbuf(2,j)=u2_sd(iy-istart(mm1)+2,ix-jstart(mm1)+2,ivert)
end do
call mpi_type_contiguous(2,mpi_rtype,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
allocate(recvbuf(2,nallrecv_sd2x))
call mpi_alltoallv(sendbuf,nsend_sd2x,ndsend_sd2x,mpi_string1, &
recvbuf,nrecv_sd2x,ndrecv_sd2x,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
deallocate(sendbuf)
do j=1,nallrecv_sd2x
ix=info_recv_sd2x(1,j)
iym=info_recv_sd2x(2,j)
u1_x(ix,iym)=recvbuf(1,j)
u2_x(ix,iym)=recvbuf(2,j)
end do
deallocate(recvbuf)
end subroutine zrnmi_sd2x2
subroutine zrnmi_sd2x3(u1_sd,u2_sd,u3_sd,u1_x,u2_x,u3_x,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_sd2x3
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! u1_sd,u2_sd,u2_sd
!
! output argument list:
! u1_x,u2_x,u3_x
!
! attributes:
! language: f90
! machine:
!
!$$$
! use mpi_alltoallv to move u_sd (subdomains) to u_x (y strips)
use kinds, only: r_kind,i_kind
use gridmod, only: lon2,lat2,jstart,istart
use mpimod, only: mpi_comm_world,ierror,mpi_rtype
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(in ) :: u1_sd,u2_sd,u3_sd
real(r_kind),dimension(nx,ny_0:ny_1) ,intent( out) :: u1_x,u2_x,u3_x
integer(i_kind) iy,iym,ix,ivert,j,mm1,mpi_string1
real(r_kind),allocatable::sendbuf(:,:),recvbuf(:,:)
mm1=mype+1
allocate(sendbuf(3,nallsend_sd2x))
do j=1,nallsend_sd2x
ix=info_send_sd2x(1,j)
iym=info_send_sd2x(2,j)
iy=list_sd2x(1,iym)
ivert=list_sd2x(2,iym)
sendbuf(1,j)=u1_sd(iy-istart(mm1)+2,ix-jstart(mm1)+2,ivert)
sendbuf(2,j)=u2_sd(iy-istart(mm1)+2,ix-jstart(mm1)+2,ivert)
sendbuf(3,j)=u3_sd(iy-istart(mm1)+2,ix-jstart(mm1)+2,ivert)
end do
call mpi_type_contiguous(3,mpi_rtype,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
allocate(recvbuf(3,nallrecv_sd2x))
call mpi_alltoallv(sendbuf,nsend_sd2x,ndsend_sd2x,mpi_string1, &
recvbuf,nrecv_sd2x,ndrecv_sd2x,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
deallocate(sendbuf)
do j=1,nallrecv_sd2x
ix=info_recv_sd2x(1,j)
iym=info_recv_sd2x(2,j)
u1_x(ix,iym)=recvbuf(1,j)
u2_x(ix,iym)=recvbuf(2,j)
u3_x(ix,iym)=recvbuf(3,j)
end do
deallocate(recvbuf)
end subroutine zrnmi_sd2x3
subroutine zrnmi_x2sd(u_sd,u_x,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_x2sd
!
! prgrmmr:
!
! abstract: move u_x (lat strips) to u_sd (subdomains)
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! u_x - lat strips
!
! output argument list:
! u_sd - subdomains
!
! attributes:
! language: f90
! machine:
!
!$$$
! use mpi_alltoallv to move u_ew (lat strips) to u_sd (subdomains)
use kinds, only: r_kind,i_kind
use gridmod, only: lon2,lat2,istart
use mpimod, only: mpi_comm_world,ierror,mpi_rtype
use constants, only: zero
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: u_sd
real(r_kind),dimension(nx,ny_0:ny_1) ,intent(in ) :: u_x
real(r_kind),allocatable::sendbuf(:),recvbuf(:)
integer(i_kind) iy,ivert,j,mm1,iym,ix,ixloc
mm1=mype+1
u_sd=zero
allocate(sendbuf(nallsend_x2sd))
do j=1,nallsend_x2sd
ix=info_send_x2sd(1,j)
iym=info_send_x2sd(3,j)
sendbuf(j)=u_x(ix,iym)
end do
allocate(recvbuf(nallrecv_x2sd))
call mpi_alltoallv(sendbuf,nsend_x2sd,ndsend_x2sd,mpi_rtype, &
recvbuf,nrecv_x2sd,ndrecv_x2sd,mpi_rtype,mpi_comm_world,ierror)
deallocate(sendbuf)
do j=1,nallrecv_x2sd
ixloc=info_recv_x2sd(2,j)
iym=info_recv_x2sd(3,j)
iy=list_sd2x(1,iym)
ivert=list_sd2x(2,iym)
u_sd(iy-istart(mm1)+2,ixloc,ivert)=recvbuf(j)
end do
deallocate(recvbuf)
end subroutine zrnmi_x2sd
subroutine zrnmi_x2sd2(u1_sd,u2_sd,u1_x,u2_x,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_x2sd2
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! u1_x -
! u2_x -
!
! output argument list:
! u1_sd -
! u2_sd -
!
! attributes:
! language: f90
! machine:
!
!$$$
! use mpi_alltoallv to move u_ew (lat strips) to u_sd (subdomains)
use kinds, only: r_kind,i_kind
use gridmod, only: lon2,lat2,istart
use mpimod, only: mpi_comm_world,ierror,mpi_rtype
use constants, only: zero
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: u1_sd,u2_sd
real(r_kind),dimension(nx,ny_0:ny_1) ,intent(in ) :: u1_x,u2_x
real(r_kind),allocatable::sendbuf(:,:),recvbuf(:,:)
integer(i_kind) iy,ivert,j,mm1,iym,ix,ixloc,mpi_string1
mm1=mype+1
u1_sd=zero
u2_sd=zero
allocate(sendbuf(2,nallsend_x2sd))
do j=1,nallsend_x2sd
ix=info_send_x2sd(1,j)
iym=info_send_x2sd(3,j)
sendbuf(1,j)=u1_x(ix,iym)
sendbuf(2,j)=u2_x(ix,iym)
end do
call mpi_type_contiguous(2,mpi_rtype,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
allocate(recvbuf(2,nallrecv_x2sd))
call mpi_alltoallv(sendbuf,nsend_x2sd,ndsend_x2sd,mpi_string1, &
recvbuf,nrecv_x2sd,ndrecv_x2sd,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
deallocate(sendbuf)
do j=1,nallrecv_x2sd
ixloc=info_recv_x2sd(2,j)
iym=info_recv_x2sd(3,j)
iy=list_sd2x(1,iym)
ivert=list_sd2x(2,iym)
u1_sd(iy-istart(mm1)+2,ixloc,ivert)=recvbuf(1,j)
u2_sd(iy-istart(mm1)+2,ixloc,ivert)=recvbuf(2,j)
end do
deallocate(recvbuf)
end subroutine zrnmi_x2sd2
subroutine zrnmi_x2sd3(u1_sd,u2_sd,u3_sd,u1_x,u2_x,u3_x,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_x2sd3
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! u1_x -
! u2_x -
! u3_x -
!
! output argument list:
! u1_sd -
! u2_sd -
! u3_sd -
!
! attributes:
! language: f90
! machine:
!
!$$$
! use mpi_alltoallv to move u_ew (lat strips) to u_sd (subdomains)
use kinds, only: r_kind,i_kind
use gridmod, only: lon2,lat2,istart
use mpimod, only: mpi_comm_world,ierror,mpi_rtype
use constants, only: zero
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: u1_sd,u2_sd,u3_sd
real(r_kind),dimension(nx,ny_0:ny_1) ,intent(in ) :: u1_x,u2_x,u3_x
real(r_kind),allocatable::sendbuf(:,:),recvbuf(:,:)
integer(i_kind) iy,ivert,j,mm1,iym,ix,ixloc, mpi_string1
mm1=mype+1
u1_sd=zero
u2_sd=zero
u3_sd=zero
allocate(sendbuf(3,nallsend_x2sd))
do j=1,nallsend_x2sd
ix=info_send_x2sd(1,j)
iym=info_send_x2sd(3,j)
sendbuf(1,j)=u1_x(ix,iym)
sendbuf(2,j)=u2_x(ix,iym)
sendbuf(3,j)=u3_x(ix,iym)
end do
call mpi_type_contiguous(3,mpi_rtype,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
allocate(recvbuf(3,nallrecv_x2sd))
call mpi_alltoallv(sendbuf,nsend_x2sd,ndsend_x2sd,mpi_string1, &
recvbuf,nrecv_x2sd,ndrecv_x2sd,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
deallocate(sendbuf)
do j=1,nallrecv_x2sd
ixloc=info_recv_x2sd(2,j)
iym=info_recv_x2sd(3,j)
iy=list_sd2x(1,iym)
ivert=list_sd2x(2,iym)
u1_sd(iy-istart(mm1)+2,ixloc,ivert)=recvbuf(1,j)
u2_sd(iy-istart(mm1)+2,ixloc,ivert)=recvbuf(2,j)
u3_sd(iy-istart(mm1)+2,ixloc,ivert)=recvbuf(3,j)
end do
deallocate(recvbuf)
end subroutine zrnmi_x2sd3
subroutine zrnmi_sd2y0(mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_sd2y0
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block
!
! input argument list:
! mype - mpi task id
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
! create y (x strips) subdivision for use with derivatives in the y direction
! output:
! nx_0,nx_1: range of x/vert index on processor mype
! 1 <= nx_0 <= nx_1 <= nx*nvert
! if npe > nx*nvert, then will have nx_0 = -1, nx_1 = -2 on some processors,
! and nx_0=nx_1 on the remaining nx*nvert processors
!
! list_sd2y(3,nx*nvert): global definition of contents of each x/vert strip
! list_sd2y(1,j) = x index for y strip j
! list_sd2y(2,j) = vert level for y strip j
! list_sd2y(3,j) = pe of this x/vert strip
use mpimod, only: npe
implicit none
integer(i_kind),intent(in ) :: mype
integer(i_kind) i,k,kchk,kk,n,nn,nx_this,nx_tot
allocate(list_sd2y(3,nx*nvert))
nx_tot=nx*nvert
nx_this=nx_tot/npe
if(mod(nx_tot,npe)/=0) nx_this=nx_this+1
if(mod(nx_tot,npe)==0) then
kchk=npe
else
kchk=mod(nx_tot,npe)
end if
nn=0
do k=1,nvert
do i=1,nx
nn=nn+1
list_sd2y(1,nn)=i
list_sd2y(2,nn)=k
list_sd2y(3,nn)=-1
end do
end do
if(mype == 0) write(6,*)' in zrnmi_sd2x0, nn,nx_tot,nx,nvert=',nn,nx_tot,nx,nvert
nx_0=-1
nx_1=-2
nn=0
do n=1,npe
if(n <= kchk) then
kk=nx_this
else
kk=nx_this-1
end if
if(kk > 0) then
if(mype+1 == n) then
nx_0=nn+1
nx_1=nn+kk
end if
do k=1,kk
nn=nn+1
list_sd2y(3,nn)=n
end do
end if
end do
end subroutine zrnmi_sd2y0
subroutine zrnmi_sd2y1(mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_sd2y1
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
! continue with setup for subdomain to x strip interchanges
use gridmod, only: lon2,lat2,jstart,istart
use mpimod, only: npe,mpi_comm_world,ierror,mpi_integer4
implicit none
integer(i_kind),intent(in ) :: mype
integer(i_kind) list2(nx,nvert)
integer(i_kind) i,ii,ii0,ix,ivert,j,mm1,nn,nyloc,ipe,ixm,iy,mpi_string1
integer(i_kind) nx_tot
allocate(nsend_sd2y(npe),nrecv_sd2y(npe),ndsend_sd2y(npe+1),ndrecv_sd2y(npe+1))
mm1=mype+1
nx_tot=nx*nvert
nn=0
list2=0
do j=1,nx_tot
ix=list_sd2y(1,j)
ivert=list_sd2y(2,j)
if(list2(ix,ivert) /= 0) then
if(mype == 0) write(0,*)' problem in zrnmi_sd2y1'
call mpi_finalize(i)
stop
end if
list2(ix,ivert)=j
end do
do ivert=1,nvert
do ix=1,nx
if(list2(ix,ivert) == 0) then
if(mype == 0) write(0,*)' problem in zrnmi_sd2y1'
call mpi_finalize(i)
stop
end if
end do
end do
! obtain counts of points to send to each pe from this pe
nsend_sd2y=0
nyloc=lat2-2
do ivert=1,nvert
do i=2,lon2-1
ix=i+jstart(mm1)-2
j=list2(ix,ivert)
ipe=list_sd2y(3,j)
nsend_sd2y(ipe)=nsend_sd2y(ipe)+nyloc
end do
end do
ndsend_sd2y(1)=0
do i=2,npe+1
ndsend_sd2y(i)=ndsend_sd2y(i-1)+nsend_sd2y(i-1)
end do
nallsend_sd2y=ndsend_sd2y(npe+1)
allocate(info_send_sd2y(3,nallsend_sd2y))
nsend_sd2y=0
do ivert=1,nvert
do i=2,lon2-1
ix=i+jstart(mm1)-2
ixm=list2(ix,ivert)
ipe=list_sd2y(3,ixm)
do ii=2,lat2-1
iy=ii+istart(mm1)-2
nsend_sd2y(ipe)=nsend_sd2y(ipe)+1
ii0=ndsend_sd2y(ipe)+nsend_sd2y(ipe)
info_send_sd2y(1,ii0)=iy
info_send_sd2y(2,ii0)=ixm
info_send_sd2y(3,ii0)=ivert
end do
end do
end do
call mpi_alltoall(nsend_sd2y,1,mpi_integer4,nrecv_sd2y,1,mpi_integer4,mpi_comm_world,ierror)
ndrecv_sd2y(1)=0
do i=2,npe+1
ndrecv_sd2y(i)=ndrecv_sd2y(i-1)+nrecv_sd2y(i-1)
end do
nallrecv_sd2y=ndrecv_sd2y(npe+1)
allocate(info_recv_sd2y(3,nallrecv_sd2y))
call mpi_type_contiguous(3,mpi_integer4,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
call mpi_alltoallv(info_send_sd2y,nsend_sd2y,ndsend_sd2y,mpi_string1, &
info_recv_sd2y,nrecv_sd2y,ndrecv_sd2y,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
end subroutine zrnmi_sd2y1
subroutine zrnmi_y2sd1(mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_y2sd1
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
! use mpi_alltoallv to move u_y (x strips) to u_sd (subdomains)
use kinds, only: r_kind,i_kind
use gridmod, only: jstart,istart,ilat1,jlon1
use mpimod, only: npe,mpi_comm_world,ierror,mpi_integer4
implicit none
integer(i_kind),intent(in ) :: mype
integer(i_kind) i,ix,ivert,j,k,mm1,mpi_string1,ipe,iy,nn
allocate(nsend_y2sd(npe),nrecv_y2sd(npe),ndsend_y2sd(npe+1),ndrecv_y2sd(npe+1))
mm1=mype+1
! 1. for each pe, gather up list of points from this set of lat strips destined
! for subdomain of pe
do ipe=1,npe
nn=0
do k=nx_0,nx_1
ix=list_sd2y(1,k)
ivert=list_sd2y(2,k)
i=ix-jstart(ipe)+2
if(i >= 1.and.i <= jlon1(ipe)+2) then
do j=1,ilat1(ipe)+2
iy=j+istart(ipe)-2
if(iy >= 1.and.iy <= ny) nn=nn+1
end do
end if
end do
nsend_y2sd(ipe)=nn
end do
ndsend_y2sd(1)=0
do i=2,npe+1
ndsend_y2sd(i)=ndsend_y2sd(i-1)+nsend_y2sd(i-1)
end do
nallsend_y2sd=ndsend_y2sd(npe+1)
allocate(info_send_y2sd(3,nallsend_y2sd))
nn=0
do ipe=1,npe
do k=nx_0,nx_1
ix=list_sd2y(1,k)
ivert=list_sd2y(2,k)
i=ix-jstart(ipe)+2
if(i >= 1.and.i <= jlon1(ipe)+2) then
do j=1,ilat1(ipe)+2
iy=j+istart(ipe)-2
if(iy >= 1.and.iy <= ny) then
nn=nn+1
info_send_y2sd(1,nn)=iy
info_send_y2sd(2,nn)=j
info_send_y2sd(3,nn)=k
end if
end do
end if
end do
end do
call mpi_alltoall(nsend_y2sd,1,mpi_integer4,nrecv_y2sd,1,mpi_integer4,mpi_comm_world,ierror)
ndrecv_y2sd(1)=0
do i=2,npe+1
ndrecv_y2sd(i)=ndrecv_y2sd(i-1)+nrecv_y2sd(i-1)
end do
nallrecv_y2sd=ndrecv_y2sd(npe+1)
allocate(info_recv_y2sd(3,nallrecv_y2sd))
call mpi_type_contiguous(3,mpi_integer4,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
call mpi_alltoallv(info_send_y2sd,nsend_y2sd,ndsend_y2sd,mpi_string1, &
info_recv_y2sd,nrecv_y2sd,ndrecv_y2sd,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
end subroutine zrnmi_y2sd1
subroutine zrnmi_sd2y2(u1_sd,u2_sd,u1_y,u2_y,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_sd2y2
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! u1_sd -
! u2_sd -
!
! output argument list:
! u1_y -
! u2_y -
!
! attributes:
! language: f90
! machine:
!
!$$$
! use mpi_alltoallv to move u_sd (subdomains) to u_y (x strips)
use kinds, only: r_kind,i_kind
use gridmod, only: lon2,lat2,jstart,istart
use mpimod, only: mpi_comm_world,ierror,mpi_rtype
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(in ) :: u1_sd,u2_sd
real(r_kind),dimension(ny,nx_0:nx_1) ,intent( out) :: u1_y,u2_y
integer(i_kind) ix,ixm,iy,ivert,j,mm1,mpi_string1
real(r_kind),allocatable::sendbuf(:,:),recvbuf(:,:)
mm1=mype+1
allocate(sendbuf(2,nallsend_sd2y))
do j=1,nallsend_sd2y
iy=info_send_sd2y(1,j)
ixm=info_send_sd2y(2,j)
ix=list_sd2y(1,ixm)
ivert=list_sd2y(2,ixm)
sendbuf(1,j)=u1_sd(iy-istart(mm1)+2,ix-jstart(mm1)+2,ivert)
sendbuf(2,j)=u2_sd(iy-istart(mm1)+2,ix-jstart(mm1)+2,ivert)
end do
call mpi_type_contiguous(2,mpi_rtype,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
allocate(recvbuf(2,nallrecv_sd2y))
call mpi_alltoallv(sendbuf,nsend_sd2y,ndsend_sd2y,mpi_string1, &
recvbuf,nrecv_sd2y,ndrecv_sd2y,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
deallocate(sendbuf)
do j=1,nallrecv_sd2y
iy=info_recv_sd2y(1,j)
ixm=info_recv_sd2y(2,j)
u1_y(iy,ixm)=recvbuf(1,j)
u2_y(iy,ixm)=recvbuf(2,j)
end do
deallocate(recvbuf)
end subroutine zrnmi_sd2y2
subroutine zrnmi_y2sd2(u1_sd,u2_sd,u1_y,u2_y,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_y2sd2
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! u1_y -
! u2_y -
!
! output argument list:
! u1_sd -
! u2_sd -
!
! attributes:
! language: f90
! machine:
!
!$$$
! use mpi_alltoallv to move u_y (x strips) to u_sd (subdomains)
use kinds, only: r_kind,i_kind
use gridmod, only: lon2,lat2,jstart
use mpimod, only: mpi_comm_world,ierror,mpi_rtype
use constants, only: zero
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: u1_sd,u2_sd
real(r_kind),dimension(ny,nx_0:nx_1) ,intent(in ) :: u1_y,u2_y
real(r_kind),allocatable::sendbuf(:,:),recvbuf(:,:)
integer(i_kind) ix,ivert,j,mm1,ixm,iy,iyloc,mpi_string1
mm1=mype+1
u1_sd=zero
u2_sd=zero
allocate(sendbuf(2,nallsend_y2sd))
do j=1,nallsend_y2sd
iy=info_send_y2sd(1,j)
ixm=info_send_y2sd(3,j)
sendbuf(1,j)=u1_y(iy,ixm)
sendbuf(2,j)=u2_y(iy,ixm)
end do
call mpi_type_contiguous(2,mpi_rtype,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
allocate(recvbuf(2,nallrecv_y2sd))
call mpi_alltoallv(sendbuf,nsend_y2sd,ndsend_y2sd,mpi_string1, &
recvbuf,nrecv_y2sd,ndrecv_y2sd,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
deallocate(sendbuf)
do j=1,nallrecv_y2sd
iyloc=info_recv_y2sd(2,j)
ixm=info_recv_y2sd(3,j)
ix=list_sd2y(1,ixm)
ivert=list_sd2y(2,ixm)
u1_sd(iyloc,ix-jstart(mm1)+2,ivert)=recvbuf(1,j)
u2_sd(iyloc,ix-jstart(mm1)+2,ivert)=recvbuf(2,j)
end do
deallocate(recvbuf)
end subroutine zrnmi_y2sd2
subroutine zrnmi_x_strans0
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_x_strans0
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: one,two,pi
implicit none
integer(i_kind) k,n
allocate(sinx(nx,nx))
do k=1,nx
do n=1,nx
sinx(n,k)=sqrt(two/(nx+one))*sin(pi*k*n/(nx+one))
end do
end do
end subroutine zrnmi_x_strans0
subroutine zrnmi_x_strans(g_x,gt_x)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_x_strans
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block
!
! input argument list:
! g_x -
!
! output argument list:
! gt_x -
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: zero,half,one
implicit none
real(r_kind),intent(in ) :: g_x(nx,ny_0:ny_1)
real(r_kind),intent( out) :: gt_x(nx,ny_0:ny_1)
integer(i_kind) i,i1,j,k,k1
real(r_kind) diff,factor,sum,diff1,sum1
do j=ny_0,ny_1
do k=1,nx
gt_x(k,j)=zero
end do
do i=1,((nx+1)/2),2
factor=one
if(nx+1-i == i) factor=half
sum =factor*(g_x(i,j)+g_x(nx+1-i,j))
diff= g_x(i,j)-g_x(nx+1-i,j)
i1=i+1
if(i1 <= (nx+1)/2) then
factor=one
if(nx+1-i1 == i1) factor=half
sum1 =factor*(g_x(i1,j)+g_x(nx+1-i1,j))
diff1= g_x(i1,j)-g_x(nx+1-i1,j)
do k=1,nx-1,2
k1=k+1
gt_x(k ,j)=gt_x(k ,j)+sinx(k ,i)*sum +sinx(k ,i1)*sum1
gt_x(k1,j)=gt_x(k1,j)+sinx(k1,i)*diff+sinx(k1,i1)*diff1
end do
if(mod(nx,2) == 1) gt_x(nx,j)=gt_x(nx,j)+sinx(nx,i)*sum+sinx(nx,i1)*sum1
else
do k=1,nx-1,2
k1=k+1
gt_x(k,j)=gt_x(k,j)+sinx(k,i)*sum
gt_x(k1,j)=gt_x(k1,j)+sinx(k1,i)*diff
end do
if(mod(nx,2) == 1) gt_x(nx,j)=gt_x(nx,j)+sinx(nx,i)*sum
end if
end do
end do
end subroutine zrnmi_x_strans
subroutine zrnmi_uvm2dzmhat(u,v,m,dhat,zhat,mhat,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_uvm2dzmhat
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! u -
! v -
! m -
!
! output argument list:
! dhat -
! zhat -
! mhat -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lon2,lat2
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(in ) :: u,v,m
real(r_kind),dimension(ny,mx_0:mx_1) ,intent( out) :: dhat,zhat,mhat
real(r_kind),dimension(lat2,lon2,nvert):: d,z
real(r_kind),dimension(nx,ny_0:ny_1):: d_x,z_x,m_x
real(r_kind),dimension(nx,ny_0:ny_1):: d4_x,z4_x,m4_x
real(r_kind),dimension(ny,mx_0:mx_1):: d_y,z_y,m_y
call zrnmi_uv2dz(u,v,d,z,mype)
call zrnmi_sd2x3(d,z,m,d_x,z_x,m_x,mype)
call zrnmi_x_strans(d_x,d4_x)
call zrnmi_x_strans(z_x,z4_x)
call zrnmi_x_strans(m_x,m4_x)
call zrnmi_x2y3(d4_x,z4_x,m4_x,d_y,z_y,m_y,mype)
call zrnmi_y_strans(d_y,dhat)
call zrnmi_y_strans(z_y,zhat)
call zrnmi_y_strans(m_y,mhat)
end subroutine zrnmi_uvm2dzmhat
subroutine zrnmi_uvm2dzmhat_ad(u,v,m,dhat,zhat,mhat,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_uvm2dzmhat_ad
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! dhat -
! zhat -
! mhat -
!
! output argument list:
! u -
! v -
! m -
! dhat -
! zhat -
! mhat -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lon2,lat2
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: u,v,m
real(r_kind),dimension(ny,mx_0:mx_1) ,intent(inout) :: dhat,zhat,mhat
real(r_kind),dimension(lat2,lon2,nvert):: d,z
real(r_kind),dimension(nx,ny_0:ny_1):: d_x,z_x,m_x
real(r_kind),dimension(nx,ny_0:ny_1):: d4_x,z4_x,m4_x
real(r_kind),dimension(ny,mx_0:mx_1):: d_y,z_y,m_y
call zrnmi_y_strans(mhat,m_y)
call zrnmi_y_strans(zhat,z_y)
call zrnmi_y_strans(dhat,d_y)
call zrnmi_y2x3(d4_x,z4_x,m4_x,d_y,z_y,m_y,mype)
call zrnmi_x_strans(m4_x,m_x)
call zrnmi_x_strans(z4_x,z_x)
call zrnmi_x_strans(d4_x,d_x)
call zrnmi_x2sd3(d,z,m,d_x,z_x,m_x,mype)
call zrnmi_uv2dz_ad(u,v,d,z,mype)
end subroutine zrnmi_uvm2dzmhat_ad
subroutine zrnmi_pcmhat2uvm(p,c,m,phat,chat,mhat,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_pcmhat2uvm
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! phat -
! chat -
! mhat -
!
! output argument list:
! p -
! c -
! m -
! phat -
! chat -
! mhat -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lon2,lat2
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: p,c,m
real(r_kind),dimension(ny,mx_0:mx_1) ,intent(inout) :: phat,chat,mhat
real(r_kind),dimension(nx,ny_0:ny_1):: p_x,c_x,m_x
real(r_kind),dimension(nx,ny_0:ny_1):: p4_x,c4_x,m4_x
real(r_kind),dimension(ny,mx_0:mx_1):: p_y,c_y,m_y
call zrnmi_y_strans(phat,p_y)
call zrnmi_y_strans(chat,c_y)
call zrnmi_y_strans(mhat,m_y)
call zrnmi_y2x3(p4_x,c4_x,m4_x,p_y,c_y,m_y,mype)
call zrnmi_x_strans(p4_x,p_x)
call zrnmi_x_strans(c4_x,c_x)
call zrnmi_x_strans(m4_x,m_x)
call zrnmi_x2sd3(p,c,m,p_x,c_x,m_x,mype)
end subroutine zrnmi_pcmhat2uvm
subroutine zrnmi_pcmhat2uvm_orig(u,v,m,phat,chat,mhat,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_pcmhat2uvm
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! phat -
! chat -
! mhat -
!
! output argument list:
! p -
! c -
! m -
! phat -
! chat -
! mhat -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lon2,lat2
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: u,v,m
real(r_kind),dimension(ny,mx_0:mx_1) ,intent(inout) :: phat,chat,mhat
real(r_kind),dimension(lat2,lon2,nvert):: p,c
real(r_kind),dimension(nx,ny_0:ny_1):: p_x,c_x,m_x
real(r_kind),dimension(nx,ny_0:ny_1):: p4_x,c4_x,m4_x
real(r_kind),dimension(ny,mx_0:mx_1):: p_y,c_y,m_y
call zrnmi_y_strans(phat,p_y)
call zrnmi_y_strans(chat,c_y)
call zrnmi_y_strans(mhat,m_y)
call zrnmi_y2x3(p4_x,c4_x,m4_x,p_y,c_y,m_y,mype)
call zrnmi_x_strans(p4_x,p_x)
call zrnmi_x_strans(c4_x,c_x)
call zrnmi_x_strans(m4_x,m_x)
call zrnmi_x2sd3(p,c,m,p_x,c_x,m_x,mype)
call zrnmi_pc2uv_orig(p,c,u,v,mype)
end subroutine zrnmi_pcmhat2uvm_orig
subroutine zrnmi_pcmhat2uvm_ad_orig(u,v,m,phat,chat,mhat,mype)
!$$$ subprogram documentation block
! . . . .
! subprogram: zrnmi_pcmhat2uvm_ad_orig
! prgmmr:
!
! abstract:
!
! program history log:
! 2010-01-07 lueken - added subprogram doc block
!
! input argument list:
! mype
! u,v,m
!
! output argument list:
! u,v,m
! phat,chat,mhat
!
! attributes:
! language: f90
! machine:
!
!$$$ end documentation block
use constants, only: zero
use gridmod, only: lon2,lat2
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(inout) :: u,v,m
real(r_kind),dimension(ny,mx_0:mx_1) ,intent( out) :: phat,chat,mhat
real(r_kind),dimension(lat2,lon2,nvert):: p,c
real(r_kind),dimension(nx,ny_0:ny_1):: p_x,c_x,m_x
real(r_kind),dimension(nx,ny_0:ny_1):: p4_x,c4_x,m4_x
real(r_kind),dimension(ny,mx_0:mx_1):: p_y,c_y,m_y
call zrnmi_pc2uv_ad_orig(p,c,u,v,mype)
call zrnmi_sd2x3(p,c,m,p_x,c_x,m_x,mype)
call zrnmi_x_strans(p_x,p4_x)
call zrnmi_x_strans(c_x,c4_x)
call zrnmi_x_strans(m_x,m4_x)
call zrnmi_x2y3(p4_x,c4_x,m4_x,p_y,c_y,m_y,mype)
call zrnmi_y_strans(p_y,phat)
call zrnmi_y_strans(c_y,chat)
call zrnmi_y_strans(m_y,mhat)
end subroutine zrnmi_pcmhat2uvm_ad_orig
subroutine zrnmi_pcmhat2uvm_ad(p,c,m,phat,chat,mhat,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_pcmhat2uvm_ad
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! p -
! c -
! m -
!
! output argument list:
! p -
! c -
! m -
! phat -
! chat -
! mhat -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lon2,lat2
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(inout) :: p,c,m
real(r_kind),dimension(ny,mx_0:mx_1) ,intent( out) :: phat,chat,mhat
real(r_kind),dimension(nx,ny_0:ny_1):: p_x,c_x,m_x
real(r_kind),dimension(nx,ny_0:ny_1):: p4_x,c4_x,m4_x
real(r_kind),dimension(ny,mx_0:mx_1):: p_y,c_y,m_y
call zrnmi_sd2x3(p,c,m,p_x,c_x,m_x,mype)
call zrnmi_x_strans(p_x,p4_x)
call zrnmi_x_strans(c_x,c4_x)
call zrnmi_x_strans(m_x,m4_x)
call zrnmi_x2y3(p4_x,c4_x,m4_x,p_y,c_y,m_y,mype)
call zrnmi_y_strans(p_y,phat)
call zrnmi_y_strans(c_y,chat)
call zrnmi_y_strans(m_y,mhat)
end subroutine zrnmi_pcmhat2uvm_ad
subroutine zrnmi_x2y0(mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_x2y0
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block
!
! input argument list:
! mype - mpi task id
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
! create y (x strips) subdivision for use with sine transform in y direction
! output:
! mx_0,mx_1: range of x/vert index on processor mype
! 1 <= mx_0 <= mx_1 <= nx*nvert
! if npe > nx*nvert, then will have mx_0 = -1, mx_1 = -2 on some processors,
! and mx_0=mx_1 on the remaining nx*nvert processors
!
! list_x2y(3,nx*nvert): global definition of contents of each x/vert strip
! list_x2y(1,j) = x index for y strip j
! list_x2y(2,j) = vert level for y strip j
! list_x2y(3,j) = pe of this x/vert strip
use mpimod, only: npe
implicit none
integer(i_kind),intent(in ) :: mype
integer(i_kind) i,k,kchk,kk,n,nn,mx_this,mx_tot
allocate(list_x2y(3,nx*nvert))
mx_tot=nx*nvert
mx_this=mx_tot/npe
if(mod(mx_tot,npe)/=0) mx_this=mx_this+1
if(mod(mx_tot,npe)==0) then
kchk=npe
else
kchk=mod(mx_tot,npe)
end if
nn=0
do k=1,nvert
do i=1,nx
nn=nn+1
list_x2y(1,nn)=i
list_x2y(2,nn)=k
list_x2y(3,nn)=-1
end do
end do
if(mype == 0) write(6,*)' in zrnmi_x2y0, nn,mx_tot,nx,nvert=',nn,mx_tot,nx,nvert
mx_0=-1
mx_1=-2
nn=0
do n=1,npe
if(n <= kchk) then
kk=mx_this
else
kk=mx_this-1
end if
if(kk > 0) then
if(mype+1 == n) then
mx_0=nn+1
mx_1=nn+kk
end if
do k=1,kk
nn=nn+1
list_x2y(3,nn)=n
end do
end if
end do
end subroutine zrnmi_x2y0
subroutine zrnmi_x2y1(mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_x2y1
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
! continue with setup for x strip to y strip communication
use mpimod, only: npe,mpi_comm_world,ierror,mpi_integer4
implicit none
integer(i_kind),intent(in ) :: mype
integer(i_kind) list2(nx,nvert)
integer(i_kind) i,ii0,ix,ivert,j,k,ipe,ixm,iy,mpi_string1
integer(i_kind) mx_tot
allocate(nsend_x2y(npe),nrecv_x2y(npe),ndsend_x2y(npe+1),ndrecv_x2y(npe+1))
mx_tot=nx*nvert
list2=0
do j=1,mx_tot
ix=list_x2y(1,j)
ivert=list_x2y(2,j)
if(list2(ix,ivert) /= 0) then
if(mype == 0) write(0,*)' problem in zrnmi_x2y1'
call mpi_finalize(i)
stop
end if
list2(ix,ivert)=j
end do
do ivert=1,nvert
do ix=1,nx
if(list2(ix,ivert) == 0) then
if(mype == 0) write(0,*)' problem in zrnmi_x2y1'
call mpi_finalize(i)
stop
end if
end do
end do
! obtain counts of points to send to each pe from this pe
nsend_x2y=0
do k=ny_0,ny_1
ivert=list_sd2x(2,k)
do ix=1,nx
j=list2(ix,ivert)
ipe=list_x2y(3,j)
nsend_x2y(ipe)=nsend_x2y(ipe)+1
end do
end do
ndsend_x2y(1)=0
do i=2,npe+1
ndsend_x2y(i)=ndsend_x2y(i-1)+nsend_x2y(i-1)
end do
nallsend_x2y=ndsend_x2y(npe+1)
allocate(info_send_x2y(4,nallsend_x2y))
nsend_x2y=0
do k=ny_0,ny_1
iy=list_sd2x(1,k)
ivert=list_sd2x(2,k)
do ix=1,nx
ixm=list2(ix,ivert)
ipe=list_x2y(3,ixm)
nsend_x2y(ipe)=nsend_x2y(ipe)+1
ii0=ndsend_x2y(ipe)+nsend_x2y(ipe)
info_send_x2y(1,ii0)=ix
info_send_x2y(2,ii0)=k
info_send_x2y(3,ii0)=iy
info_send_x2y(4,ii0)=ixm
end do
end do
call mpi_alltoall(nsend_x2y,1,mpi_integer4,nrecv_x2y,1,mpi_integer4,mpi_comm_world,ierror)
ndrecv_x2y(1)=0
do i=2,npe+1
ndrecv_x2y(i)=ndrecv_x2y(i-1)+nrecv_x2y(i-1)
end do
nallrecv_x2y=ndrecv_x2y(npe+1)
allocate(info_recv_x2y(4,nallrecv_x2y))
call mpi_type_contiguous(4,mpi_integer4,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
call mpi_alltoallv(info_send_x2y,nsend_x2y,ndsend_x2y,mpi_string1, &
info_recv_x2y,nrecv_x2y,ndrecv_x2y,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
end subroutine zrnmi_x2y1
subroutine zrnmi_x2y3(u1_x,u2_x,u3_x,u1_y,u2_y,u3_y,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_x2y3
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block
!
! input argument list:
! mype - mpi task id
! u1_x -
! u2_x -
! u3_x -
!
! output argument list:
! u1_y -
! u2_y -
! u3_y -
!
! attributes:
! language: f90
! machine:
!
!$$$
use mpimod, only: mpi_comm_world,ierror,mpi_rtype
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(nx,ny_0:ny_1),intent(in ) :: u1_x,u2_x,u3_x
real(r_kind),dimension(ny,mx_0:mx_1),intent( out) :: u1_y,u2_y,u3_y
integer(i_kind) ixm,ix,iy,iym,j,mm1,mpi_string1
real(r_kind),allocatable::sendbuf(:,:),recvbuf(:,:)
mm1=mype+1
allocate(sendbuf(3,nallsend_x2y))
do j=1,nallsend_x2y
ix=info_send_x2y(1,j)
iym=info_send_x2y(2,j)
sendbuf(1,j)=u1_x(ix,iym)
sendbuf(2,j)=u2_x(ix,iym)
sendbuf(3,j)=u3_x(ix,iym)
end do
call mpi_type_contiguous(3,mpi_rtype,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
allocate(recvbuf(3,nallrecv_x2y))
call mpi_alltoallv(sendbuf,nsend_x2y,ndsend_x2y,mpi_string1, &
recvbuf,nrecv_x2y,ndrecv_x2y,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
deallocate(sendbuf)
do j=1,nallrecv_x2y
iy=info_recv_x2y(3,j)
ixm=info_recv_x2y(4,j)
u1_y(iy,ixm)=recvbuf(1,j)
u2_y(iy,ixm)=recvbuf(2,j)
u3_y(iy,ixm)=recvbuf(3,j)
end do
deallocate(recvbuf)
end subroutine zrnmi_x2y3
subroutine zrnmi_y2x3(u1_x,u2_x,u3_x,u1_y,u2_y,u3_y,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_y2x3
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! u1_y -
! u2_y -
! u3_y -
!
! output argument list:
! u1_x -
! u2_x -
! u3_x -
!
! attributes:
! language: f90
! machine:
!
!$$$
use mpimod, only: mpi_comm_world,ierror,mpi_rtype
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(nx,ny_0:ny_1),intent( out) :: u1_x,u2_x,u3_x
real(r_kind),dimension(ny,mx_0:mx_1),intent(in ) :: u1_y,u2_y,u3_y
integer(i_kind) ixm,ix,iy,iym,j,mm1,mpi_string1
real(r_kind),allocatable::sendbuf(:,:),recvbuf(:,:)
mm1=mype+1
allocate(recvbuf(3,nallrecv_x2y))
do j=1,nallrecv_x2y
iy=info_recv_x2y(3,j)
ixm=info_recv_x2y(4,j)
recvbuf(1,j)=u1_y(iy,ixm)
recvbuf(2,j)=u2_y(iy,ixm)
recvbuf(3,j)=u3_y(iy,ixm)
end do
allocate(sendbuf(3,nallsend_x2y))
call mpi_type_contiguous(3,mpi_rtype,mpi_string1,ierror)
call mpi_type_commit(mpi_string1,ierror)
call mpi_alltoallv(recvbuf,nrecv_x2y,ndrecv_x2y,mpi_string1, &
sendbuf,nsend_x2y,ndsend_x2y,mpi_string1,mpi_comm_world,ierror)
call mpi_type_free(mpi_string1,ierror)
deallocate(recvbuf)
do j=1,nallsend_x2y
ix=info_send_x2y(1,j)
iym=info_send_x2y(2,j)
u1_x(ix,iym)=sendbuf(1,j)
u2_x(ix,iym)=sendbuf(2,j)
u3_x(ix,iym)=sendbuf(3,j)
end do
deallocate(sendbuf)
end subroutine zrnmi_y2x3
subroutine zrnmi_y_strans0
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_y_strans0
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: one,two,pi
implicit none
integer(i_kind) k,n
allocate(siny(ny,ny))
do k=1,ny
do n=1,ny
siny(n,k)=sqrt(two/(ny+one))*sin(pi*k*n/(ny+one))
end do
end do
end subroutine zrnmi_y_strans0
subroutine zrnmi_y_strans(g_y,gt_y)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_y_strans
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block
!
! input argument list:
! g_y -
!
! output argument list:
! gt_y -
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: zero,half,one
implicit none
real(r_kind),intent(in ) :: g_y(ny,mx_0:mx_1)
real(r_kind),intent( out) :: gt_y(ny,mx_0:mx_1)
integer(i_kind) i,i1,j,k,k1
real(r_kind) diff,factor,sum,diff1,sum1
do j=mx_0,mx_1
do k=1,ny
gt_y(k,j)=zero
end do
do i=1,((ny+1)/2),2
factor=one
if(ny+1-i == i) factor=half
sum =factor*(g_y(i,j)+g_y(ny+1-i,j))
diff= g_y(i,j)-g_y(ny+1-i,j)
i1=i+1
if(i1 <= (ny+1)/2) then
factor=one
if(ny+1-i1 == i1) factor=half
sum1 =factor*(g_y(i1,j)+g_y(ny+1-i1,j))
diff1= g_y(i1,j)-g_y(ny+1-i1,j)
do k=1,ny-1,2
k1=k+1
gt_y(k ,j)=gt_y(k ,j)+siny(k ,i)*sum +siny(k ,i1)*sum1
gt_y(k1,j)=gt_y(k1,j)+siny(k1,i)*diff+siny(k1,i1)*diff1
end do
if(mod(ny,2) == 1) gt_y(ny,j)=gt_y(ny,j)+siny(ny,i)*sum+siny(ny,i1)*sum1
else
do k=1,ny-1,2
k1=k+1
gt_y(k,j)=gt_y(k,j)+siny(k,i)*sum
gt_y(k1,j)=gt_y(k1,j)+siny(k1,i)*diff
end do
if(mod(ny,2) == 1) gt_y(ny,j)=gt_y(ny,j)+siny(ny,i)*sum
end if
end do
end do
end subroutine zrnmi_y_strans
subroutine zrnmi_delx_general(f_x,fx_x,vector,iord)
!$$$ subprogram documentation block
! . . . .
! subprogram: zrnmi_delx_general
! prgmmr:
!
! abstract:
!
! program history log:
! 2010-01-07 lueken - added subprogram doc block
!
! input argument list:
! f_x
! vector
! iord
!
! output argument list:
! fx_x
!
! attributes:
! language: f90
! machine:
!
!$$$ end documentation block
use gridmod, only: region_dy,region_dyi
real(r_kind) ,intent(in ) :: f_x(nx,ny_0:ny_1)
real(r_kind) ,intent( out) :: fx_x(nx,ny_0:ny_1)
logical ,intent(in ) :: vector
integer(i_kind),intent(in ) :: iord
real(r_kind) work1(nx,ny_0:ny_1)
real(r_kind) work2(nx,ny_0:ny_1)
integer(i_kind) i,j,iy
if(vector) then
do i=ny_0,ny_1
iy=list_sd2x(1,i)
do j=1,nx
work1(j,i)=f_x(j,i)*region_dy(iy,j)
end do
end do
else
do i=ny_0,ny_1
do j=1,nx
work1(j,i)=f_x(j,i)
end do
end do
end if
if(iord == 2) call zrnmi_delx(work1,work2)
!if(iord == 4) call zrnmi_delx_4th_ord(work1,work2)
if(vector) then
do i=ny_0,ny_1
iy=list_sd2x(1,i)
do j=1,nx
fx_x(j,i)=work2(j,i)*region_dyi(iy,j)
end do
end do
else
do i=ny_0,ny_1
do j=1,nx
fx_x(j,i)=work2(j,i)
end do
end do
end if
end subroutine zrnmi_delx_general
subroutine zrnmi_delx(f_x,fx_x)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_delx
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! f_x -
!
! output argument list:
! fx_x -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: coeffx
implicit none
real(r_kind) ,intent(in ) :: f_x(nx,ny_0:ny_1)
real(r_kind),intent( out) :: fx_x(nx,ny_0:ny_1)
integer(i_kind) i,j,iy
do i=ny_0,ny_1
iy=list_sd2x(1,i)
fx_x(1,i)=(f_x(3,i)-f_x(1,i))*coeffx(iy,1)
do j=2,nx-1
fx_x(j,i)=(f_x(j+1,i)-f_x(j-1,i))*coeffx(iy,j)
end do
fx_x(nx,i)=(f_x(nx,i)-f_x(nx-2,i))*coeffx(iy,nx)
end do
end subroutine zrnmi_delx
subroutine zrnmi_delx_ad(f_x,fx_x)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_delx_ad
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! fx_x -
!
! output argument list:
! f_x -
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: zero
use gridmod, only: coeffx
implicit none
real(r_kind) ,intent( out) :: f_x(nx,ny_0:ny_1)
real(r_kind) ,intent(in ) :: fx_x(nx,ny_0:ny_1)
integer(i_kind) i,j,iy
f_x=zero
do i=ny_0,ny_1
iy=list_sd2x(1,i)
f_x(nx ,i)=f_x(nx ,i)+fx_x(nx,i)*coeffx(iy,nx)
f_x(nx-2,i)=f_x(nx-2,i)-fx_x(nx,i)*coeffx(iy,nx)
do j=2,nx-1
f_x(j+1,i)=f_x(j+1,i)+fx_x(j,i)*coeffx(iy,j)
f_x(j-1,i)=f_x(j-1,i)-fx_x(j,i)*coeffx(iy,j)
end do
f_x(1,i)=f_x(1,i)-fx_x(1,i)*coeffx(iy,1)
f_x(3,i)=f_x(3,i)+fx_x(1,i)*coeffx(iy,1)
end do
end subroutine zrnmi_delx_ad
subroutine zrnmi_dely_general(f_y,fy_y,vector,iord)
!$$$ subprogram documentation block
! . . . .
! subprogram: zrnmi_dely_general
! prgmmr:
!
! abstract:
!
! program history log:
! 2010-01-07 lueken - added subprogram doc block
!
! input argument list:
! f_y
! vector
! iord
!
! output argument list:
! fy_y
!
! attributes:
! language: f90
! machine:
!
!$$$ end documentation block
use gridmod, only: region_dx,region_dxi
implicit none
real(r_kind) ,intent(in ) :: f_y(ny,nx_0:nx_1)
real(r_kind) ,intent( out) :: fy_y(ny,nx_0:nx_1)
logical ,intent(in ) :: vector
integer(i_kind),intent(in ) :: iord
real(r_kind) work1(ny,nx_0:nx_1)
real(r_kind) work2(ny,nx_0:nx_1)
integer(i_kind) i,j,ix
if(vector) then
do i=nx_0,nx_1
ix=list_sd2y(1,i)
do j=1,ny
work1(j,i)=f_y(j,i)*region_dx(j,ix)
end do
end do
else
do i=nx_0,nx_1
do j=1,ny
work1(j,i)=f_y(j,i)
end do
end do
end if
if(iord == 2) call zrnmi_dely(work1,work2)
!if(iord == 4) call zrnmi_dely_4th_ord(work1,work2)
if(vector) then
do i=nx_0,nx_1
ix=list_sd2y(1,i)
do j=1,ny
fy_y(j,i)=work2(j,i)*region_dxi(j,ix)
end do
end do
else
do i=nx_0,nx_1
do j=1,ny
fy_y(j,i)=work2(j,i)
end do
end do
end if
end subroutine zrnmi_dely_general
subroutine zrnmi_dely(f_y,fy_y)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_dely
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! f_y -
!
! output argument list:
! fy_y -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: coeffy
implicit none
real(r_kind) ,intent(in ) :: f_y(ny,nx_0:nx_1)
real(r_kind) ,intent( out) :: fy_y(ny,nx_0:nx_1)
integer(i_kind) i,j,ix
do i=nx_0,nx_1
ix=list_sd2y(1,i)
fy_y(1,i)=(f_y(3,i)-f_y(1,i))*coeffy(1,ix)
do j=2,ny-1
fy_y(j,i)=(f_y(j+1,i)-f_y(j-1,i))*coeffy(j,ix)
end do
fy_y(ny,i)=(f_y(ny,i)-f_y(ny-2,i))*coeffy(ny,ix)
end do
end subroutine zrnmi_dely
subroutine zrnmi_dely_ad(f_y,fy_y)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_dely_ad
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! fy_y -
!
! output argument list:
! f_y -
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: zero
use gridmod, only: coeffy
implicit none
real(r_kind) ,intent( out) :: f_y(ny,nx_0:nx_1)
real(r_kind) ,intent(in ) :: fy_y(ny,nx_0:nx_1)
integer(i_kind) i,j,ix
f_y=zero
do i=nx_0,nx_1
ix=list_sd2y(1,i)
f_y(ny ,i)=f_y(ny ,i)+fy_y(ny,i)*coeffy(ny,ix)
f_y(ny-2,i)=f_y(ny-2,i)-fy_y(ny,i)*coeffy(ny,ix)
do j=2,ny-1
f_y(j+1,i)=f_y(j+1,i)+fy_y(j,i)*coeffy(j,ix)
f_y(j-1,i)=f_y(j-1,i)-fy_y(j,i)*coeffy(j,ix)
end do
f_y(3,i)=f_y(3,i)+fy_y(1,i)*coeffy(1,ix)
f_y(1,i)=f_y(1,i)-fy_y(1,i)*coeffy(1,ix)
end do
end subroutine zrnmi_dely_ad
subroutine zrnmi_uv2dz(u,v,div,vort,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_uv2dz
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block
!
! input argument list:
! mype - mpi task id
! u -
! v -
!
! output argument list:
! div -
! vort -
!
! attributes:
! language: f90
! machine:
!
!$$$
use kinds, only: r_kind,i_kind
use constants, only: zero
use gridmod, only: lat2,lon2
implicit none
! Declare passed variables
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(in ) :: u,v
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: div,vort
! Declare local variables
real(r_kind),dimension(nx,ny_0:ny_1)::u_x,v_x,ux_x,vx_x
real(r_kind),dimension(ny,nx_0:nx_1)::u_y,v_y,uy_y,vy_y
real(r_kind),dimension(lat2,lon2,nvert)::ux,vx,uy,vy
u_x=zero ; v_x=zero
call zrnmi_sd2x2(u,v,u_x,v_x,mype)
u_y=zero ; v_y=zero
call zrnmi_sd2y2(u,v,u_y,v_y,mype)
ux_x=zero
call zrnmi_delx_general(u_x,ux_x,.true.,2)
vx_x=zero
call zrnmi_delx_general(v_x,vx_x,.true.,2)
uy_y=zero
call zrnmi_dely_general(u_y,uy_y,.true.,2)
vy_y=zero
call zrnmi_dely_general(v_y,vy_y,.true.,2)
ux=zero ; vx=zero
call zrnmi_x2sd2(ux,vx,ux_x,vx_x,mype)
uy=zero ; vy=zero
call zrnmi_y2sd2(uy,vy,uy_y,vy_y,mype)
div=ux+vy
vort=vx-uy
end subroutine zrnmi_uv2dz
subroutine zrnmi_uv2dz_ad(u,v,div,vort,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_uv2dz_ad
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block
!
! input argument list:
! mype - mpi task id
! div -
! vort -
!
! output argument list:
! u -
! v -
! div -
! vort -
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: zero
use gridmod, only: lat2,lon2
implicit none
! Declare passed variables
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: u,v
real(r_kind),dimension(lat2,lon2,nvert),intent(inout) :: div,vort
! Declare local variables
real(r_kind),dimension(nx,ny_0:ny_1)::u_x,v_x,ux_x,vx_x
real(r_kind),dimension(ny,nx_0:nx_1)::u_y,v_y,uy_y,vy_y
real(r_kind),dimension(lat2,lon2,nvert)::ux,vx,uy,vy
ux=div
uy=-vort
vx=vort
vy=div
uy_y=zero ; vy_y=zero
call zrnmi_sd2y2(uy,vy,uy_y,vy_y,mype)
ux_x=zero ; vx_x=zero
call zrnmi_sd2x2(ux,vx,ux_x,vx_x,mype)
v_y=zero
call zrnmi_dely_ad(v_y,vy_y)
u_y=zero
call zrnmi_dely_ad(u_y,uy_y)
v_x=zero
call zrnmi_delx_ad(v_x,vx_x)
u_x=zero
call zrnmi_delx_ad(u_x,ux_x)
ux=zero ; vx=zero
call zrnmi_y2sd2(ux,vx,u_y,v_y,mype)
u=zero ; v=zero
call zrnmi_x2sd2(u,v,u_x,v_x,mype)
u=u+ux ; v=v+vx
end subroutine zrnmi_uv2dz_ad
subroutine zrnmi_pc2uv_orig(psi,chi,u,v,mype)
!$$$ subprogram documentation block
! . . . .
! subprogram: zrnmi_pc2uv_orig
! prgmmr:
!
! abstract:
!
! program history log:
! 2010-01-07 lueken - added subprogram doc block
!
! input argument list:
! mype
! psi,chi
!
! output argument list:
! u,v
!
! attributes:
! language: f90
! machine:
!
!$$$ end documentation block
use kinds, only: r_kind,i_kind
use constants, only: zero
use gridmod, only: lat2,lon2
implicit none
! Declare passed variables
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(in ) :: psi,chi
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: u,v
! Declare local variables
real(r_kind),dimension(nx,ny_0:ny_1)::p_x,c_x,px_x,cx_x
real(r_kind),dimension(ny,nx_0:nx_1)::p_y,c_y,py_y,cy_y
real(r_kind),dimension(lat2,lon2,nvert)::px,cx,py,cy
p_x=zero ; c_x=zero
call zrnmi_sd2x2(psi,chi,p_x,c_x,mype)
p_y=zero ; c_y=zero
call zrnmi_sd2y2(psi,chi,p_y,c_y,mype)
px_x=zero
call zrnmi_delx(p_x,px_x)
cx_x=zero
call zrnmi_delx(c_x,cx_x)
py_y=zero
call zrnmi_dely(p_y,py_y)
cy_y=zero
call zrnmi_dely(c_y,cy_y)
px=zero ; cx=zero
call zrnmi_x2sd2(px,cx,px_x,cx_x,mype)
py=zero ; cy=zero
call zrnmi_y2sd2(py,cy,py_y,cy_y,mype)
u=cx-py
v=px+cy
end subroutine zrnmi_pc2uv_orig
subroutine zrnmi_pc2uv_ad_orig(psi,chi,u,v,mype)
!$$$ subprogram documentation block
! . . . .
! subprogram: zrnmi_pc2uv_ad_orig
! prgmmr:
!
! abstract:
!
! program history log:
! 2010-01-07 lueken - added subprogram doc block
!
! input argument list:
! mype
! u,v
!
! output argument list:
! psi,chi
! u,v
!
! attributes:
! language: f90
! machine:
!
!$$$ end documentation block
use kinds, only: r_kind,i_kind
use constants, only: zero
use gridmod, only: lat2,lon2
implicit none
! Declare passed variables
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: psi,chi
real(r_kind),dimension(lat2,lon2,nvert),intent(inout) :: u,v
! Declare local variables
real(r_kind),dimension(nx,ny_0:ny_1)::p_x,c_x,px_x,cx_x
real(r_kind),dimension(ny,nx_0:nx_1)::p_y,c_y,py_y,cy_y
real(r_kind),dimension(lat2,lon2,nvert)::px,cx,py,cy
cx=u ; cy=v ; px=v ; py=-u
py_y=zero ; cy_y=zero
call zrnmi_sd2y2(py,cy,py_y,cy_y,mype)
px_x=zero ; cx_x=zero
call zrnmi_sd2x2(px,cx,px_x,cx_x,mype)
c_y=zero
call zrnmi_dely_ad(c_y,cy_y)
p_y=zero
call zrnmi_dely_ad(p_y,py_y)
c_x=zero
call zrnmi_delx_ad(c_x,cx_x)
p_x=zero
call zrnmi_delx_ad(p_x,px_x)
py=zero ; cy=zero
call zrnmi_y2sd2(py,cy,p_y,c_y,mype)
px=zero ; cx=zero
call zrnmi_x2sd2(px,cx,p_x,c_x,mype)
psi=px+py ; chi=cx+cy
end subroutine zrnmi_pc2uv_ad_orig
subroutine zrnmi_constants(mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_constants
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block
!
! input argument list:
! mype - mpi task id
!
! output argument list:
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: zero,half,one,two,omega,pi,one_tenth,r3600
use gridmod, only: region_dx,region_dy
use mod_vtrans, only: depths,speeds
use mpimod,only: mpi_rtype,mpi_integer,mpi_max,mpi_min,mpi_sum,mpi_comm_world,ierror
implicit none
integer(i_kind),intent(in ) :: mype
integer(i_kind) i,j,k,mode
real(r_kind) bigk,bigl,dxbar,dybar,a2,ak2,s2
real(r_kind) thisperiod,thislength
real(r_kind) rlenmax(nvert),permax(nvert)
integer(i_kind) numkeep(nvert),numtot(nvert)
real(r_kind) rlenmax0(nvert),permax0(nvert)
integer(i_kind) numkeep0(nvert),numtot0(nvert)
real(r_kind) pmaskmax(nvert),pmaskmin(nvert),pmaskmax0(nvert),pmaskmin0(nvert)
fbar=two*omega
dxbar=zero
dybar=zero
do j=1,nx
do i=1,ny
dxbar=dxbar+region_dx(i,j)
dybar=dybar+region_dy(i,j)
end do
end do
dxbar=dxbar/(nx*ny)
dybar=dybar/(nx*ny)
if(mype == 0) then
write(6,*)' in zrnmi_constants, dxbar=',dxbar
write(6,*)' in zrnmi_constants, dybar=',dybar
write(6,*)' in zrnmi_constants, fbar=', fbar
do k=1,nvert
write(6,*)' in zrnmi_constants, k,depths(k)=',k,depths(k)
end do
end if
allocate(am2(ny,mx_0:mx_1),f_sm2_am2(ny,mx_0:mx_1),sm2(ny,mx_0:mx_1))
allocate(a2_p0_sm2(ny,mx_0:mx_1),f_p0_sm2(ny,mx_0:mx_1),p0_sm2(ny,mx_0:mx_1))
allocate(pmask(ny,mx_0:mx_1))
permax=zero
rlenmax=zero
pmask=zero
am2=zero
sm2=zero
f_sm2_am2=zero
p0_sm2=zero
a2_p0_sm2=zero
f_p0_sm2=zero
pmaskmax=-huge(pmaskmax)
pmaskmin= huge(pmaskmin)
do j=mx_0,mx_1
k=list_x2y(1,j)
bigk=k
ak2=( (two/dxbar)*sin(pi*bigk/(two*(nx+one))) )**2
mode=list_x2y(2,j)
do i=1,ny
bigl=i
a2 = ak2 + ( (two/dybar)*sin(pi*bigl/(two*(ny+one))) )**2
s2=depths(mode)*a2+fbar**2
am2(i,j)=one/a2
sm2(i,j)=one/s2
f_sm2_am2(i,j)=fbar*sm2(i,j)*am2(i,j)
p0_sm2(i,j)=depths(mode)*sm2(i,j)
a2_p0_sm2(i,j)=a2*p0_sm2(i,j)
f_p0_sm2(i,j)=fbar*p0_sm2(i,j)
thislength=two*pi*sqrt(am2(i,j))
! if(thislength < 3._r_kind*max(dxbar,dybar)) cycle
thisperiod=thislength/(speeds(mode)*r3600)
! pmask(i,j)=half*(one-tanh((thisperiod-zrnmi_period_max)/zrnmi_period_width))
if(thisperiod <= zrnmi_period_max) pmask(i,j)=one
permax(mode)=max(permax(mode),thisperiod)
rlenmax(mode)=max(rlenmax(mode),thislength)
end do
end do
numkeep=zero
numtot=zero
do j=mx_0,mx_1
mode=list_x2y(2,j)
do i=1,ny
numtot(mode)=numtot(mode)+1
if(pmask(i,j) > one_tenth) numkeep(mode)=numkeep(mode)+1
pmaskmax(mode)=max(pmask(i,j),pmaskmax(mode))
pmaskmin(mode)=min(pmask(i,j),pmaskmin(mode))
end do
end do
call mpi_allreduce(rlenmax,rlenmax0,nvert,mpi_rtype,mpi_max,mpi_comm_world,ierror)
call mpi_allreduce(permax,permax0,nvert,mpi_rtype,mpi_max,mpi_comm_world,ierror)
call mpi_allreduce(pmaskmax,pmaskmax0,nvert,mpi_rtype,mpi_max,mpi_comm_world,ierror)
call mpi_allreduce(pmaskmin,pmaskmin0,nvert,mpi_rtype,mpi_min,mpi_comm_world,ierror)
call mpi_allreduce(numkeep,numkeep0,nvert,mpi_integer,mpi_sum,mpi_comm_world,ierror)
call mpi_allreduce(numtot,numtot0,nvert,mpi_integer,mpi_sum,mpi_comm_world,ierror)
if(mype == 0) then
do k=1,nvert
write(6,*)' in zrnmi_constants, k,period_max,numkeep,numtot,lenmax,permax=', &
k,zrnmi_period_max,numkeep0(k),numtot0(k),rlenmax0(k),permax0(k)
end do
do k=1,nvert
write(6,*)' in zrnmi_constants, k,pmaskmax,min=',k,pmaskmax0(k),pmaskmin0(k)
end do
end if
end subroutine zrnmi_constants
subroutine zrnmi_strong_bal_correction(ut,vt,tt,pst,psi,chi,t,ps,baldiag,fullfield,update,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_strong_bal_correction
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
! 2009-11-27 parrish - add uv_hyb_ens. if present and true, then
! input/output variables psi=u, chi=v.
!
! input argument list:
! mype - mpi task id
! ut -
! vt -
! tt -
! pst -
! psi -
! chi -
! t -
! ps -
! baldiag -
! update -
! fullfield-
!
! output argument list:
! ut -
! vt -
! tt -
! pst -
! u -
! v -
! t -
! ps -
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: zero
use gridmod, only: lat2,lon2,nsig
use mod_vtrans, only: vtrans,vtrans_inv
use mod_vtrans, only: depths
use mpimod,only: mpi_rtype,mpi_sum,mpi_comm_world,ierror
use jfunc,only: jiter
use hybrid_ensemble_parameters, only: uv_hyb_ens
implicit none
! initially just generate projections and make maps
real(r_kind),dimension(lat2,lon2,nsig),intent(inout) :: ut,vt,tt
real(r_kind),dimension(lat2,lon2) ,intent(inout) :: pst
real(r_kind),dimension(lat2,lon2,nsig),intent(inout) :: psi,chi,t
real(r_kind),dimension(lat2,lon2) ,intent(inout) :: ps
logical ,intent(in ) :: baldiag,update,fullfield
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(ny,mx_0:mx_1,2)::rbalg
real(r_kind),dimension(lat2,lon2,nvert)::utilde,vtilde,mtilde
real(r_kind),dimension(ny,mx_0:mx_1)::dhat,zhat,mhat
real(r_kind),dimension(ny,mx_0:mx_1)::phat2,chat2,mhat2
real(r_kind),dimension(lat2,lon2,nsig)::dpsi,dchi,dt
real(r_kind),dimension(lat2,lon2)::dps
real(r_kind),dimension(nvert)::baldt(nvert),balagt(nvert)
real(r_kind),dimension(nvert)::baldt0(nvert),balagt0(nvert)
real(r_kind) baldt_all,balagt_all
integer(i_kind) i,j,k,mode
! vertical mode transform
utilde=zero ; vtilde=zero ; mtilde=zero
call vtrans(ut,vt,tt,pst,utilde,vtilde,mtilde)
! transform to spectral space
call zrnmi_uvm2dzmhat(utilde,vtilde,mtilde,dhat,zhat,mhat,mype)
! apply mask to input spectral fields to limit periods considered
dhat=pmask*dhat
zhat=pmask*zhat
mhat=pmask*mhat
if(update) then
! compute gravity projected corrections:
! chat2=f_sm2_am2*zhat+sm2*mhat ! original, similar to bourke-mcgregor scheme B
chat2= sm2*mhat ! emulate bourke-mcgregor scheme A
phat2=-f_sm2_am2*dhat
mhat2=p0_sm2*dhat
! transform to grid space
if(uv_hyb_ens) then
call zrnmi_pcmhat2uvm_orig(utilde,vtilde,mtilde,phat2,chat2,mhat2,mype)
else
call zrnmi_pcmhat2uvm(utilde,vtilde,mtilde,phat2,chat2,mhat2,mype)
end if
dt=zero
dpsi=zero
dchi=zero
dps=zero
call vtrans_inv(utilde,vtilde,mtilde,dpsi,dchi,dt,dps)
t=t-dt ; ps=ps-dps
psi=psi-dpsi ; chi=chi-dchi
end if
! compute baldt, balagt, and bal=baldt+balagt
if(baldiag) then
! compute gravity tendency amplitudes
do j=mx_0,mx_1
mode=list_x2y(2,j)
do i=1,ny
rbalg(i,j,1)=sqrt(am2(i,j)*depths(mode))*dhat(i,j)
rbalg(i,j,2)=sqrt(a2_p0_sm2(i,j))*(fbar*am2(i,j)*zhat(i,j)+mhat(i,j))
end do
end do
baldt=zero
balagt=zero
do j=mx_0,mx_1
mode=list_x2y(2,j)
do i=1,ny
baldt(mode)=baldt(mode) +rbalg(i,j,1)**2
balagt(mode)=balagt(mode)+rbalg(i,j,2)**2
end do
end do
call mpi_allreduce(balagt,balagt0,nvert,mpi_rtype,mpi_sum,mpi_comm_world,ierror)
call mpi_allreduce(baldt,baldt0,nvert,mpi_rtype,mpi_sum,mpi_comm_world,ierror)
if(mype == 0) then
if (fullfield) then
write(6,*) 'ZRNMI_STRONG_BAL: FULL FIELD BALANCE DIAGNOSTICS -- '
else
write(6,*) 'ZRNMI_STRONG_BAL: INCREMENTAL BALANCE DIAGNOSTICS -- '
end if
baldt_all=zero ; balagt_all=zero
do k=1,nvert
baldt_all=baldt_all+baldt0(k)
balagt_all=balagt_all+balagt0(k)
write(6,*)' jiter, k,baldt,balagt,bal=',jiter,k,baldt0(k),balagt0(k),baldt0(k)+balagt0(k)
end do
write(6,*)' jiter, baldt,balagt,bal=',jiter,baldt_all,balagt_all,baldt_all+balagt_all
end if
end if
end subroutine zrnmi_strong_bal_correction
subroutine zrnmi_strong_bal_correction_ad(ut,vt,tt,pst,psi,chi,t,ps,update,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_strong_bal_correction_ad
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
! 2009-11-27 parrish - add uv_hyb_ens. if present and true, then
! input/output variables psi=u, chi=v.
!
! input argument list:
! mype - mpi task id
! ut -
! vt -
! tt -
! pst -
! u -
! v -
! t -
! ps -
! update -
!
! output argument list:
! ut -
! vt -
! tt -
! pst -
! ps -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lat2,lon2,nsig
use constants, only: zero
use mod_vtrans, only: vtrans_ad,vtrans_inv_ad
use hybrid_ensemble_parameters, only: uv_hyb_ens
implicit none
! initially just generate projections and make maps
real(r_kind),dimension(lat2,lon2,nsig),intent(inout) :: ut,vt,tt
real(r_kind),dimension(lat2,lon2) ,intent(inout) :: pst
real(r_kind),dimension(lat2,lon2,nsig),intent(in ) :: psi,chi,t
real(r_kind),dimension(lat2,lon2) ,intent(in ) :: ps
logical ,intent(in ) :: update
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert)::utilde,vtilde,mtilde
real(r_kind),dimension(ny,mx_0:mx_1)::dhat,zhat,mhat
real(r_kind),dimension(ny,mx_0:mx_1)::phat2,chat2,mhat2
real(r_kind),dimension(lat2,lon2,nsig)::dpsi,dchi,dt
real(r_kind),dimension(lat2,lon2)::dps
dhat=zero ; zhat=zero ; mhat=zero
dpsi=zero ; dchi=zero ; dt=zero ; dps=zero
if(update) then
dpsi=-psi ; dchi=-chi ; dt=-t ; dps=-ps
utilde=zero ; vtilde=zero ; mtilde=zero
call vtrans_inv_ad(utilde,vtilde,mtilde,dpsi,dchi,dt,dps)
phat2=zero ; chat2=zero ; mhat2=zero
if(uv_hyb_ens) then
call zrnmi_pcmhat2uvm_ad_orig(utilde,vtilde,mtilde,phat2,chat2,mhat2,mype)
else
call zrnmi_pcmhat2uvm_ad(utilde,vtilde,mtilde,phat2,chat2,mhat2,mype)
end if
! adjoint of gravity projected corrections
dhat=p0_sm2*mhat2-f_sm2_am2*phat2
zhat=f_sm2_am2*chat2
mhat=sm2*chat2
end if
! adjoint of apply mask to input spectral fields to limit periods considered
dhat=pmask*dhat
zhat=pmask*zhat
mhat=pmask*mhat
! adjoint of transform to spectral space
utilde=zero ; vtilde=zero ; mtilde=zero
call zrnmi_uvm2dzmhat_ad(utilde,vtilde,mtilde,dhat,zhat,mhat,mype)
! vertical mode transform
call vtrans_ad(ut,vt,tt,pst,utilde,vtilde,mtilde)
end subroutine zrnmi_strong_bal_correction_ad
subroutine zrnmi_filter_uvm(utilde,vtilde,mtilde,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: filter low frequency scales from input
!
! prgrmmr: parrish
!
! abstract:
!
! program history log:
! 2009-08-28 parrish
!
! input argument list:
! mype - mpi task id
! utilde -
! vtilde -
! mtilde -
!
! output argument list:
! utilde -
! vtilde -
! mtilde -
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: zero
use gridmod, only: lat2,lon2
! initially just generate projections and make maps
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(inout) :: utilde,vtilde,mtilde
real(r_kind),dimension(ny,mx_0:mx_1)::dhat,zhat,mhat
! transform to spectral space
call zrnmi_uvm2dzmhat(utilde,vtilde,mtilde,dhat,zhat,mhat,mype)
! apply mask to input spectral fields to limit periods considered
dhat=pmask*dhat*am2
zhat=pmask*zhat*am2
mhat=pmask*mhat
! transform back to grid space
call zrnmi_pcmhat2uvm_orig(utilde,vtilde,mtilde,zhat,dhat,mhat,mype)
end subroutine zrnmi_filter_uvm
subroutine zrnmi_filter_uvm_ad(utilde,vtilde,mtilde,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_filter_uvm_ad
!
! prgrmmr: parrish
!
! abstract:
!
! program history log:
! 2009-08-28 parrish
!
! input argument list:
! mype - mpi task id
! utilde -
! vtilde -
! mtilde -
!
! output argument list:
! utilde -
! vtilde -
! mtilde -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lat2,lon2
use constants, only: zero
! initially just generate projections and make maps
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(inout) :: utilde,vtilde,mtilde
real(r_kind),dimension(ny,mx_0:mx_1)::dhat,zhat,mhat
dhat=zero ; zhat=zero ; mhat=zero
call zrnmi_pcmhat2uvm_ad_orig(utilde,vtilde,mtilde,zhat,dhat,mhat,mype)
! adjoint of apply mask to input spectral fields to limit periods considered
dhat=pmask*dhat*am2
zhat=pmask*zhat*am2
mhat=pmask*mhat
! adjoint of transform to spectral space
utilde=zero ; vtilde=zero ; mtilde=zero
call zrnmi_uvm2dzmhat_ad(utilde,vtilde,mtilde,dhat,zhat,mhat,mype)
end subroutine zrnmi_filter_uvm_ad
subroutine zrnmi_filter_uvm2(utilde,vtilde,mtilde,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: filter low frequency scales from input
!
! prgrmmr: parrish
!
! abstract:
!
! program history log:
! 2009-08-28 parrish
!
! input argument list:
! mype - mpi task id
! utilde -
! vtilde -
! mtilde -
!
! output argument list:
! utilde -
! vtilde -
! mtilde -
!
! attributes:
! language: f90
! machine:
!
!$$$
use constants, only: zero
use gridmod, only: lat2,lon2
! initially just generate projections and make maps
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(inout) :: utilde,vtilde,mtilde
real(r_kind),dimension(ny,mx_0:mx_1)::uhat,vhat,mhat
! transform to spectral space
call zrnmi_uvm2uvmhat(utilde,vtilde,mtilde,uhat,vhat,mhat,mype)
! apply mask to input spectral fields to limit periods considered
uhat=pmask*uhat
vhat=pmask*vhat
mhat=pmask*mhat
! transform back to grid space
call zrnmi_uvmhat2uvm(utilde,vtilde,mtilde,uhat,vhat,mhat,mype)
end subroutine zrnmi_filter_uvm2
subroutine zrnmi_filter_uvm2_ad(utilde,vtilde,mtilde,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_filter_uvm2_ad
!
! prgrmmr: parrish
!
! abstract:
!
! program history log:
! 2009-08-28 parrish
!
! input argument list:
! mype - mpi task id
! utilde -
! vtilde -
! mtilde -
!
! output argument list:
! utilde -
! vtilde -
! mtilde -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lat2,lon2
use constants, only: zero
implicit none
! initially just generate projections and make maps
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(inout) :: utilde,vtilde,mtilde
real(r_kind),dimension(ny,mx_0:mx_1)::uhat,vhat,mhat
uhat=zero ; vhat=zero ; mhat=zero
call zrnmi_uvmhat2uvm_ad(utilde,vtilde,mtilde,uhat,vhat,mhat,mype)
! adjoint of apply mask to input spectral fields to limit periods considered
uhat=pmask*uhat
vhat=pmask*vhat
mhat=pmask*mhat
! adjoint of transform to spectral space
utilde=zero ; vtilde=zero ; mtilde=zero
call zrnmi_uvm2uvmhat_ad(utilde,vtilde,mtilde,uhat,vhat,mhat,mype)
end subroutine zrnmi_filter_uvm2_ad
subroutine zrnmi_uvm2uvmhat(u,v,m,uhat,vhat,mhat,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_uvm2uvmhat
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! u -
! v -
! m -
!
! output argument list:
! dhat -
! zhat -
! mhat -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lon2,lat2
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(in ) :: u,v,m
real(r_kind),dimension(ny,mx_0:mx_1) ,intent( out) :: uhat,vhat,mhat
real(r_kind),dimension(nx,ny_0:ny_1):: u_x,v_x,m_x
real(r_kind),dimension(nx,ny_0:ny_1):: u4_x,v4_x,m4_x
real(r_kind),dimension(ny,mx_0:mx_1):: u_y,v_y,m_y
call zrnmi_sd2x3(u,v,m,u_x,v_x,m_x,mype)
call zrnmi_x_strans(u_x,u4_x)
call zrnmi_x_strans(v_x,v4_x)
call zrnmi_x_strans(m_x,m4_x)
call zrnmi_x2y3(u4_x,v4_x,m4_x,u_y,v_y,m_y,mype)
call zrnmi_y_strans(u_y,uhat)
call zrnmi_y_strans(v_y,vhat)
call zrnmi_y_strans(m_y,mhat)
end subroutine zrnmi_uvm2uvmhat
subroutine zrnmi_uvm2uvmhat_ad(u,v,m,uhat,vhat,mhat,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_uvm2uvmhat_ad
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! dhat -
! zhat -
! mhat -
!
! output argument list:
! u -
! v -
! m -
! dhat -
! zhat -
! mhat -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lon2,lat2
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: u,v,m
real(r_kind),dimension(ny,mx_0:mx_1) ,intent(inout) :: uhat,vhat,mhat
real(r_kind),dimension(nx,ny_0:ny_1):: u_x,v_x,m_x
real(r_kind),dimension(nx,ny_0:ny_1):: u4_x,v4_x,m4_x
real(r_kind),dimension(ny,mx_0:mx_1):: u_y,v_y,m_y
call zrnmi_y_strans(mhat,m_y)
call zrnmi_y_strans(vhat,v_y)
call zrnmi_y_strans(uhat,u_y)
call zrnmi_y2x3(u4_x,v4_x,m4_x,u_y,v_y,m_y,mype)
call zrnmi_x_strans(m4_x,m_x)
call zrnmi_x_strans(v4_x,v_x)
call zrnmi_x_strans(u4_x,u_x)
call zrnmi_x2sd3(u,v,m,u_x,v_x,m_x,mype)
end subroutine zrnmi_uvm2uvmhat_ad
subroutine zrnmi_uvmhat2uvm(u,v,m,uhat,vhat,mhat,mype)
!$$$ subprogram documentation block
! . . .
! subprogram: zrnmi_uvmhat2uvm
!
! prgrmmr:
!
! abstract:
!
! program history log:
! 2008-03-25 safford -- add subprogram doc block, rm unused uses
!
! input argument list:
! mype - mpi task id
! phat -
! chat -
! mhat -
!
! output argument list:
! p -
! c -
! m -
! phat -
! chat -
! mhat -
!
! attributes:
! language: f90
! machine:
!
!$$$
use gridmod, only: lon2,lat2
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent( out) :: u,v,m
real(r_kind),dimension(ny,mx_0:mx_1) ,intent(inout) :: uhat,vhat,mhat
real(r_kind),dimension(nx,ny_0:ny_1):: u_x,v_x,m_x
real(r_kind),dimension(nx,ny_0:ny_1):: u4_x,v4_x,m4_x
real(r_kind),dimension(ny,mx_0:mx_1):: u_y,v_y,m_y
call zrnmi_y_strans(uhat,u_y)
call zrnmi_y_strans(vhat,v_y)
call zrnmi_y_strans(mhat,m_y)
call zrnmi_y2x3(u4_x,v4_x,m4_x,u_y,v_y,m_y,mype)
call zrnmi_x_strans(u4_x,u_x)
call zrnmi_x_strans(v4_x,v_x)
call zrnmi_x_strans(m4_x,m_x)
call zrnmi_x2sd3(u,v,m,u_x,v_x,m_x,mype)
end subroutine zrnmi_uvmhat2uvm
subroutine zrnmi_uvmhat2uvm_ad(u,v,m,uhat,vhat,mhat,mype)
!$$$ subprogram doucmentation block
! . . . .
! subprogram: zrnmi_uvmhat2uvm_ad
! prgmmr:
!
! abstract:
!
! program history log:
! 2010-01-07 lueken - added subprogram doc block
!
! input argument list:
! mype
! u,v,m
!
! output argument list:
! uhat,vhat,mhat
! u,v,m
!
! attributes:
! language: f90
! machine:
!
!$$$ end documentation block
use constants, only: zero
use gridmod, only: lon2,lat2
implicit none
integer(i_kind) ,intent(in ) :: mype
real(r_kind),dimension(lat2,lon2,nvert),intent(inout) :: u,v,m
real(r_kind),dimension(ny,mx_0:mx_1) ,intent( out) :: uhat,vhat,mhat
real(r_kind),dimension(nx,ny_0:ny_1):: u_x,v_x,m_x
real(r_kind),dimension(nx,ny_0:ny_1):: u4_x,v4_x,m4_x
real(r_kind),dimension(ny,mx_0:mx_1):: u_y,v_y,m_y
call zrnmi_sd2x3(u,v,m,u_x,v_x,m_x,mype)
call zrnmi_x_strans(u_x,u4_x)
call zrnmi_x_strans(v_x,v4_x)
call zrnmi_x_strans(m_x,m4_x)
call zrnmi_x2y3(u4_x,v4_x,m4_x,u_y,v_y,m_y,mype)
call zrnmi_y_strans(u_y,uhat)
call zrnmi_y_strans(v_y,vhat)
call zrnmi_y_strans(m_y,mhat)
end subroutine zrnmi_uvmhat2uvm_ad
end module zrnmi_mod