From bd4b4b30af0528ce2b4ef075c8c8ef827b38ee42 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 22 Apr 2021 16:00:55 -0400 Subject: [PATCH 1/8] Changes needed by NAG --- GEOS_Shared/G3_MPI_Util_Mod.F90 | 163 +++++++++--------- GEOS_Shared/Lightning_mod.F90 | 81 ++++----- GEOS_Shared/OVP.F90 | 3 +- GEOS_Shared/calcdbz.F | 4 +- GEOS_Shared/lightning_toolbox_mod.F90 | 60 +++---- GEOS_Util/plots/zonal.f | 6 +- GEOS_Util/post/CMakeLists.txt | 2 +- GEOS_Util/post/binarytile.F90 | 4 +- GEOS_Util/post/flat2hdf.F | 8 +- GEOS_Util/post/fvrst.F | 6 +- GEOS_Util/post/mpi_util.F | 4 +- GEOS_Util/post/rs_numtiles.F90 | 2 +- GEOS_Util/post/stats.F90 | 27 ++- GEOS_Util/post/timer.F | 4 +- .../pre/NSIDC-OSTIA_SST-ICE_blend/check.F90 | 2 +- .../lake_data_EIGTHdeg.F90 | 2 +- .../proc_SST_FRACI.F90 | 2 +- .../proc_SST_FRACI_ostia_quart.F90 | 2 +- GMAO_etc/mkdrstdate.f | 6 +- GMAO_etc/rst_date.f | 2 +- GMAO_gfio/GFIO_mean.f90 | 39 ++--- GMAO_hermes/ana5sfc.F90 | 10 +- GMAO_hermes/diag2dyn.F | 12 +- GMAO_hermes/drs2dyn.f90 | 30 ++-- GMAO_hermes/dyn2drs.f90 | 16 +- GMAO_hermes/dyn2dyn.f90 | 46 ++--- GMAO_hermes/dyn2prs.f90 | 22 +-- GMAO_hermes/dyn2real_eta.f90 | 8 +- GMAO_hermes/dyn2rs5.f90 | 8 +- GMAO_hermes/dyn52dyn.f90 | 8 +- GMAO_hermes/dyn_boot.f90 | 4 +- GMAO_hermes/dyn_cov.f90 | 24 +-- GMAO_hermes/dyn_efsens.f90 | 22 +-- GMAO_hermes/dyn_inflate.f90 | 34 ++-- GMAO_hermes/dyn_iupd.F90 | 8 +- GMAO_hermes/dyn_ncf2dyn.f90 | 8 +- GMAO_hermes/dyn_pert_remap.F90 | 17 +- GMAO_hermes/dyn_rankhist.F90 | 28 +-- GMAO_hermes/dyn_recenter.f90 | 44 ++--- GMAO_hermes/dyndiff.f90 | 37 ++-- GMAO_hermes/dyndot.f90 | 10 +- GMAO_hermes/dynp.f90 | 30 ++-- GMAO_hermes/eta_echo.f90 | 56 +++--- GMAO_hermes/gcmbkg2ana.F | 6 +- GMAO_hermes/getgfiodim.f90 | 12 +- GMAO_hermes/ibc_upd.F | 49 +++--- GMAO_hermes/lcv2prs.F90 | 59 ++++--- GMAO_hermes/m_dyn_util.F90 | 5 +- GMAO_hermes/m_insitu.F | 2 +- GMAO_hermes/m_interp.F90 | 2 +- GMAO_hermes/m_topo_remap.F90 | 6 +- GMAO_hermes/maph_pert.f90 | 22 +-- GMAO_hermes/recalcsfc.F90 | 8 +- GMAO_hermes/reset_time.f | 11 +- GMAO_hermes/rs52dyn.f90 | 8 +- GMAO_hermes/write_eta.F90 | 8 +- GMAO_mpeu/m_random.F | 2 +- 57 files changed, 568 insertions(+), 543 deletions(-) diff --git a/GEOS_Shared/G3_MPI_Util_Mod.F90 b/GEOS_Shared/G3_MPI_Util_Mod.F90 index a14d0b59..2b7ec0cd 100644 --- a/GEOS_Shared/G3_MPI_Util_Mod.F90 +++ b/GEOS_Shared/G3_MPI_Util_Mod.F90 @@ -2,6 +2,7 @@ module G3_MPI_Util_Mod use MAPL + use iso_fortran_env implicit none ! Define Lattice @@ -345,12 +346,12 @@ subroutine g3_scatter_1d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal ) - real(kind=4) qlocal ( lattice%im(lattice%myid) ) + real(kind=REAL32) qglobal( lattice%imglobal ) + real(kind=REAL32) qlocal ( lattice%im(lattice%myid) ) integer status(mpi_status_size) integer comm integer i,n,loc,im,imx,imglobal,myid,npes,ierror,mpi_rkind - real(kind=4), allocatable :: buf(:) + real(kind=REAL32), allocatable :: buf(:) comm = lattice%comm myid = lattice%myid @@ -386,12 +387,12 @@ subroutine g3_scatter_1d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal ) - real(kind=8) qlocal ( lattice%im(lattice%myid) ) + real(kind=REAL64) qglobal( lattice%imglobal ) + real(kind=REAL64) qlocal ( lattice%im(lattice%myid) ) integer status(mpi_status_size) integer comm integer i,n,loc,im,imx,imglobal,myid,npes,ierror,mpi_rkind - real(kind=8), allocatable :: buf(:) + real(kind=REAL64), allocatable :: buf(:) comm = lattice%comm myid = lattice%myid @@ -427,14 +428,14 @@ subroutine g3_scatter_2d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal,lattice%jmglobal ) - real(kind=4) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) + real(kind=REAL32) qglobal( lattice%imglobal,lattice%jmglobal ) + real(kind=REAL32) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) integer status(mpi_status_size) integer comm integer myid,npe,ierror,mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=4), allocatable :: buf(:,:) + real(kind=REAL32), allocatable :: buf(:,:) comm = lattice%comm myid = lattice%myid @@ -490,14 +491,14 @@ subroutine g3_scatter_2d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal,lattice%jmglobal ) - real(kind=8) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) + real(kind=REAL64) qglobal( lattice%imglobal,lattice%jmglobal ) + real(kind=REAL64) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) integer status(mpi_status_size) integer comm integer myid,npe,ierror,mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=8), allocatable :: buf(:,:) + real(kind=REAL64), allocatable :: buf(:,:) comm = lattice%comm myid = lattice%myid @@ -615,14 +616,14 @@ subroutine g3_scatter_3d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) - real(kind=4) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) + real(kind=REAL32) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) + real(kind=REAL32) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) integer status(mpi_status_size) integer comm,lm,L integer myid,npe,ierror,mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=4), allocatable :: buf(:,:,:) + real(kind=REAL32), allocatable :: buf(:,:,:) comm = lattice%comm myid = lattice%myid @@ -683,14 +684,14 @@ subroutine g3_scatter_3d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) - real(kind=8) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) + real(kind=REAL64) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) + real(kind=REAL64) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) integer status(mpi_status_size) integer comm,lm,L integer myid,npe,ierror,mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=8), allocatable :: buf(:,:,:) + real(kind=REAL64), allocatable :: buf(:,:,:) comm = lattice%comm myid = lattice%myid @@ -751,8 +752,8 @@ subroutine g3_gather_1d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal ) - real(kind=4) qlocal ( lattice%im(lattice%myid) ) + real(kind=REAL32) qglobal( lattice%imglobal ) + real(kind=REAL32) qlocal ( lattice%im(lattice%myid) ) integer status(mpi_status_size) integer comm, mpi_rkind integer i,n,loc,im,imx,myid,npes,ierror @@ -786,8 +787,8 @@ subroutine g3_gather_1d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal ) - real(kind=8) qlocal ( lattice%im(lattice%myid) ) + real(kind=REAL64) qglobal( lattice%imglobal ) + real(kind=REAL64) qlocal ( lattice%im(lattice%myid) ) integer status(mpi_status_size) integer comm, mpi_rkind integer i,n,loc,im,imx,myid,npes,ierror @@ -821,14 +822,14 @@ subroutine g3_gather_2d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal,lattice%jmglobal ) - real(kind=4) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) + real(kind=REAL32) qglobal( lattice%imglobal,lattice%jmglobal ) + real(kind=REAL32) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) integer status(mpi_status_size) integer comm, mpi_rkind integer myid,npe,ierror integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=4), allocatable :: buf(:,:) + real(kind=REAL32), allocatable :: buf(:,:) mpi_rkind = mpi_real comm = lattice%comm @@ -883,14 +884,14 @@ subroutine g3_gather_2d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal,lattice%jmglobal ) - real(kind=8) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) + real(kind=REAL64) qglobal( lattice%imglobal,lattice%jmglobal ) + real(kind=REAL64) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) integer status(mpi_status_size) integer comm, mpi_rkind integer myid,npe,ierror integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=8), allocatable :: buf(:,:) + real(kind=REAL64), allocatable :: buf(:,:) mpi_rkind = mpi_double_precision comm = lattice%comm @@ -945,14 +946,14 @@ subroutine g3_gather_3d_r4 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=4) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) - real(kind=4) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) + real(kind=REAL32) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) + real(kind=REAL32) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) integer status(mpi_status_size) integer comm,lm,L integer myid,npe,ierror, mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=4), allocatable :: buf(:,:,:) + real(kind=REAL32), allocatable :: buf(:,:,:) mpi_rkind = mpi_real comm = lattice%comm @@ -1012,14 +1013,14 @@ subroutine g3_gather_3d_r8 ( qglobal,qlocal,lattice ) ! ********************************************************************** implicit none type ( dynamics_lattice_type ) lattice - real(kind=8) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) - real(kind=8) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) + real(kind=REAL64) qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) + real(kind=REAL64) qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) integer status(mpi_status_size) integer comm,lm,L integer myid,npe,ierror, mpi_rkind integer nx,i,iloc,im,imx,imglobal,isum integer ny,j,jloc,jm,jmy,jmglobal,jsum - real(kind=8), allocatable :: buf(:,:,:) + real(kind=REAL64), allocatable :: buf(:,:,:) mpi_rkind = mpi_double_precision comm = lattice%comm @@ -1651,26 +1652,26 @@ subroutine g3_gmean_2d_r4 ( q,qave4,lattice ) implicit none type ( dynamics_lattice_type ) lattice real q( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) - real*8 cosp( lattice%jm(lattice%pej) ) - real*8 qdum - real*8 qave + real(kind=REAL64) cosp( lattice%jm(lattice%pej) ) + real(kind=REAL64) qdum + real(kind=REAL64) qave real qave4 - real*8 dlat,dlon,phi + real(kind=REAL64) dlat,dlon,phi integer i,j,ierror integer im,jm im = lattice%im(lattice%pei) jm = lattice%jm(lattice%pej) - dlon = 2_8*MAPL_PI/ lattice%imglobal + dlon = 2_REAL64*MAPL_PI/ lattice%imglobal dlat = MAPL_PI/(lattice%jmglobal-1) do j=1,jm - phi = -0.5_8*MAPL_PI + (lattice%jglobal(j)-1)*dlat + phi = -0.5_REAL64*MAPL_PI + (lattice%jglobal(j)-1)*dlat cosp(j) = dcos(phi) enddo - qdum = 0.0_8 + qdum = 0.0_REAL64 do j=1,jm do i=1,im qdum = qdum + q(i,j) * cosp(j)*dlon*dlat @@ -1698,12 +1699,12 @@ subroutine g3_gmean_3d_r4 ( q,qave4,dp,lattice ) type ( dynamics_lattice_type ) lattice real q( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) real dp( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) - real*8 cosp( lattice%jm(lattice%pej) ) - real*8 qdum - real*8 qave + real(kind=REAL64) cosp( lattice%jm(lattice%pej) ) + real(kind=REAL64) qdum + real(kind=REAL64) qave real qave4 - real*8 dlat,dlon,phi + real(kind=REAL64) dlat,dlon,phi integer i,j,L,ierror integer im,jm,lm @@ -1711,14 +1712,14 @@ subroutine g3_gmean_3d_r4 ( q,qave4,dp,lattice ) jm = lattice%jm(lattice%pej) lm = lattice%lm - dlon = 2_8*MAPL_PI/ lattice%imglobal + dlon = 2_REAL64*MAPL_PI/ lattice%imglobal dlat = MAPL_PI/(lattice%jmglobal-1) do j=1,jm - phi = -0.5_8*MAPL_PI + (lattice%jglobal(j)-1)*dlat + phi = -0.5_REAL64*MAPL_PI + (lattice%jglobal(j)-1)*dlat cosp(j) = dcos(phi) enddo - qdum = 0.0_8 + qdum = 0.0_REAL64 do L=1,lm do j=1,jm do i=1,im @@ -1747,25 +1748,25 @@ subroutine g3_gmean_2d_r8 ( q,qave,lattice ) implicit none type ( dynamics_lattice_type ) lattice real q( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) - real*8 cosp( lattice%jm(lattice%pej) ) - real*8 qdum - real*8 qave + real(kind=REAL64) cosp( lattice%jm(lattice%pej) ) + real(kind=REAL64) qdum + real(kind=REAL64) qave - real*8 dlat,dlon,phi + real(kind=REAL64) dlat,dlon,phi integer i,j,ierror integer im,jm im = lattice%im(lattice%pei) jm = lattice%jm(lattice%pej) - dlon = 2_8*MAPL_PI/ lattice%imglobal + dlon = 2_REAL64*MAPL_PI/ lattice%imglobal dlat = MAPL_PI/(lattice%jmglobal-1) do j=1,jm - phi = -0.5_8*MAPL_PI + (lattice%jglobal(j)-1)*dlat + phi = -0.5_REAL64*MAPL_PI + (lattice%jglobal(j)-1)*dlat cosp(j) = dcos(phi) enddo - qdum = 0.0_8 + qdum = 0.0_REAL64 do j=1,jm do i=1,im qdum = qdum + q(i,j) * cosp(j)*dlon*dlat @@ -1792,11 +1793,11 @@ subroutine g3_gmean_3d_r8 ( q,qave,dp,lattice ) type ( dynamics_lattice_type ) lattice real q( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) real dp( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) - real*8 cosp( lattice%jm(lattice%pej) ) - real*8 qdum - real*8 qave + real(kind=REAL64) cosp( lattice%jm(lattice%pej) ) + real(kind=REAL64) qdum + real(kind=REAL64) qave - real*8 dlat,dlon,phi + real(kind=REAL64) dlat,dlon,phi integer i,j,L,ierror integer im,jm,lm @@ -1804,14 +1805,14 @@ subroutine g3_gmean_3d_r8 ( q,qave,dp,lattice ) jm = lattice%jm(lattice%pej) lm = lattice%lm - dlon = 2_8*MAPL_PI/ lattice%imglobal + dlon = 2_REAL64*MAPL_PI/ lattice%imglobal dlat = MAPL_PI/(lattice%jmglobal-1) do j=1,jm - phi = -0.5_8*MAPL_PI + (lattice%jglobal(j)-1)*dlat + phi = -0.5_REAL64*MAPL_PI + (lattice%jglobal(j)-1)*dlat cosp(j) = dcos(phi) enddo - qdum = 0.0_8 + qdum = 0.0_REAL64 do L=1,lm do j=1,jm do i=1,im @@ -1841,23 +1842,23 @@ subroutine gmean ( q,qave4,dp,im,jm,lm,n,lattice ) integer im,jm,lm real q(im,jm,lm) real dp(im,jm,lm) - real*8 cosp(jm) - real*8 qdum - real*8 qave + real(kind=REAL64) cosp(jm) + real(kind=REAL64) qdum + real(kind=REAL64) qave real qave4 - real*8 dlat,dlon,phi + real(kind=REAL64) dlat,dlon,phi integer i,j,L,n,ierror - dlon = 2_8*MAPL_PI/ lattice%imglobal + dlon = 2_REAL64*MAPL_PI/ lattice%imglobal dlat = MAPL_PI/(lattice%jmglobal-1) do j=1,jm - phi = -0.5_8*MAPL_PI + (lattice%jglobal(j)-1)*dlat + phi = -0.5_REAL64*MAPL_PI + (lattice%jglobal(j)-1)*dlat cosp(j) = dcos(phi) enddo if( lm.gt.1 ) then - qdum = 0.0_8 + qdum = 0.0_REAL64 do L=1,lm do j=1,jm do i=1,im @@ -1866,7 +1867,7 @@ subroutine gmean ( q,qave4,dp,im,jm,lm,n,lattice ) enddo enddo else - qdum = 0.0_8 + qdum = 0.0_REAL64 do j=1,jm do i=1,im qdum = qdum + q(i,j,1)**n * cosp(j)*dlon*dlat @@ -1894,16 +1895,16 @@ subroutine g3_amean_2d_r8 ( q,qave,area,im,jm,comm ) integer im,jm, comm real q( im,jm ) real area( im,jm ) - real*8 qdum1 - real*8 qdum2 - real*8 qave1 - real*8 qave2 - real*8 qave + real(kind=REAL64) qdum1 + real(kind=REAL64) qdum2 + real(kind=REAL64) qave1 + real(kind=REAL64) qave2 + real(kind=REAL64) qave integer i,j,ierror - qdum1 = 0.0_8 - qdum2 = 0.0_8 + qdum1 = 0.0_REAL64 + qdum2 = 0.0_REAL64 do j=1,jm do i=1,im qdum1 = qdum1 + q(i,j)*area(i,j) @@ -2000,7 +2001,7 @@ end subroutine destroy_dynamics_lattice subroutine malloc_1d_r (a,im) implicit none - real(kind=8), dimension(:), pointer :: a + real(kind=REAL64), dimension(:), pointer :: a integer i,im,m if(.not.associated(a)) then allocate(a(im)) @@ -2020,7 +2021,7 @@ end subroutine malloc_1d_r subroutine malloc_2d_r (a,im,jm) implicit none - real(kind=8), dimension(:,:), pointer :: a + real(kind=REAL64), dimension(:,:), pointer :: a integer i,j,m,im,jm if(.not.associated(a)) then allocate(a(im,jm)) @@ -2042,7 +2043,7 @@ end subroutine malloc_2d_r subroutine malloc_3d_r (a,im,jm,lm) implicit none - real(kind=8), dimension(:,:,:), pointer :: a + real(kind=REAL64), dimension(:,:,:), pointer :: a integer i,j,l,im,jm,lm,m if(.not.associated(a)) then allocate(a(im,jm,lm)) @@ -2066,7 +2067,7 @@ end subroutine malloc_3d_r subroutine malloc_4d_r (a,im,jm,lm,nm) implicit none - real(kind=8), dimension(:,:,:,:), pointer :: a + real(kind=REAL64), dimension(:,:,:,:), pointer :: a integer i,j,l,n,im,jm,lm,nm,m if(.not.associated(a)) then allocate(a(im,jm,lm,nm)) diff --git a/GEOS_Shared/Lightning_mod.F90 b/GEOS_Shared/Lightning_mod.F90 index 04ad16cc..df442832 100644 --- a/GEOS_Shared/Lightning_mod.F90 +++ b/GEOS_Shared/Lightning_mod.F90 @@ -16,6 +16,7 @@ module Lightning_mod use MAPL_Mod use Lightning_Toolbox_Mod, only : CalcFlashRate +use iso_fortran_env implicit none private @@ -38,11 +39,11 @@ module Lightning_mod ! !PARAMETERS: - real*8, parameter :: AVOGAD = 6.0221367d+23 ! Avogadro number (mole^-1) - real*8, parameter :: CONVFAC = 2.33e-23 ! 14g of N per mole of NO/ 6.02e23 molecules of NO/mole of NO. - real*8, parameter :: PRODFAC = 1.0e26 ! (joules per flash) * molecules of NO per joule - real*8, parameter :: Pa2hPa = 0.01 - integer,parameter :: hp = KIND( REAL( 0.0, 8 ) ) ! HEMCO type + real(kind=REAL64), parameter :: AVOGAD = 6.0221367d+23 ! Avogadro number (mole^-1) + real(kind=REAL64), parameter :: CONVFAC = 2.33e-23 ! 14g of N per mole of NO/ 6.02e23 molecules of NO/mole of NO. + real(kind=REAL64), parameter :: PRODFAC = 1.0e26 ! (joules per flash) * molecules of NO per joule + real(kind=REAL64), parameter :: Pa2hPa = 0.01 + integer,parameter :: hp = KIND( REAL( 0.0, REAL64 ) ) ! HEMCO type ! !DESCRIPTION: @@ -725,31 +726,31 @@ subroutine flashfit_flipped (cldmas, threshold, ratio_local, ratio_global, midla ! Convective mass flux at desired layer (kg m-2 min-1) ! Warning: Make sure units are correct and that you've accessed the proper vertical layer. - real*8, intent(in) :: cldmas(:, :) + real(kind=REAL64), intent(in) :: cldmas(:, :) ! Desired mean lightning NO production rate (Tg yr-1) (specified in namelist) - real*8, intent(in) :: desired_g_N_prod_rate + real(kind=REAL64), intent(in) :: desired_g_N_prod_rate ! Mass flux threshold (kg m-2 min-1) below which flash rate is assumed to be zero (Read in from file) - real*8, intent(in) :: threshold + real(kind=REAL64), intent(in) :: threshold ! Adjustment factor local flash rates must be multiplied so that monthly average local flash rates (after ! "ratio_global" adjustment) match monthly average local v2.2 climatological OTD/LIS flash rates (Read in from file). ! Note: ratio_local varies monthly. - real*8, intent(inout) :: ratio_local(:,:) + real(kind=REAL64), intent(inout) :: ratio_local(:,:) - real*8, intent(in) :: midLatAdj(:,:) + real(kind=REAL64), intent(in) :: midLatAdj(:,:) ! Adjustment factor local flash rates must be multiplied so that globally averaged ! flash rate matches v2.2 OTD/LIS climatological globally averaged flash rate (Read in from file) ! Note: ratio_global varies monthly. - real*8, intent(in) :: ratio_global + real(kind=REAL64), intent(in) :: ratio_global ! !OUTPUT PARAMETERS: ! Total (CG+IC) flash rate (flashes per grid box per s) - real*8, intent(inout) :: flashrate(:,:) + real(kind=REAL64), intent(inout) :: flashrate(:,:) ! ! DESCRIPTION: !EOP @@ -757,7 +758,7 @@ subroutine flashfit_flipped (cldmas, threshold, ratio_local, ratio_global, midla ! !Local variables - real*8, allocatable :: cldmas_local(:,:) + real(kind=REAL64), allocatable :: cldmas_local(:,:) integer :: shapeCldmas(2) integer :: RC @@ -1257,18 +1258,18 @@ SUBROUTINE emiss_lightning (i1, i2, j1, j2, k1, k2, minDeepCloudTop, ampFactor, REAL, INTENT(IN) :: ampFactor ! > 0, for targeting the observed nitrogen production rate [3.41 Tg yr^{-1}] REAL, INTENT(IN) :: numberNOperFlash ! NO molecules generated by each flash INTEGER, INTENT(IN) :: lwi(i1:i2, j1:j2) ! Flag: 1=water 2=land 3=ice - REAL*8, INTENT(IN) :: flashrate(i1:i2, j1:j2) ! Flash rate [km^{-2} s^{-1}] - REAL*8, INTENT(IN) :: dtrn(i1:i2, j1:j2, k1:k2) ! Detrainment [kg m^{-2} s^{-1}] - REAL*8, INTENT(IN) :: cellDepth(i1:i2, j1:j2, k1:k2) ! Grid cell depth [m] + real(kind=REAL64), INTENT(IN) :: flashrate(i1:i2, j1:j2) ! Flash rate [km^{-2} s^{-1}] + real(kind=REAL64), INTENT(IN) :: dtrn(i1:i2, j1:j2, k1:k2) ! Detrainment [kg m^{-2} s^{-1}] + real(kind=REAL64), INTENT(IN) :: cellDepth(i1:i2, j1:j2, k1:k2) ! Grid cell depth [m] - REAL*8, INTENT(OUT) :: pNOx3D(i1:i2, j1:j2, k1:k2) ! Lightning NO production rate [m^{-3} s^{-1}] - REAL*8, INTENT(OUT) :: kgNOx3D(i1:i2, j1:j2, k1:k2) ! NO production rate [kg m^{-3} s^{-1}] + real(kind=REAL64), INTENT(OUT) :: pNOx3D(i1:i2, j1:j2, k1:k2) ! Lightning NO production rate [m^{-3} s^{-1}] + real(kind=REAL64), INTENT(OUT) :: kgNOx3D(i1:i2, j1:j2, k1:k2) ! NO production rate [kg m^{-3} s^{-1}] ! Local ! ----- INTEGER :: k INTEGER :: status, rc - REAL*8, ALLOCATABLE :: pNOx2D(:,:) ! Lightning NO production [molecules NO m^{-2} s^{-1}] + real(kind=REAL64), ALLOCATABLE :: pNOx2D(:,:) ! Lightning NO production [molecules NO m^{-2} s^{-1}] CHARACTER(LEN=*), PARAMETER :: Iam = "emiss_lightning" rc = 0 status = 0 @@ -1344,14 +1345,14 @@ subroutine partition (i1,i2,j1,j2,k1,k2,pNOx2D,dtrn,cellDepth,minDeepCloudTop,lw ! !INPUT PARAMETERS: integer :: i1, i2, j1, j2, k1, k2 - real*8, intent(in) :: pNOx2D(:,:) - real*8, intent(in) :: dtrn(:,:,:) ! Detrainment [kg m^{-2}s^{-1}] - real*8, intent(in) :: cellDepth(:,:,:) ! Grid cell depth [m] + real(kind=REAL64), intent(in) :: pNOx2D(:,:) + real(kind=REAL64), intent(in) :: dtrn(:,:,:) ! Detrainment [kg m^{-2}s^{-1}] + real(kind=REAL64), intent(in) :: cellDepth(:,:,:) ! Grid cell depth [m] real, intent(in) :: minDeepCloudTop ! Minimum cloud top [km] for selecting deep convection profiles integer, intent(in) :: lwi(:,:) ! !OUTPUT PARAMETERS: - REAL*8, intent(out) :: pNOx3D(i1:i2, j1:j2, k1:k2) ! Scaled production rate (no units conversion here) + real(kind=REAL64), intent(out) :: pNOx3D(i1:i2, j1:j2, k1:k2) ! Scaled production rate (no units conversion here) ! !Local Variables character(len=*), parameter :: Iam = "partition" @@ -1518,15 +1519,15 @@ subroutine partitionnox (lprslay, imonth, dtrn, mass, pnox2d, pnox3d) implicit none ! !INPUT PARAMETERS: - real*8, allocatable, intent(in) :: lprslay(:,:,:) + real(kind=REAL64), allocatable, intent(in) :: lprslay(:,:,:) integer, intent(in) :: imonth - real*8, intent(in) :: dtrn(:,:,:) - real*8, intent(in) :: mass(:,:,:) + real(kind=REAL64), intent(in) :: dtrn(:,:,:) + real(kind=REAL64), intent(in) :: mass(:,:,:) ! integer, intent(in) :: cmi_flags(i1:i2, ju1:j2) - real*8, intent(in) :: pnox2d(:,:) + real(kind=REAL64), intent(in) :: pnox2d(:,:) ! !OUTPUT PARAMETERS: - real*8, intent(inout) :: pnox3d(:,:,:) + real(kind=REAL64), intent(inout) :: pnox3d(:,:,:) ! ! DESCRIPTION: @@ -1561,12 +1562,12 @@ subroutine partitionnox (lprslay, imonth, dtrn, mass, pnox2d, pnox3d) integer :: il,ij,ik,iktop ! old indices / counters integer :: IM, JM, LME, LM ! new indices using shape array information - real*8 :: ppmtoppv ! conversion from parts per mass to parts per vol. + real(kind=REAL64) :: ppmtoppv ! conversion from parts per mass to parts per vol. - real*8, allocatable :: ztop(:,:,:) ! cloud layer tops - real*8, allocatable :: htedge2(:) ! Top edge heights after adjusting to match model-cloud - real*8, allocatable :: fd0(:) ! Used to calc cont of each "model-cloud" - real*8, allocatable :: yout(:) ! Layer to each CTM cloud layer + real(kind=REAL64), allocatable :: ztop(:,:,:) ! cloud layer tops + real(kind=REAL64), allocatable :: htedge2(:) ! Top edge heights after adjusting to match model-cloud + real(kind=REAL64), allocatable :: fd0(:) ! Used to calc cont of each "model-cloud" + real(kind=REAL64), allocatable :: yout(:) ! Layer to each CTM cloud layer integer, allocatable :: inox1(:,:) ! "Model-cloud" type indices integer, allocatable :: ntop(:,:) ! Top cloud layer indices @@ -1574,7 +1575,7 @@ subroutine partitionnox (lprslay, imonth, dtrn, mass, pnox2d, pnox3d) integer,parameter :: pmax(4) = (/ 17, 17, 16, 15 /) integer :: shapeArray (3) - real*8 :: r0(17,4) + real(kind=REAL64) :: r0(17,4) ikmm = 40 !? What is this, and does it work for layers other than GEOS (72)? @@ -1772,18 +1773,18 @@ subroutine calculateProductionNox (midLatAdj, flashrate, desired_g_N_prod_rate, implicit none ! !INPUT PARAMETERS: - real*8, intent(in) :: midLatAdj(:,:) + real(kind=REAL64), intent(in) :: midLatAdj(:,:) ! Total (CG+IC) flash rate (flashes per grid box per s) - real*8, intent(in) :: flashrate(:,:) + real(kind=REAL64), intent(in) :: flashrate(:,:) ! Desired mean lightning NO production rate (Tg yr-1) (specified in namelist) - real*8, intent(in) :: desired_g_N_prod_rate + real(kind=REAL64), intent(in) :: desired_g_N_prod_rate ! !OUTPUT PARAMETERS: ! Lightning NO production rate (g N per grid box per s) - real*8, intent(out) :: pnox(:,:) + real(kind=REAL64), intent(out) :: pnox(:,:) ! !DESCRIPTION ! Calculate N production rate (g s-1). @@ -1805,12 +1806,12 @@ subroutine readLightRatioGlobalData & character (len=*) :: light_ratioGlobal_infile_name - real*8, intent(out) :: ratioGlobalLight + real(kind=REAL64), intent(out) :: ratioGlobalLight integer, intent(in) :: nym logical, intent(in) :: pr_diag, rootProc integer :: ii, mm, asc_lun, ierr - real*8 :: readRatio + real(kind=REAL64) :: readRatio character (len=256) :: err_msg diff --git a/GEOS_Shared/OVP.F90 b/GEOS_Shared/OVP.F90 index 61c2bbc8..e5deedbe 100644 --- a/GEOS_Shared/OVP.F90 +++ b/GEOS_Shared/OVP.F90 @@ -14,6 +14,7 @@ module OVP use ESMF use MAPL + use iso_fortran_env implicit none private @@ -185,7 +186,7 @@ subroutine OVP_mask ( LONS, DELTA_TIME, OVERPASS_HOUR, MASK ) ALLOCATE( MASK( SIZE(LONS(:,1)), SIZE(LONS(1,:)) ) ) ! RETURN VALUE - SECONDS_AWAY = LONS*(180._8/MAPL_PI_R8)*240. - OVERPASS_HOUR*60*60 + SECONDS_AWAY = LONS*(180._REAL64/MAPL_PI_R8)*240. - OVERPASS_HOUR*60*60 CALL RESET_TIME_RANGE(SECONDS_AWAY) diff --git a/GEOS_Shared/calcdbz.F b/GEOS_Shared/calcdbz.F index 88cbd3a6..da4aabb7 100644 --- a/GEOS_Shared/calcdbz.F +++ b/GEOS_Shared/calcdbz.F @@ -160,8 +160,8 @@ SUBROUTINE CALCDBZ(DBZ,PRS,TMK,QVP,QRA,QSN,QGR,WEDIM,SNDIM,BTDIM, IF (IVARINT.EQ.1) THEN - TEMP_C = DMIN1(-0.001D0,TMK(I,J,K)-CELKEL) - SONV = DMIN1(2.0D8,2.0D6*EXP(-0.12D0*TEMP_C)) + TEMP_C = MIN(-0.001D0,TMK(I,J,K)-CELKEL) + SONV = MIN(2.0D8,2.0D6*EXP(-0.12D0*TEMP_C)) GONV = GON IF (QGR(I,J,K).GT.R1) THEN diff --git a/GEOS_Shared/lightning_toolbox_mod.F90 b/GEOS_Shared/lightning_toolbox_mod.F90 index 424add9a..71f87eeb 100644 --- a/GEOS_Shared/lightning_toolbox_mod.F90 +++ b/GEOS_Shared/lightning_toolbox_mod.F90 @@ -31,6 +31,8 @@ MODULE Lightning_Toolbox_Mod ! ! !USES: ! + + use iso_fortran_env IMPLICIT NONE PRIVATE ! @@ -56,18 +58,18 @@ MODULE Lightning_Toolbox_Mod ! ! !DEFINED PARAMETERS: ! - INTEGER, PARAMETER :: hp = KIND( REAL( 0.0, 8 ) ) + INTEGER, PARAMETER :: hp = KIND( REAL( 0.0, REAL64 ) ) ! Parameter for LFR calculation - REAL*8, PARAMETER :: RFLASH_MIDLAT = 3.011d26 ! 500 mol/flash - REAL*8, PARAMETER :: RFLASH_TROPIC = 1.566d26 ! 260 mol/flash - REAL*8, PARAMETER :: EAST_WEST_DIV = -30d0 - REAL*8, PARAMETER :: WEST_NS_DIV = 35d0 - REAL*8, PARAMETER :: EAST_NS_DIV = 35d0 - REAL*8, PARAMETER :: T_NEG_BOT = 273.0d0 ! 0 C - REAL*8, PARAMETER :: T_NEG_CTR = 258.0d0 ! -15 C - REAL*8, PARAMETER :: T_NEG_TOP = 233.0d0 ! -40 C - REAL*8, PARAMETER :: Rdg0 = 287.0e+0_hp / 9.80665e+0_hp ! Rd/g0 + real(kind=REAL64), PARAMETER :: RFLASH_MIDLAT = 3.011d26 ! 500 mol/flash + real(kind=REAL64), PARAMETER :: RFLASH_TROPIC = 1.566d26 ! 260 mol/flash + real(kind=REAL64), PARAMETER :: EAST_WEST_DIV = -30d0 + real(kind=REAL64), PARAMETER :: WEST_NS_DIV = 35d0 + real(kind=REAL64), PARAMETER :: EAST_NS_DIV = 35d0 + real(kind=REAL64), PARAMETER :: T_NEG_BOT = 273.0d0 ! 0 C + real(kind=REAL64), PARAMETER :: T_NEG_CTR = 258.0d0 ! -15 C + real(kind=REAL64), PARAMETER :: T_NEG_TOP = 233.0d0 ! -40 C + real(kind=REAL64), PARAMETER :: Rdg0 = 287.0e+0_hp / 9.80665e+0_hp ! Rd/g0 CONTAINS !EOC @@ -139,13 +141,13 @@ SUBROUTINE CalcFlashRate( am_I_Root, IM, JM, LM, AREA_M2, LWI2D, & INTEGER :: I, J, L, LCHARGE INTEGER :: LMAX, LTOP, LBOTTOM, A_KM2 INTEGER :: LTOP1, LTOP2 - REAL*8 :: XMID, YMID, CC, DLNP - REAL*8 :: DZ, FLASHRATE, H0, HBOTTOM - REAL*8 :: HCHARGE, IC_CG_RATIO, Z_CG, ZUP - REAL*8 :: RATE_SAVE, REDIST, T1, T2 - REAL*8 :: TOTAL, TOTAL_CG, TOTAL_IC, X - REAL*8 :: P1, P2, P3, RATE - REAL*8 :: Z_IC + real(kind=REAL64) :: XMID, YMID, CC, DLNP + real(kind=REAL64) :: DZ, FLASHRATE, H0, HBOTTOM + real(kind=REAL64) :: HCHARGE, IC_CG_RATIO, Z_CG, ZUP + real(kind=REAL64) :: RATE_SAVE, REDIST, T1, T2 + real(kind=REAL64) :: TOTAL, TOTAL_CG, TOTAL_IC, X + real(kind=REAL64) :: P1, P2, P3, RATE + real(kind=REAL64) :: Z_IC INTEGER :: SFCTYPE !================================================================= @@ -769,12 +771,12 @@ SUBROUTINE Flashes_CTH( I, J, HEIGHT, FLASHRATE, SFCTYPE ) ! INTEGER, INTENT(IN) :: I ! Longitude index INTEGER, INTENT(IN) :: J ! Latitude index - REAL*8, INTENT(IN) :: HEIGHT ! Height of conv cloud top [m] + real(kind=REAL64), INTENT(IN) :: HEIGHT ! Height of conv cloud top [m] INTEGER, INTENT(IN) :: SFCTYPE ! Surface type (0=land, 1=water, 2=ice) ! ! !OUTPUT PARAMETERS: ! - REAL*8, INTENT(OUT) :: FLASHRATE ! LightNOX flash rate [flashes/min] + real(kind=REAL64), INTENT(OUT) :: FLASHRATE ! LightNOX flash rate [flashes/min] ! ! !REVISION HISTORY: ! 10 May 2006 - L. Murray - Initial version @@ -849,11 +851,11 @@ FUNCTION Get_IC_CG_ratio( CCTHICK ) RESULT( IC_CG_RATIO ) ! ! !INPUT PARAMETERS: ! - REAL*8, INTENT(IN) :: CCTHICK ! Cold cloud thickness [m] + real(kind=REAL64), INTENT(IN) :: CCTHICK ! Cold cloud thickness [m] ! ! !RETURN VALUE: ! - REAL*8 :: IC_CG_RATIO ! Intra-cloud/cloud-ground ratio + real(kind=REAL64) :: IC_CG_RATIO ! Intra-cloud/cloud-ground ratio ! ! !REVISION HISTORY: ! 11 Dec 2006 - R. Yantosca - Initial version @@ -869,7 +871,7 @@ FUNCTION Get_IC_CG_ratio( CCTHICK ) RESULT( IC_CG_RATIO ) ! ! !LOCAL VARIABLES: ! - REAL*8 :: CC, F_CG + real(kind=REAL64) :: CC, F_CG !================================================================= ! GET_IC_CG_RATIO begins here! @@ -969,17 +971,17 @@ SUBROUTINE LightDist( NZ, NNLIGHT, NLTYPE, LTOP, H0, XLAT, TOTAL, & INTEGER, INTENT(IN) :: NNLIGHT ! Dimension 1 of profile array INTEGER, INTENT(IN) :: NLTYPE ! Dimension 2 of profile array INTEGER, INTENT(IN) :: LTOP ! Level of conv cloud top - REAL*8, INTENT(IN) :: H0 ! Conv cloud top height [m] - REAL*8, INTENT(IN) :: XLAT ! Latitude value [degrees] - REAL*8, INTENT(IN) :: TOTAL ! Column Total # of LNOx molec + real(kind=REAL64), INTENT(IN) :: H0 ! Conv cloud top height [m] + real(kind=REAL64), INTENT(IN) :: XLAT ! Latitude value [degrees] + real(kind=REAL64), INTENT(IN) :: TOTAL ! Column Total # of LNOx molec REAL(hp), INTENT(IN) :: BXHEIGHT_M(NZ) ! Boxheights in meter INTEGER, INTENT(IN) :: SFCTYPE ! Surface type INTEGER, INTENT(IN) :: cMt ! Current month - REAL*8, INTENT(IN) :: PROFILE(NNLIGHT, NLTYPE ) ! Profile tables + real(kind=REAL64), INTENT(IN) :: PROFILE(NNLIGHT, NLTYPE ) ! Profile tables ! ! !OUTPUT PARAMETERS: ! - REAL*8, INTENT(OUT) :: VERTPROF(NZ) ! Vertical profile + real(kind=REAL64), INTENT(OUT) :: VERTPROF(NZ) ! Vertical profile INTEGER, INTENT(OUT) :: MTYPE ! lightning type ! ! !REMARKS: @@ -1029,8 +1031,8 @@ SUBROUTINE LightDist( NZ, NNLIGHT, NLTYPE, LTOP, H0, XLAT, TOTAL, & ! !LOCAL VARIABLES: ! INTEGER :: L - REAL*8 :: ZHEIGHT, YMID - REAL*8 :: FRAC(NZ) + real(kind=REAL64) :: ZHEIGHT, YMID + real(kind=REAL64) :: FRAC(NZ) !================================================================= ! LIGHTDIST begins here! diff --git a/GEOS_Util/plots/zonal.f b/GEOS_Util/plots/zonal.f index 6611d0f2..dde8eead 100644 --- a/GEOS_Util/plots/zonal.f +++ b/GEOS_Util/plots/zonal.f @@ -44,15 +44,15 @@ PROGRAM main real undef, lat0 integer im,jm,lm,tm integer j,L,n,nt,lrec - integer rc,nargs,iargc + integer rc,nargs undef = 1e15 - nargs = iargc() + nargs = command_argument_count() if( nargs.ne.0 ) then allocate( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-tag' ) tag = '.' // arg(n+1) diff --git a/GEOS_Util/post/CMakeLists.txt b/GEOS_Util/post/CMakeLists.txt index 4fb5a3a7..223a1b41 100644 --- a/GEOS_Util/post/CMakeLists.txt +++ b/GEOS_Util/post/CMakeLists.txt @@ -77,7 +77,7 @@ target_link_libraries (ec_prs2eta.x ${this} GMAO_gfio_r4 MAPL) target_link_libraries (era5_prs2eta.x ${this} GMAO_gfio_r4 MAPL) target_link_libraries (ec_prs2fv.x ${this} GMAO_gfio_r4 MAPL) target_link_libraries (stats.x post_nompi GMAO_gfio_r4 MAPL ${ESMF_LIBRARIES}) -target_link_libraries (flat2hdf.x post_nompi GMAO_gfio_r4) +target_link_libraries (flat2hdf.x post_nompi) target_link_libraries (gg2fv.x post) target_link_libraries (rs2hdf.x post) target_link_libraries (time_ave.x ${this} GMAO_gfio_r4 MAPL ) diff --git a/GEOS_Util/post/binarytile.F90 b/GEOS_Util/post/binarytile.F90 index 9fc2d219..cdf5e420 100644 --- a/GEOS_Util/post/binarytile.F90 +++ b/GEOS_Util/post/binarytile.F90 @@ -19,9 +19,9 @@ Program binarytile character(len=128) :: filenameOUT integer, parameter :: max_rec=2 - call getarg(1,filenameIN) + call get_command_argument(1,filenameIN) if (filenameIN == "") filenameIN = 'input' - call getarg(2,filenameOUT) + call get_command_argument(2,filenameOUT) if (filenameOUT == "") filenameOUT = 'output' open(unit=unitR, file=filenameIN, form='FORMATTED') diff --git a/GEOS_Util/post/flat2hdf.F b/GEOS_Util/post/flat2hdf.F index 0896dd2e..05cf4f17 100644 --- a/GEOS_Util/post/flat2hdf.F +++ b/GEOS_Util/post/flat2hdf.F @@ -47,7 +47,7 @@ program main character*2 time0 character*1 char - integer n,m,nargs,iargc,L,nfiles + integer n,m,nargs,L,nfiles real undef @@ -90,13 +90,13 @@ end subroutine read_ctl yrev = .false. ecmwf = .false. - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1),*) nymd0 @@ -857,7 +857,7 @@ subroutine usage() print *, " ALL Grads Keywords MUST BE lowercase (eg: xdef, options, sequential, etc.)" print * print * - call exit(7) + error stop 7 end subroutine usage subroutine qsat (tt,p,q,dqdt,ldqdt) diff --git a/GEOS_Util/post/fvrst.F b/GEOS_Util/post/fvrst.F index 85f3191e..1e6d72a1 100644 --- a/GEOS_Util/post/fvrst.F +++ b/GEOS_Util/post/fvrst.F @@ -22,7 +22,7 @@ program main character*512 dynrst character*512, allocatable :: arg(:) - integer nargs,iargc,n + integer nargs,n logical HEADER integer :: filetype,rc type(Netcdf4_fileformatter) :: fmt @@ -30,12 +30,12 @@ program main HEADER = .false. - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) stop allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) HEADER = .true. diff --git a/GEOS_Util/post/mpi_util.F b/GEOS_Util/post/mpi_util.F index ac461252..6744af4c 100644 --- a/GEOS_Util/post/mpi_util.F +++ b/GEOS_Util/post/mpi_util.F @@ -1370,10 +1370,10 @@ subroutine my_exit (irc) integer irc #if (mpi) integer ierror - call system ('touch gcm_error') + call execute_command_line ('touch gcm_error') call mpi_finalize (ierror) #endif - call exit (irc) + error stop irc return end diff --git a/GEOS_Util/post/rs_numtiles.F90 b/GEOS_Util/post/rs_numtiles.F90 index d86d0da7..3e0a42f1 100644 --- a/GEOS_Util/post/rs_numtiles.F90 +++ b/GEOS_Util/post/rs_numtiles.F90 @@ -32,7 +32,7 @@ program rs_numtiles write (output_unit,*) " This program looks at the first record of a binary restart. If" write (output_unit,*) " that record has subtiles, it will be a multiple of the number" write (output_unit,*) " of tiles." - call exit(2) + error stop 2 end if call get_command_argument(1, fname1) diff --git a/GEOS_Util/post/stats.F90 b/GEOS_Util/post/stats.F90 index 6b616b5e..b46e4841 100644 --- a/GEOS_Util/post/stats.F90 +++ b/GEOS_Util/post/stats.F90 @@ -26,6 +26,7 @@ end module stats_mod program stats use stats_mod use ESMF + use iso_fortran_env implicit none type(ESMF_Config) :: config @@ -54,7 +55,7 @@ program stats real, allocatable :: corr(:,:,:,:) ! Note: Hardwired for 100 time periods (Max) real, allocatable :: rms(:,:,:,:,:) ! Note: Hardwired for 100 time periods (Max) - real*4 dum(nr) + real(kind=REAL32) dum(nr) ! Original Levels ! --------------- @@ -1632,7 +1633,9 @@ subroutine read_clim_hdf ( nymd,nhms,fields_2d,fields_3d,n2d,n3d,idim,jdim,nl,zl end subroutine read_clim_bin ( nymd,nhms,p,u,v,t,q,h,idim,jdim,ldim,undef ) - + + use iso_fortran_env + implicit none !*********************************************************************** !* GODDARD LABORATORY FOR ATMOSPHERES * !* Note: Climatology Data is in Grads Format from the files: * @@ -1640,12 +1643,14 @@ subroutine read_clim_bin ( nymd,nhms,p,u,v,t,q,h,idim,jdim,ldim,undef ) !* ncep_1x1_clim.data * !* Climatology Data is stored: January through December * !*********************************************************************** - + + integer :: IM, JM, LM + integer :: idim, jdim, ldim PARAMETER ( IM = 360 ) PARAMETER ( JM = 181 ) PARAMETER ( LM = 10 ) - real*4 bum(IM,JM) + real(kind=REAL32) bum(IM,JM) real dum(IM,JM) real p ( IDIM,JDIM ) @@ -1679,6 +1684,13 @@ subroutine read_clim_bin ( nymd,nhms,p,u,v,t,q,h,idim,jdim,ldim,undef ) INTEGER DAYS(12) DATA DAYS /31,28,31,30,31,30,31,31,30,31,30,31/ + integer :: N, SEC, MONTH, DAY, MIDMON + integer :: imnm, imnp, i, j, l + integer :: ISC, ISCM, ISCP, MONTH2, KU, IMONM, IMONP, MONTH1 + real :: FACP, FACM + + INTEGER :: NSECF, NMONF, NDAYF, NHMS, NYMD + NSECF(N) = N/10000*3600 + MOD(N,10000)/100* 60 + MOD(N,100) NMONF(N) = MOD(N,10000)/100 NDAYF(N) = MOD(N,100) @@ -2361,10 +2373,10 @@ subroutine bin_10x10 ( z,im,jm,z10x10 ) subroutine read_anal( nymd,nhms,fields_2d,fields_3d,n2d,n3d,idim,jdim,nl,zlev,ana_files,num_ana_files,undef ) use stats_mod implicit none + integer nymd,nhms,n2d,n3d type(fields) :: fields_2d(n2d) type(fields) :: fields_3d(n3d) - integer nymd,nhms,n2d,n3d integer idim,jdim,nl,num_ana_files real zlev(nl) @@ -3159,11 +3171,12 @@ subroutine interp_time ( nymd1,nhms1, nymd2,nhms2, ntimes, num ) END subroutine writit ( q,im,jm,lm,qundef,undef ) + use iso_fortran_env implicit none integer im,jm,lm real q(im,jm,lm) - real*4 dum(im,jm) - real*4 qundef, undef + real(kind=REAL32) dum(im,jm) + real(kind=REAL32) qundef, undef logical defined integer i,j,L do L=1,lm diff --git a/GEOS_Util/post/timer.F b/GEOS_Util/post/timer.F index fb81c60b..cd2f0f82 100644 --- a/GEOS_Util/post/timer.F +++ b/GEOS_Util/post/timer.F @@ -55,7 +55,7 @@ subroutine timebeg (task) #if mpi call mpi_finalize (n) #endif - call exit (101) + error stop 101 endif call clocks ( wclk ) tasks(ntasks) = task @@ -103,7 +103,7 @@ subroutine timeend (task) #if mpi call mpi_finalize (n) #endif - call exit (101) + error stop 101 endif call clocks ( wclk ) diff --git a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/check.F90 b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/check.F90 index 7bc8a9b3..7f3f9dbb 100644 --- a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/check.F90 +++ b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/check.F90 @@ -6,7 +6,7 @@ SUBROUTINE check(status) PRINT *, TRIM(nf90_strerror(status)) PRINT *, "OPS: ERROR in reading NetCDF file for SST & SIC BCs" PRINT *, "NO SST and ICE Boundary Conditions!" - call exit(99) + error stop 99 END IF diff --git a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/lake_data_EIGTHdeg.F90 b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/lake_data_EIGTHdeg.F90 index 6625953f..82bcd68a 100644 --- a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/lake_data_EIGTHdeg.F90 +++ b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/lake_data_EIGTHdeg.F90 @@ -48,7 +48,7 @@ PROGRAM lake_data_EIGTHdeg !--------------------------------------------------------------------------- ! Read all input data parameters (time to proc, files to proc, output resolution) - CALL getarg(1,inputBuffer) + CALL get_command_argument(1,inputBuffer) READ(inputBuffer, *) inputFile CALL read_input(inputFile, iDebug, today, tomrw, fileNames, NLAT_out, NLON_out, iMerra, iAdjust_SST_SIC, SST_Thr, iERR) !--------------------------------------------------------------------------- diff --git a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI.F90 b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI.F90 index 8033937a..ab38128c 100644 --- a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI.F90 +++ b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI.F90 @@ -50,7 +50,7 @@ PROGRAM proc_SST_FRACI !--------------------------------------------------------------------------- ! Read all input data parameters (time to proc, files to proc, output resolution) - CALL getarg(1,inputBuffer) + CALL get_command_argument(1,inputBuffer) READ(inputBuffer, *) inputFile CALL read_input(inputFile, iDebug, today, tomrw, fileNames, NLAT_out, NLON_out, iMerra, iAdjust_SST_SIC, SST_Thr, iERR) !--------------------------------------------------------------------------- diff --git a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI_ostia_quart.F90 b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI_ostia_quart.F90 index 2e98acd9..0aaed50e 100644 --- a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI_ostia_quart.F90 +++ b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI_ostia_quart.F90 @@ -48,7 +48,7 @@ PROGRAM proc_SST_FRACI_quart !--------------------------------------------------------------------------- ! Read all input data parameters (time to proc, files to proc, output resolution) - CALL getarg(1,inputBuffer) + CALL get_command_argument(1,inputBuffer) READ(inputBuffer, *) inputFile CALL read_input_quart(inputFile, iDebug, today, tomrw, fileNames, NLAT_out, NLON_out, iERR, & max_diff_SST, max_diff_ICE) diff --git a/GMAO_etc/mkdrstdate.f b/GMAO_etc/mkdrstdate.f index f06ad63f..8b331cf2 100644 --- a/GMAO_etc/mkdrstdate.f +++ b/GMAO_etc/mkdrstdate.f @@ -7,15 +7,15 @@ character(len=255) :: fname integer :: nymd, nhms, n, argc, iargc - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) then print*, 'GEOS-5 temporary and specific program ' print*, 'to create d_rst file with date and time' print*, ' Usage: mkdrstdate.x nymd nhms' - call exit(0) + stop endif do n=1,argc - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo read(arg(1), * ) nymd read(arg(2), * ) nhms diff --git a/GMAO_etc/rst_date.f b/GMAO_etc/rst_date.f index cfb7c133..3867a9f3 100644 --- a/GMAO_etc/rst_date.f +++ b/GMAO_etc/rst_date.f @@ -6,7 +6,7 @@ integer :: ndummy, nymd, nhms, n do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo drst = trim(arg(1)) diff --git a/GMAO_gfio/GFIO_mean.f90 b/GMAO_gfio/GFIO_mean.f90 index 0bf4b18f..5f8ddb3b 100644 --- a/GMAO_gfio/GFIO_mean.f90 +++ b/GMAO_gfio/GFIO_mean.f90 @@ -685,7 +685,7 @@ Program GFIO_mean ! All done ! -------- - call exit(0) + stop CONTAINS @@ -767,7 +767,6 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & !------------------------------------------------------------------------- integer iarg, argc - integer :: iargc character(len=2048) argv character(len=255) Vars(mVars) @@ -784,7 +783,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & print *, "-------------------------------------------------------------------" print * - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) call usage_() ! Defaults @@ -815,36 +814,36 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) then - exit + stop endif - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if(index(argv,'-o') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, outFile ) + call get_command_argument ( iArg, outFile ) elseif(index(argv,'-tfile') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, out_total_file ) + call get_command_argument ( iArg, out_total_file ) elseif(index(argv,'-cfile') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, out_counter_file ) + call get_command_argument ( iArg, out_counter_file ) else if(index(argv,'-inc') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) inc_hhmmss else if(index(argv,'-date') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) ndate yyyymmdd_new = ndate else if(index(argv,'-time') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) ntime hhmmss_new = ntime else if(index(argv,'-xswap') .gt. 0 ) then @@ -854,22 +853,22 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & else if(index(argv,'-iflag') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) iflag else if(index(argv,'-irflag') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) irflag else if(index(argv,'-vars') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) call split_ ( ',', argv, mVars, Vars, nVars ) else if(index(argv,'-levels') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) call split_ ( ',', argv, mLevs, cLevs, nLevs ) allocate( Levs(nLevs), stat = rc) if ( rc /= 0 ) call die (myname, 'wrong in allocating nLevs') @@ -881,7 +880,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & else if(index(argv,'-prec') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) outPrec else if(index(argv,'-d') .gt. 0 ) then debug = .true. @@ -922,7 +921,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, & read(inFiles(n)(1:i-1),*,iostat=ios) alpha(n) if ( ios /= 0 ) then print *, 'GFIO_mean: invalid alpha in '//trim(inFiles(n)) - call exit(1) + error stop 1 else infiles(n) = inFiles(n)(i+1:) linear_comb = .true. @@ -1051,13 +1050,13 @@ subroutine split_ ( tok, str, mList, List, nList ) if ( j < 1 ) then nList = nList + 1 List(nList) = str(i:) - exit + stop end if nList = nList + 1 List(nList) = str(i:i+j-1) i = i + j + 1 if ( i > l ) then - exit + stop endif end do @@ -1072,7 +1071,7 @@ subroutine die(myname,string) print *, ' ',myname print *, ' ',string print *, ' --------------------------------' - call exit(1) + error stop 1 return end subroutine die ! diff --git a/GMAO_hermes/ana5sfc.F90 b/GMAO_hermes/ana5sfc.F90 index 3d4c4ba0..50b0df64 100644 --- a/GMAO_hermes/ana5sfc.F90 +++ b/GMAO_hermes/ana5sfc.F90 @@ -489,7 +489,7 @@ program Ana5sfc ! call fremem_(x_a) - call exit(0) + stop !............................................................................ @@ -1280,7 +1280,7 @@ subroutine Init_ () character(len=*), parameter :: myname = 'init' - integer i, iarg, argc, iargc, n + integer i, iarg, argc, n character(len=255) argv print * @@ -1297,7 +1297,7 @@ subroutine Init_ () ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 3 ) call usage() iarg = 0 @@ -1307,7 +1307,7 @@ subroutine Init_ () if ( iarg .gt. argc ) then exit endif - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-v' ) .gt. 0 ) then debug = .true. else if (index(argv,'-noFlip' ) .gt. 0 ) then @@ -1317,7 +1317,7 @@ subroutine Init_ () else if (index(argv,'-o' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, ana_sfc_tn ) ! not ana_sfc_fn + call get_command_argument ( iArg, ana_sfc_tn ) ! not ana_sfc_fn else n = n + 1 if ( n .eq. 1 ) then diff --git a/GMAO_hermes/diag2dyn.F b/GMAO_hermes/diag2dyn.F index 13810689..973bc5f6 100644 --- a/GMAO_hermes/diag2dyn.F +++ b/GMAO_hermes/diag2dyn.F @@ -876,7 +876,7 @@ subroutine parse ( diag1_fn, diag2_fn, ana_fn, in_res, out_res, logical, intent(out) :: verbose integer, intent(out) :: time(2), date(2) - integer :: i, iarg, argc, iargc, n, fid, rc, nhms1, vid + integer :: i, iarg, argc, n, fid, rc, nhms1, vid integer :: ntimes, nvars, ngatts character(len=255) argv, out_template, basen @@ -895,7 +895,7 @@ subroutine parse ( diag1_fn, diag2_fn, ana_fn, in_res, out_res, expid = 'unknown' verbose = .false. - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage_() iarg = 0 @@ -903,15 +903,15 @@ subroutine parse ( diag1_fn, diag2_fn, ana_fn, in_res, out_res, do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-o' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, out_template ) + call get_command_argument ( iArg, out_template ) else if (index(argv,'-r' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) out_res = argv(1:3) else if (index(argv,'-v' ) .gt. 0 ) then verbose = .true. @@ -920,7 +920,7 @@ subroutine parse ( diag1_fn, diag2_fn, ana_fn, in_res, out_res, diag1_fn = argv if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, diag2_fn ) + call get_command_argument ( iArg, diag2_fn ) n = n + 1 end if end do diff --git a/GMAO_hermes/drs2dyn.f90 b/GMAO_hermes/drs2dyn.f90 index 0409dff1..e50af479 100644 --- a/GMAO_hermes/drs2dyn.f90 +++ b/GMAO_hermes/drs2dyn.f90 @@ -91,7 +91,7 @@ program drs2dyn write(6,'(3a,i8.8,a,i2.2,a)') ' Created ', trim(dynfile), & ' with dyn-vect for ', nymd, ' at ', nhms/10000, 'Z' print *, '--------------------------------------------------------------------' - call exit(0) + stop CONTAINS @@ -132,7 +132,7 @@ subroutine Init_ ( drsfile, phyfile, bcsfile, dynftmpl, expid, & character*4, parameter :: myname = 'init' - integer nfiles, i, iarg, argc, iargc + integer nfiles, i, iarg, argc integer ires character(len=255) :: etafile, argv, res character*10 str @@ -158,7 +158,7 @@ subroutine Init_ ( drsfile, phyfile, bcsfile, dynftmpl, expid, & ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -169,20 +169,20 @@ subroutine Init_ ( drsfile, phyfile, bcsfile, dynftmpl, expid, & if ( iarg .gt. argc ) then exit end if - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, dynftmpl ) + call get_command_argument ( iarg, dynftmpl ) case ("-expid") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, expid ) + call get_command_argument ( iarg, expid ) case ("-res") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, res ) + call get_command_argument ( iarg, res ) select case (res) case ("a") ires=1 @@ -194,37 +194,37 @@ subroutine Init_ ( drsfile, phyfile, bcsfile, dynftmpl, expid, & ires=4 case default print *, 'Sorry this resolutio not supported' - call exit(1) + error stop 1 end select in = ims(ires) jn = jms(ires) case ('-freq') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) freq case ('-prec') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) prec case ('-nlevs') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) kn if (count(kn==KMS).eq.0) then print *, 'Cannot handle this vertical number of levels' - call exit(1) + error stop 1 endif case ('-ntrac') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) ln if (count(ln==LMS).eq.0) then print *, 'Cannot handle this number of tracers' - call exit(1) + error stop 1 endif case default nfiles = nfiles + 1 @@ -282,7 +282,7 @@ subroutine usage() print * print *, ' Last updated: 30 Sep 2004; Todling ' print * - call exit(1) + error stop 1 end subroutine usage !------------------------------------------------------------------------- diff --git a/GMAO_hermes/dyn2drs.f90 b/GMAO_hermes/dyn2drs.f90 index 6a5b5a25..35373cba 100644 --- a/GMAO_hermes/dyn2drs.f90 +++ b/GMAO_hermes/dyn2drs.f90 @@ -68,7 +68,7 @@ program dyn2drs print *, ' Ozone not found in eta file' ! not really an error else print *, ' Cannot read eta file' - call exit (1) + error stop 1 endif end if @@ -83,7 +83,7 @@ program dyn2drs ! done if(verbose) print *, ' -- dyn2drs.x has successfully ended -- ' - call exit(0) + stop CONTAINS @@ -123,7 +123,7 @@ subroutine init ( etafile, binfile, pick, nymd, nhms, oldana, skipo3, verbose ) integer, parameter :: nfiles_max = 1 character(len=255) :: infile(nfiles_max) character*4, parameter :: myname = 'init' - integer :: i,argc,iarg,iargc,nfiles,leta + integer :: i,argc,iarg,nfiles,leta character*255 :: argv ! defaults @@ -134,14 +134,14 @@ subroutine init ( etafile, binfile, pick, nymd, nhms, oldana, skipo3, verbose ) verbose = .false. skipo3 = .false. - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() nfiles = 0 iarg = 0 lp: do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit lp - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-oldana') .gt. 0 ) then oldana = .TRUE. elseif (index(argv,'-verbose') .gt. 0 ) then @@ -151,16 +151,16 @@ subroutine init ( etafile, binfile, pick, nymd, nhms, oldana, skipo3, verbose ) elseif (index(argv,'-pick') .gt. 0 ) then if ( iarg+2 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nymd iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nhms pick = .true. elseif (index(argv,'-o') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, binfile ) + call get_command_argument ( iArg, binfile ) else nfiles = nfiles + 1 if ( nfiles .gt. nfiles_max ) then diff --git a/GMAO_hermes/dyn2dyn.f90 b/GMAO_hermes/dyn2dyn.f90 index eded76ee..978c71de 100644 --- a/GMAO_hermes/dyn2dyn.f90 +++ b/GMAO_hermes/dyn2dyn.f90 @@ -192,7 +192,7 @@ program dyn2dyn ! All done ! -------- if(associated(xtrnames)) deallocate(xtrnames) - call exit(0) + stop CONTAINS @@ -263,7 +263,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & character*4, parameter :: myname = 'init' - integer iret, i, iarg, argc, iargc + integer iret, i, iarg, argc integer ii,jj,ie,il integer uprec, iprec, ires, jcapusr logical verb, setres, geos4res, setjcap @@ -318,7 +318,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & ! Parse command line ! ------------------ dynfile = 'DEFAULT' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -327,30 +327,30 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-vdc") dophys = .true. case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, dynfile ) + call get_command_argument ( iarg, dynfile ) case ("-lwi") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, lwifile ) + call get_command_argument ( iarg, lwifile ) case ("-rc") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, RCfile ) + call get_command_argument ( iarg, RCfile ) case ("-expid") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, expid ) + call get_command_argument ( iarg, expid ) case ("-res") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, res ) + call get_command_argument ( iarg, res ) select case (res) case ("a") ires=1 @@ -366,13 +366,13 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & ires=6 case default print *, 'Sorry this resolution not supported' - call exit(1) + error stop 1 end select setres = .true. case ("-jcap") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) jcapusr select case (jcapusr) case (62) @@ -389,7 +389,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & ires=6 case default print *, 'Sorry this resolution not supported' - call exit(1) + error stop 1 end select setjcap = .true. case ('-verb') @@ -405,38 +405,38 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & case ('-nlevs') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) kn if (count(kn==KMS).eq.0) then print *, 'Cannot handle this vertical number of levels' - call exit(1) + error stop 1 endif case ('-tracers') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, trnames ) + call get_command_argument ( iarg, trnames ) case ('-pick') if ( iarg+2 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nymd iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nhms pick = .true. case ('-fakedate') if ( iarg+2 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nymdf iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nhmsf fakedate = .true. case ('-freq') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) myfreq case ('-indxlevs') indxlevs = .true. @@ -450,7 +450,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & case ('-prec') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) iprec if(iprec==32)prec=0 if(iprec==64)prec=1 @@ -601,7 +601,7 @@ subroutine usage() print * print *, ' Last updated: 05 Jan 2006; Todling ' print * - call exit(1) + error stop 1 end subroutine usage !................................................................. @@ -609,7 +609,7 @@ end subroutine usage subroutine die ( myname, msg ) character(len=*) :: myname, msg write(*,'(a)') trim(myname) // ': ' // trim(msg) - call exit(1) + error stop 1 end subroutine die !................................................................. diff --git a/GMAO_hermes/dyn2prs.f90 b/GMAO_hermes/dyn2prs.f90 index e2fb486e..7ea6994d 100644 --- a/GMAO_hermes/dyn2prs.f90 +++ b/GMAO_hermes/dyn2prs.f90 @@ -223,7 +223,7 @@ program dyn2prs ! All done ! -------- - call exit(0) + stop CONTAINS @@ -266,7 +266,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, prsfile, & character*4, parameter :: myname = 'init' - integer i, iarg, argc, iargc + integer i, iarg, argc character(len=255) :: etafile, argv print * @@ -278,7 +278,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, prsfile, & ! Parse command line ! ------------------ prsfile = 'dyn.prs.hdf' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -291,32 +291,32 @@ subroutine Init_ ( mfiles, etafiles, nfiles, prsfile, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-South") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv, *) ySouth if (ySouth .ne. 90. .and. ySouth .ne. -90.) call usage() case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, prsfile ) + call get_command_argument ( iarg, prsfile ) case ("-im") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv, *) imOut case ("-jm") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv, *) jmOut case ("-West") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv, *) xWest if (xWest .gt. 0.0) xWest = xWest - 360. case default @@ -388,7 +388,7 @@ subroutine usage() print *, '-etafile(s) input dynamics vector file in' print *, ' hybrid (eta) coordinates' print * - call exit(1) + error stop 1 end subroutine usage !................................................................. @@ -396,7 +396,7 @@ end subroutine usage subroutine die ( myname, msg ) character(len=*) :: myname, msg write(*,'(a)') trim(myname) // ': ' // trim(msg) - call exit(1) + error stop 1 end subroutine die !................................................................. diff --git a/GMAO_hermes/dyn2real_eta.f90 b/GMAO_hermes/dyn2real_eta.f90 index 0dc2a214..c7954d18 100644 --- a/GMAO_hermes/dyn2real_eta.f90 +++ b/GMAO_hermes/dyn2real_eta.f90 @@ -59,9 +59,9 @@ program dyn2real_eta subroutine init_ -integer :: argc,iarg,iargc +integer :: argc,iarg -argc = iargc() +argc = command_argument_count() if ( argc < 1 ) then print * print *, "Usage: dyn_realeta.x dyn_input dyn_output" @@ -70,9 +70,9 @@ subroutine init_ endif iarg = 1 -call GetArg ( iarg, files(1) ) +call get_command_argument ( iarg, files(1) ) iarg = iarg + 1 -call GetArg ( iarg, files(2) ) +call get_command_argument ( iarg, files(2) ) end subroutine init_ diff --git a/GMAO_hermes/dyn2rs5.f90 b/GMAO_hermes/dyn2rs5.f90 index 69e45d36..d31e7fd5 100644 --- a/GMAO_hermes/dyn2rs5.f90 +++ b/GMAO_hermes/dyn2rs5.f90 @@ -67,7 +67,7 @@ program main character*120, allocatable :: arg(:) character*8 date character*2 hour - integer n,nargs,iargc,i,j,L,ID,rc + integer n,nargs,i,j,L,ID,rc ! ********************************************************************** ! **** Initialize Filenames **** @@ -84,11 +84,11 @@ program main nymd_ana = -999 nhms_ana = -999 - nargs = iargc() + nargs = command_argument_count() if(nargs==0) call usage() allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage() @@ -406,5 +406,5 @@ subroutine usage() print *, " moist_internal_restart.ana.yyyymmdd_hhz" print *, " pchem_internal_restart.ana.yyyymmdd_hhz" print * - call exit(7) + error stop 7 end diff --git a/GMAO_hermes/dyn52dyn.f90 b/GMAO_hermes/dyn52dyn.f90 index 7e3b9e99..9783ab3e 100755 --- a/GMAO_hermes/dyn52dyn.f90 +++ b/GMAO_hermes/dyn52dyn.f90 @@ -52,7 +52,7 @@ program main character*120, allocatable :: arg(:) character*8 date character*2 hour - integer n,nargs,iargc,i,j,L + integer n,nargs,i,j,L integer id,rc,timinc,nmax,kbeg,kend,freq integer ntime,nvars,ngatts @@ -67,11 +67,11 @@ program main freq = 6 ! default: frequency of bkg is 6-hrs - nargs = iargc() + nargs = command_argument_count() if(nargs==0) call usage() allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage() @@ -461,6 +461,6 @@ subroutine usage() print *, " -prec PREC where PREC=32 or 64 for 32 or 64 bits output" print *, " -freq FREQ specify frequency of background; default: 6 (hr)" print * - call exit(7) + error stop 7 end diff --git a/GMAO_hermes/dyn_boot.f90 b/GMAO_hermes/dyn_boot.f90 index f6ddda56..682bd9b8 100644 --- a/GMAO_hermes/dyn_boot.f90 +++ b/GMAO_hermes/dyn_boot.f90 @@ -25,14 +25,14 @@ program dyn_boot call dyn_init ( idyn, odyn, ier, copy=.true., vectype=vectype, lm=lm ) if ( ier/=0 ) then print *, trim(myname), ': Error duplicating dyn vector(odyn), ier=', ier - call exit(998) + error stop 998 endif print *, 'writing to: ', ofile call dyn_put ( ofile, nymd, nhms, prec, odyn, ier, freq=freq, nstep=nstep, vectype=vectype ) if ( ier .ne. 0 ) then print *, trim(myname), ': cannot write interpolated ETA file' - call exit(999) + error stop 999 endif call dyn_clean ( odyn ) diff --git a/GMAO_hermes/dyn_cov.f90 b/GMAO_hermes/dyn_cov.f90 index cd2239ed..26b5e8e9 100644 --- a/GMAO_hermes/dyn_cov.f90 +++ b/GMAO_hermes/dyn_cov.f90 @@ -259,7 +259,7 @@ program dyn_cov subroutine init_() implicit none - integer i, iarg, argc, iargc + integer i, iarg, argc integer ncount,nc character(len=255) :: argv real corrlen @@ -272,7 +272,7 @@ subroutine init_() adrate = -9999. corrlen = 800. ! to be read from file - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg=0 @@ -280,43 +280,43 @@ subroutine init_() do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ('-fcstlen') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) fcstlen case ('-mem') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) members case ('-adrate') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) adrate case ('-corrlen') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) corrlen case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) ofile(1) = trim(argv) case ("-ox") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) ofile(2) = trim(argv) case ('-nolocal') @@ -328,10 +328,10 @@ subroutine init_() case default ncount = ncount + 1 if (ncount==1) then - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nymd(1) else if (ncount==2 ) then - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nhms(1) else nc=nc+1 @@ -396,7 +396,7 @@ subroutine usage() print *, ' 1. This program requires error files to have been generated' print *, ' prior to attempting to run it. E.g., see dyndiff.x' print * - call exit(1) + error stop 1 end subroutine usage subroutine globeloc (aloc,lat,lon) diff --git a/GMAO_hermes/dyn_efsens.f90 b/GMAO_hermes/dyn_efsens.f90 index 2ffb4388..f28b9b91 100644 --- a/GMAO_hermes/dyn_efsens.f90 +++ b/GMAO_hermes/dyn_efsens.f90 @@ -153,7 +153,7 @@ program dyn_efsens subroutine init_() implicit none - integer i, iarg, argc, iargc + integer i, iarg, argc integer ncount,nc character(len=255) :: argv real corrlen @@ -168,7 +168,7 @@ subroutine init_() ofile = 'efsens.eta.nc4' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg=0 @@ -176,37 +176,37 @@ subroutine init_() do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ('-fcstlen') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) fcstlen case ('-mem') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) members case ('-adrate') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) adrate case ('-corrlen') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) corrlen case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) ofile = trim(argv) case ('-nolocal') @@ -218,10 +218,10 @@ subroutine init_() case default ncount = ncount + 1 if (ncount==1) then - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nymd(1) else if (ncount==2 ) then - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) nhms(1) else nc=nc+1 @@ -291,7 +291,7 @@ subroutine usage() print *, ' 1. This program requires error files to have been generated' print *, ' prior to attempting to run it. E.g., see dyndiff.x' print * - call exit(1) + error stop 1 end subroutine usage subroutine globeloc (aloc,lat,lon) diff --git a/GMAO_hermes/dyn_inflate.f90 b/GMAO_hermes/dyn_inflate.f90 index 4cab7038..bf7766d9 100644 --- a/GMAO_hermes/dyn_inflate.f90 +++ b/GMAO_hermes/dyn_inflate.f90 @@ -56,7 +56,7 @@ program dyn_inflate if(.not.allocated(ainf)) then print *, 'ainf not defined, aborting ...' - call exit(99) + error stop 99 endif do iv=1,size(vars) if(trim(vars(iv))=='u')then @@ -189,7 +189,7 @@ subroutine init_ (dyntype,files) character(len=*),intent(out) :: files(:) character(len=*), parameter :: myname='init_' - integer iret, i, iarg, argc, iargc + integer iret, i, iarg, argc integer irow,nlevs, ier, nfiles, iv, nivars character(len=255) :: argv character(len=255) :: token @@ -204,14 +204,14 @@ subroutine init_ (dyntype,files) ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() nfiles=0 iarg=0 do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-g4") @@ -219,11 +219,11 @@ subroutine init_ (dyntype,files) case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, ofile ) + call get_command_argument ( iArg, ofile ) case ("-rc") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, RCfile ) + call get_command_argument ( iArg, RCfile ) case default nfiles = nfiles + 1 if ( nfiles .gt. mfiles ) call usage() @@ -253,7 +253,7 @@ subroutine init_ (dyntype,files) nlevs = I90_GInt(iret) else write(stderr,'(2a,i5)') trim(myname),': cannot determine no. of levels, aborting ... ' - call exit(1) + error stop 1 end if write(stdout,'(2a,i5)') trim(myname),': number of inflation vertical levels = ', nlevs @@ -287,7 +287,7 @@ subroutine init_ (dyntype,files) if (iret/=0) then write(stderr,'(2a,i5,2a)') myname, ': I90_label error, iret=', iret, & ': trying to read ', trim(tablename) - call exit(2) + error stop 2 end if irow = 0 write(stdout,'(3a)') ' Reading vertically varying inflation ', trim(vars(iv)), '...' @@ -299,19 +299,19 @@ subroutine init_ (dyntype,files) call I90_GToken(token, ier ) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot read 1st entry in table, aborting ...' - call exit(3) + error stop 3 endif call I90_GToken(token, ier ) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot read 2nd entry in table, aborting ...' - call exit(4) + error stop 4 endif read(token,*) ainf(irow,iv) end if end do if(irow/=nlevs) then write(stderr,'(2a,i5)') trim(myname),': inconsistent number of levels in table, aborting ...' - call exit(4) + error stop 4 endif end do ! iv @@ -322,7 +322,7 @@ subroutine init_ (dyntype,files) ainf_ps = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot addinf_coeff(ps), aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get addinf_coeff(ps) from RC, using default ... ' @@ -336,7 +336,7 @@ subroutine init_ (dyntype,files) ainf_ts = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot addinf_coeff(ts), aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get addinf_coeff(ts) from RC, using default ... ' @@ -350,7 +350,7 @@ subroutine init_ (dyntype,files) pkthresh = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot pkthresh, aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get pthreshold from RC, using default ... ' @@ -377,7 +377,7 @@ subroutine init_ (dyntype,files) m_star = I90_GInt(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot adaptive_smooth_factor(), aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get adaptive_smooth_factor() from RC, no smoothing ... ' @@ -399,7 +399,7 @@ subroutine init_ (dyntype,files) print * else print *, 'not enough input files, aborting ...' - call exit(1) + error stop 1 endif end subroutine init_ @@ -471,7 +471,7 @@ subroutine usage() print *, ' xm_a - ensemble mean analysis file' print *, ' xs_b - ensemble background spread file' print * - call exit(1) + error stop 1 end subroutine usage diff --git a/GMAO_hermes/dyn_iupd.F90 b/GMAO_hermes/dyn_iupd.F90 index 2f69c255..a027195d 100644 --- a/GMAO_hermes/dyn_iupd.F90 +++ b/GMAO_hermes/dyn_iupd.F90 @@ -128,10 +128,10 @@ program dyn_iupd subroutine init_ integer, parameter :: mfiles=2 - integer iargc,argc,nfiles,iarg,i + integer argc,nfiles,iarg,i character(len=256) str,argv - argc = iargc() + argc = command_argument_count() if ( argc < 2 ) then print *, "Usage: dyn_iupd.x [-scale SCALE] finput foutput" print *, " " @@ -144,7 +144,7 @@ subroutine init_ do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ('-scale') if ( iarg+1 .gt. argc ) then @@ -152,7 +152,7 @@ subroutine init_ stop endif iarg = iarg + 1 - call GetArg ( iarg, str ) + call get_command_argument ( iarg, str ) read(str,*) rscale case default nfiles = nfiles + 1 diff --git a/GMAO_hermes/dyn_ncf2dyn.f90 b/GMAO_hermes/dyn_ncf2dyn.f90 index c2b2803a..408a001f 100644 --- a/GMAO_hermes/dyn_ncf2dyn.f90 +++ b/GMAO_hermes/dyn_ncf2dyn.f90 @@ -59,9 +59,9 @@ subroutine init_ (rc) character(len=*),parameter :: myname_ = 'init_' character(len=256) :: argv - integer argc,i,iarg,iargc,nfiles + integer argc,i,iarg,nfiles rc=0 - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) then rc=-1 return @@ -76,7 +76,7 @@ subroutine init_ (rc) do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-o") if ( iarg+1 .gt. argc ) then @@ -84,7 +84,7 @@ subroutine init_ (rc) return endif iarg = iarg + 1 - call GetArg ( iarg, odyn_file ) + call get_command_argument ( iarg, odyn_file ) case default nfiles = nfiles + 1 if ( nfiles .gt. mfiles ) call die(myname_,': too many eta files') diff --git a/GMAO_hermes/dyn_pert_remap.F90 b/GMAO_hermes/dyn_pert_remap.F90 index a10e00ff..1bb7d12d 100644 --- a/GMAO_hermes/dyn_pert_remap.F90 +++ b/GMAO_hermes/dyn_pert_remap.F90 @@ -23,14 +23,13 @@ program dyn_pert_remap character(len=255) argv character(len=3) opt - integer iargc integer iarg,argc,nymd,nhms,freq integer im,jm integer ierr integer idim,odim real dotp0(1),dotp1(1),dotp2(1) !,ddot_ - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) then print * print *, "Purpose: interpolate perturbation vector." @@ -48,17 +47,17 @@ program dyn_pert_remap end if iarg = 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) im iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) jm iarg = iarg + 1 - call GetArg ( iarg, opt ) + call get_command_argument ( iarg, opt ) iarg = iarg + 1 - call GetArg ( iarg, ifile ) + call get_command_argument ( iarg, ifile ) iarg = iarg + 1 - call GetArg ( iarg, ofile ) + call get_command_argument ( iarg, ofile ) ! read input dyn vector ! --------------------- @@ -76,7 +75,7 @@ program dyn_pert_remap idyn%grid%ptop, idyn%grid%ks, idyn%grid%ak, idyn%grid%bk, vectype=5 ) if(ierr/=0)then print *, 'trouble in init ', ierr - call exit(99) + error stop 99 endif if ( opt == 'ppm' ) then @@ -97,7 +96,7 @@ program dyn_pert_remap idyn%grid%ptop, idyn%grid%ks, idyn%grid%ak, idyn%grid%bk, vectype=5 ) if(ierr/=0)then print *, 'trouble in init ', ierr - call exit(99) + error stop 99 endif idim = idyn%grid%im * idyn%grid%jm * idyn%grid%km odim = odyn%grid%im * odyn%grid%jm * odyn%grid%km diff --git a/GMAO_hermes/dyn_rankhist.F90 b/GMAO_hermes/dyn_rankhist.F90 index 0c2c517a..5e04e1b7 100644 --- a/GMAO_hermes/dyn_rankhist.F90 +++ b/GMAO_hermes/dyn_rankhist.F90 @@ -247,7 +247,7 @@ program dyn_rankhist print*, 'Error: something is not adding up' print*, 'sum(hist) = ', sum(hist) print*, 'total samples = ', icnt - call exit(1) + error stop 1 endif print *, 'total number of samples: ', icnt write(fnout,'(2a,i3.3,2a)') & @@ -278,7 +278,7 @@ program dyn_rankhist close(999) open (999,file='DYN_RANKHIST',form='formatted') close(999) - call exit(0) + stop CONTAINS @@ -320,7 +320,7 @@ subroutine Init_ ( dyntype, mfiles, files, members, seed, mean, sigma, & character*4, parameter :: myname = 'init' - integer i, iarg, argc, iargc + integer i, iarg, argc character(len=255) :: argv files = 'NONE' @@ -343,7 +343,7 @@ subroutine Init_ ( dyntype, mfiles, files, members, seed, mean, sigma, & ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -352,7 +352,7 @@ subroutine Init_ ( dyntype, mfiles, files, members, seed, mean, sigma, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-g5") @@ -360,39 +360,39 @@ subroutine Init_ ( dyntype, mfiles, files, members, seed, mean, sigma, & case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, dyn_out ) + call get_command_argument ( iArg, dyn_out ) case ("-mem") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) members case ("-plev") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) plev case ("-normal") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) mean if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) sigma case ("-reg") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, reg ) + call get_command_argument ( iArg, reg ) case ("-seed") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) seed case ("-var") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, var ) + call get_command_argument ( iArg, var ) case ("-h") if ( iarg+1 .gt. argc ) call usage() case ("-verbose") @@ -449,7 +449,7 @@ subroutine usage() print * print *, ' Remarks: ' print * - call exit(1) + error stop 1 end subroutine usage !................................................................. diff --git a/GMAO_hermes/dyn_recenter.f90 b/GMAO_hermes/dyn_recenter.f90 index ba5f508e..20e9f7b8 100644 --- a/GMAO_hermes/dyn_recenter.f90 +++ b/GMAO_hermes/dyn_recenter.f90 @@ -28,6 +28,8 @@ program dyn_recenter use m_inpak90 use m_stdio, only : stdout,stderr + use iso_fortran_env + implicit NONE ! !DESCRIPTION: Used in context of ensemble DAS to recenter dyn-vector @@ -111,8 +113,8 @@ program dyn_recenter integer ks integer lm_mean,lm_pert,lm_central real pabove,pbelow,pkthresh,alpha - real(8) ptop,pint - real(8),allocatable:: ak(:),bk(:) + real(REAL64) ptop,pint + real(REAL64),allocatable:: ak(:),bk(:) real,allocatable:: phis(:,:) real,pointer:: frocean(:,:) real,pointer:: ainf(:,:) @@ -511,7 +513,7 @@ program dyn_recenter close(999) open (999,file='DYNRECENTER_EGRESS',form='formatted') close(999) - call exit(0) + stop CONTAINS @@ -557,7 +559,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & character*4, parameter :: myname = 'init' - integer iret, i, iarg, argc, iargc + integer iret, i, iarg, argc integer irow,nlevs, ier, iv, nivars character(len=255) :: argv character(len=255) :: token @@ -590,7 +592,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -599,7 +601,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-g5") @@ -607,16 +609,16 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & case ("-o") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, dyn_out ) + call get_command_argument ( iArg, dyn_out ) case ("-a") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) alpha case ("-inflate") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, dyn_inflate ) + call get_command_argument ( iArg, dyn_inflate ) case ("-h") if ( iarg+1 .gt. argc ) call usage() case ("-verbose") @@ -633,7 +635,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & case ("-rc") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, RCfile ) + call get_command_argument ( iArg, RCfile ) case default nfiles = nfiles + 1 if ( nfiles .gt. mfiles ) call usage() @@ -675,7 +677,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & nlevs = I90_GInt(iret) else write(stderr,'(2a,i5)') trim(myname),': cannot determine no. of levels, aborting ... ' - call exit(1) + error stop 1 end if ! Read in ocean-only option @@ -721,7 +723,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & if (iret/=0) then write(stderr,'(2a,i5,2a)') myname, ': I90_label error, iret=', iret, & ': trying to read ', trim(tablename) - call exit(2) + error stop 2 end if irow = 0 write(stdout,'(a)') ' Reading vertically varying inflation ...' @@ -733,19 +735,19 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & call I90_GToken(token, ier ) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot read 1st entry in table, aborting ...' - call exit(3) + error stop 3 endif call I90_GToken(token, ier ) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot read 2nd entry in table, aborting ...' - call exit(4) + error stop 4 endif read(token,*) ainf(irow,iv) end if end do if(irow/=nlevs) then write(stderr,'(2a,i5)') trim(myname),': inconsistent number of levels in table, aborting ...' - call exit(4) + error stop 4 endif end do ! iv @@ -756,7 +758,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & ainf_ps = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot addinf_coeff(ps), aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get addinf_coeff(ps) from RC, using default ... ' @@ -770,7 +772,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & ainf_ts = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot addinf_coeff(ts), aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get addinf_coeff(ts) from RC, using default ... ' @@ -784,7 +786,7 @@ subroutine Init_ ( dyntype, mfiles, files, damp, remap2central, remap2member, & pkthresh = I90_GFloat(ier) if(ier/=0) then write(stderr,'(2a,i5)') trim(myname),': cannot pkthresh, aborting ...' - call exit(5) + error stop 5 endif else write(stderr,'(2a)') trim(myname),': cannot get pthreshold from RC, using default ... ' @@ -870,7 +872,7 @@ subroutine usage() print *, ' for this - indeed one might need to do this using ESMF' print *, ' to better handle high-resolution fields.' print * - call exit(1) + error stop 1 end subroutine usage !................................................................. @@ -1065,7 +1067,7 @@ end subroutine my_sscal_ subroutine die ( myname, msg ) character(len=*) :: myname, msg write(*,'(a)') trim(myname) // ': ' // trim(msg) - call exit(1) + error stop 1 end subroutine die !................................................................. @@ -1172,7 +1174,7 @@ subroutine vinter_pert_ (xpi,xpo,ak,bk,dyntype,rc) type(dyn_vect) :: xpi ! input vector type(dyn_vect) :: xpo ! output vector - real(8), intent(in) :: ak(:),bk(:) + real(REAL64), intent(in) :: ak(:),bk(:) integer,intent(in) :: dyntype integer,intent(out) :: rc diff --git a/GMAO_hermes/dyndiff.f90 b/GMAO_hermes/dyndiff.f90 index 48ca890a..f0afa4fb 100644 --- a/GMAO_hermes/dyndiff.f90 +++ b/GMAO_hermes/dyndiff.f90 @@ -14,6 +14,7 @@ program dyndiff use m_dyn use m_dyn_util, only: Dyn_Util_Tv2T use m_dyn_util, only: Dyn_Scale_by_TotEne + use iso_fortran_env implicit NONE @@ -59,7 +60,7 @@ program dyndiff integer ios, rc, iopt, ifile integer ntimes, n, freq, nymd, nhms, prec integer freq_d, nymd_d, nhms_d, prec_d !Timetag for newly created diff in *.hdf format - integer im, jm, km, lm, system, dyntype, irh + integer im, jm, km, lm, dyntype, irh logical dominmax,verb,sbyene,tv2t integer addrh logical normlz @@ -222,7 +223,7 @@ program dyndiff end do ! loop over files st = "rm -f " // trim(binfiles(1)) // " " // trim(binfiles(2)) - rc = system(st) ! rc == 0 for success + call execute_command_line(st,exitstat=rc) ! rc == 0 for success if (rc .ne. 0 ) then print *, "Unable to remove binary files." end if @@ -234,7 +235,7 @@ program dyndiff close(999) open (999,file=trim(egress),form='formatted') close(999) - call exit(0) + stop CONTAINS @@ -287,7 +288,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & character(len=256) :: rcfile character(len=255) :: etafile, argv - integer iret, i, iarg, argc, iargc + integer iret, i, iarg, argc real pnext logical dout logical invalid @@ -327,7 +328,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage() iarg = 0 @@ -336,7 +337,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-g5") @@ -346,26 +347,26 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & case ("-a") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) acoeff case ("-egress") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, egress ) + call get_command_argument ( iArg, egress ) case ("-o") dout = .true. if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, dyn_dout ) + call get_command_argument ( iArg, dyn_dout ) case ("-txt") dout = .true. if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, jnorm ) + call get_command_argument ( iArg, jnorm ) case ("-addrh") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) addrh case ("-tv2t") tv2t = .true. @@ -378,11 +379,11 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & case ("-ntype") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, ntype ) + call get_command_argument ( iArg, ntype ) case ("-rc") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iArg, rcfile ) + call get_command_argument ( iArg, rcfile ) case default nfiles = nfiles + 1 if ( nfiles .gt. mfiles ) call usage() @@ -409,7 +410,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & call i90_loadf (trim(rcfile), iret) if( iret .ne. 0) then write(6,'(2a,i5)') myname_,': I90_loadf error, iret =',iret - call exit (1) + error stop 1 endif ! Read in norm type @@ -432,7 +433,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & eps_eer = I90_GFloat(iret) if( iret .ne. 0) then write(6,'(3a,i5)') myname_,': I90_GFloat error, ', ' iret =',iret - call exit (1) + error stop 1 end if end if write(6,'(a,1p,e13.6)') 'Ehrendorfer, Errico, and Raeder eps: ',eps_eer @@ -571,7 +572,7 @@ subroutine usage() print *, ' for the fact that sometimes file1-file2 not possible, but' print *, ' file2-file1 is possible due to nc4-header issues' print *, ' 3. If addrh<0, mean rh is added to the file (serves BeCov code)' - call exit(1) + error stop 1 end subroutine usage !................................................................. @@ -579,7 +580,7 @@ end subroutine usage subroutine die ( myname, msg ) character(len=*) :: myname, msg write(*,'(a)') trim(myname) // ': ' // trim(msg) - call exit(1) + error stop 1 end subroutine die subroutine getrh_(rh,tv,qv,ps,ak,bk) @@ -590,7 +591,7 @@ subroutine getrh_(rh,tv,qv,ps,ak,bk) real,intent(out):: rh(:,:,:) real,intent(in) :: tv(:,:,:), qv(:,:,:), ps(:,:) real,intent(in) :: ak(:), bk(:) - real(4),allocatable :: tmp(:,:,:),pmk(:,:,:),qs(:,:,:) + real(REAL32),allocatable :: tmp(:,:,:),pmk(:,:,:),qs(:,:,:) integer i,j,k,kb select case (abs(addrh)) case (1) diff --git a/GMAO_hermes/dyndot.f90 b/GMAO_hermes/dyndot.f90 index 3f419568..cd23910d 100644 --- a/GMAO_hermes/dyndot.f90 +++ b/GMAO_hermes/dyndot.f90 @@ -7,7 +7,7 @@ program dyndot integer,parameter :: dyntype=5 integer,parameter :: nfiles=2 integer nymd, nhms, lu, n, freq, vectype, prec, ier, nstep - integer i, nf, iarg, argc, ndim2, ndim3, intarg, iargc + integer i, nf, iarg, argc, ndim2, ndim3, intarg character(len=255) :: dynfile(nfiles) character(len=255) argv type(dyn_vect) w_1 @@ -26,13 +26,13 @@ program dyndot adm=.false. pncf=.false. - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) call usage_() nf=0 do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-use_ps") use_ps = .true. @@ -45,11 +45,11 @@ program dyndot ! case ("-adm") ! if ( iarg+1 .gt. argc ) call usage_() ! iarg = iarg + 1 -! call GetArg ( iarg, argv ) +! call get_command_argument ( iarg, argv ) ! read(argv,*) intarg ! if(intarg>0) adm(1)=.true. ! iarg = iarg + 1 -! call GetArg ( iarg, argv ) +! call get_command_argument ( iarg, argv ) ! read(argv,*) intarg ! if(intarg>0) adm(2)=.true. case default diff --git a/GMAO_hermes/dynp.f90 b/GMAO_hermes/dynp.f90 index c9f7acba..d8c6e113 100644 --- a/GMAO_hermes/dynp.f90 +++ b/GMAO_hermes/dynp.f90 @@ -393,7 +393,7 @@ program dynp print *, '--------------------------' print * - call exit(0) + stop !................................................................................... @@ -429,7 +429,7 @@ subroutine init_ () !EOP !----------------------------------------------------------------------- - integer i, iarg, argc, iargc, ires + integer i, iarg, argc, ires character(len=255) argv logical sin, sout, pin, pout, geos4res, gsires @@ -451,23 +451,23 @@ subroutine init_ () dyn_sout = 'NONE' dyn_pout = 'NONE' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage_() iarg = 0 do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) select case ( argv ) case ("-pick") pick = .true. if ( iarg+2 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nymd_s iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nhms_s case ("-realp") realp = .true. @@ -494,7 +494,7 @@ subroutine init_ () case ("-res") if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, res ) + call get_command_argument ( iArg, res ) select case (res) case ("a") ires=1 @@ -508,38 +508,38 @@ subroutine init_ () ires=5 case default print *, 'Sorry this resolution not supported' - call exit(1) + error stop 1 end select interp = .true. case ("-os") sout = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_sout ) + call get_command_argument ( iArg, dyn_sout ) case ("-op") pout = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_pout ) + call get_command_argument ( iArg, dyn_pout ) case ("-s") sin = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_sin ) + call get_command_argument ( iArg, dyn_sin ) case ("-p") pin = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_pin ) + call get_command_argument ( iArg, dyn_pin ) case ("-a") if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) pcoef case ("-scale") if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) pscal end select end do @@ -670,7 +670,7 @@ subroutine die ( myname, msg ) print * print *, trim(myname) // ': ' // trim(msg) print * - call exit(1) + error stop 1 end subroutine die !....................................................................... diff --git a/GMAO_hermes/eta_echo.f90 b/GMAO_hermes/eta_echo.f90 index 29c87c27..35ff59b4 100644 --- a/GMAO_hermes/eta_echo.f90 +++ b/GMAO_hermes/eta_echo.f90 @@ -2,16 +2,17 @@ program eta_echo use m_set_eta, only: set_eta use m_set_eta, only: get_ref_plevs use m_spline, only: spline +use iso_fortran_env implicit none integer :: nlevs,mlevs integer :: k,km,ks,ii logical :: bot2top, lsingle, lplevs -real(8) :: ptop8, pint8 -real(8),allocatable :: ak8(:),bk8(:) -real(4),allocatable :: hloc(:),zloc(:),betac(:),betae(:) -real(4) :: ak4,bk4 -real(4) :: pbottom +real(REAL64) :: ptop8, pint8 +real(REAL64),allocatable :: ak8(:),bk8(:) +real(REAL32),allocatable :: hloc(:),zloc(:),betac(:),betae(:) +real(REAL32) :: ak4,bk4 +real(REAL32) :: pbottom character(len=255) :: locfname call init_ @@ -36,9 +37,8 @@ program eta_echo subroutine init_ integer argc, iarg - integer iargc character(len=255) :: argv - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) then print *, "Usage: eta_echo.x [options] nlevs" print *, " " @@ -63,18 +63,18 @@ subroutine init_ mlevs=0 iarg = 1 do while (iarg<=argc) - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (argv) case ("-bot2top") bot2top = .true. case ("-p0") iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) pbottom pbottom=pbottom*100. case ("-mlevs") iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) mlevs case ("-plevs") lplevs = .true. @@ -82,7 +82,7 @@ subroutine init_ lsingle = .true. case ("-loc") iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) locfname = trim(argv) case default read(argv,*) nlevs @@ -100,7 +100,7 @@ subroutine get_locs_ if(km/=nlevs) then print *, 'Inconsistent levels: km/nlevs', km, nlevs print *, 'Aborting ...' - call exit(1) + error stop 1 else do k=1,nlevs read(10,*) hloc(k), zloc(k), betac(k), betae(k) @@ -109,11 +109,11 @@ subroutine get_locs_ end subroutine get_locs_ subroutine write_plevs_ - real(8),allocatable :: levn(:) - real(8),allocatable :: levm(:) - real(8),allocatable :: xak(:),xbk(:) - real(4),allocatable :: hlocm(:), zlocm(:), betacm(:), betaem(:) - real(4),allocatable :: dp(:),dz(:),pe(:) + real(REAL64),allocatable :: levn(:) + real(REAL64),allocatable :: levm(:) + real(REAL64),allocatable :: xak(:),xbk(:) + real(REAL32),allocatable :: hlocm(:), zlocm(:), betacm(:), betaem(:) + real(REAL32),allocatable :: dp(:),dz(:),pe(:) integer :: ksm print* print*, "Ref. pressure levels" @@ -121,7 +121,7 @@ subroutine write_plevs_ allocate(levn(nlevs)) allocate(pe(nlevs+1),dp(nlevs),dz(nlevs)) if(pbottom>0.) then - call get_ref_plevs ( ak8, bk8, ptop8, levn, p0=real(pbottom,8) ) + call get_ref_plevs ( ak8, bk8, ptop8, levn, p0=real(pbottom,REAL64) ) pe(1)=ptop8 do k=1,nlevs dp(k) = (ak8(k+1)-ak8(k))+(pbottom-ptop8)*(bk8(k+1)-bk8(k)) @@ -156,31 +156,31 @@ subroutine write_plevs_ write(6,'(i5,3(2x,f20.10))') k,levn(k),dp(k),dz(k) enddo endif - call weights2grads_(real(levn(nlevs:1:-1),4),dp(nlevs:1:-1), dz(nlevs:1:-1)) + call weights2grads_(real(levn(nlevs:1:-1),REAL32),dp(nlevs:1:-1), dz(nlevs:1:-1)) else levn=levn(nlevs:1:-1) do k = 1, nlevs write(6,'(i5,2x,f20.10,2x,f7.1,3x,f4.1,2(3x,f7.4))') k,levn(k),hloc(k), zloc(k), betac(k), betae(k) enddo - call loc2grads_(real(levn,4),hloc, zloc, betac, betae) + call loc2grads_(real(levn,REAL32),hloc, zloc, betac, betae) if (mlevs>0) then allocate(levm(mlevs)) allocate(xak(mlevs+1),xbk(mlevs+1)) call set_eta ( mlevs, ksm, ptop8, pint8, xak, xbk ) if(pbottom>0.) then - call get_ref_plevs ( xak, xbk, ptop8, levm, p0=real(pbottom,8) ) + call get_ref_plevs ( xak, xbk, ptop8, levm, p0=real(pbottom,REAL64) ) else call get_ref_plevs ( xak, xbk, ptop8, levm ) endif deallocate(xak,xbk) allocate(hlocm(mlevs), zlocm(mlevs), betacm(mlevs), betaem(mlevs)) levm=levm(mlevs:1:-1) - call spline ( real(levn,4), real(levm,4), hloc, hlocm ) - call spline ( real(levn,4), real(levm,4), zloc, zlocm ) - call spline ( real(levn,4), real(levm,4), betac, betacm ) - call spline ( real(levn,4), real(levm,4), betae, betaem ) - call loc2grads_(real(levm,4),hlocm, zlocm, betacm, betaem) + call spline ( real(levn,REAL32), real(levm,REAL32), hloc, hlocm ) + call spline ( real(levn,REAL32), real(levm,REAL32), zloc, zlocm ) + call spline ( real(levn,REAL32), real(levm,REAL32), betac, betacm ) + call spline ( real(levn,REAL32), real(levm,REAL32), betae, betaem ) + call loc2grads_(real(levm,REAL32),hlocm, zlocm, betacm, betaem) write(6,*) write(6,*) do k = 1, mlevs @@ -228,7 +228,7 @@ end subroutine write_akbk_ subroutine loc2grads_(lev,hloc, zloc, betac, betae) use m_ioutil, only : luavail implicit none - real(4),intent(in) :: lev(:),hloc(:),zloc(:),betac(:),betae(:) + real(REAL32),intent(in) :: lev(:),hloc(:),zloc(:),betac(:),betae(:) integer lo,km character(len=80) :: fctl,fgrd lo=luavail() @@ -271,7 +271,7 @@ end subroutine loc2grads_ subroutine weights2grads_(lev,dp,dz) use m_ioutil, only : luavail implicit none - real(4),intent(in) :: lev(:),dp(:),dz(:) + real(REAL32),intent(in) :: lev(:),dp(:),dz(:) integer lo,km,ii character(len=80) :: fctl,fgrd lo=luavail() diff --git a/GMAO_hermes/gcmbkg2ana.F b/GMAO_hermes/gcmbkg2ana.F index 2c0337ef..3b469b2a 100644 --- a/GMAO_hermes/gcmbkg2ana.F +++ b/GMAO_hermes/gcmbkg2ana.F @@ -24,7 +24,7 @@ program bkgeta_fix character*256, allocatable :: arg(:) character*256 input, output - integer n,m,nargs,iargc,L,nvars2 + integer n,m,nargs,L,nvars2 real plev real undef @@ -66,13 +66,13 @@ program bkgeta_fix C **** Read Command Line Arguments **** C ********************************************************************** - nargs = iargc() + nargs = command_argument_count() if( nargs.ne.3 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-o' ) output = arg(n+1) diff --git a/GMAO_hermes/getgfiodim.f90 b/GMAO_hermes/getgfiodim.f90 index 9be89e4d..cb64bb22 100644 --- a/GMAO_hermes/getgfiodim.f90 +++ b/GMAO_hermes/getgfiodim.f90 @@ -4,19 +4,19 @@ program getgfiodim integer, parameter :: READ_ONLY = 1 character(len=255) fname, argv - integer iarg, iargc, argc + integer iarg, argc integer fid, err integer im, jm, km, lm, nvars, ngatts - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) then print * print *, "Usage: getgfiodim.x gfiofilename" print * - call exit(1) + error stop 1 endif iarg = 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) fname = trim(argv) ! Open the file @@ -24,7 +24,7 @@ program getgfiodim call GFIO_Open ( trim(fname), READ_ONLY, fid, err ) if ( err .ne. 0 ) then print *, 'cannot open file ' - call exit (2) + error stop 2 endif ! Get dimensions @@ -32,7 +32,7 @@ program getgfiodim call GFIO_DimInquire ( fid, im, jm, km, lm, nvars, ngatts, err) if ( err .ne. 0 ) then print *, 'cannot extra dimensions ' - call exit (3) + error stop 3 end if ! Close GFIO file diff --git a/GMAO_hermes/ibc_upd.F b/GMAO_hermes/ibc_upd.F index fa7ae320..118c593e 100644 --- a/GMAO_hermes/ibc_upd.F +++ b/GMAO_hermes/ibc_upd.F @@ -57,9 +57,6 @@ program ibc_upd character(len=255) :: vars, str ! vars - logical upd - upd ( str ) = ( index((vars),(str)) .gt. 0 ) - !....................................................................... call zeit_ci ( 'ibc_upd' ) @@ -141,12 +138,12 @@ program ibc_upd ! Estimate bias ! ------------- a = alpha - if ( upd('ts') ) b_f%Ts = b_f%Ts - a * (w_e%Ts - w_f%Ts) - if ( upd('u') ) b_f%u = b_f%u - a * (w_e%u - w_f%u) - if ( upd('v') ) b_f%v = b_f%v - a * (w_e%v - w_f%v) - if ( upd('pt') ) b_f%pt = b_f%pt - a * (w_e%pt - w_f%pt) - if ( upd('q') ) b_f%q = b_f%q - a * (w_e%q - w_f%q) - if ( upd('delp') ) b_f%delp = b_f%delp - a * (w_e%delp - w_f%delp) + if ( upd('ts',vars) ) b_f%Ts = b_f%Ts - a * (w_e%Ts - w_f%Ts) + if ( upd('u',vars) ) b_f%u = b_f%u - a * (w_e%u - w_f%u) + if ( upd('v',vars) ) b_f%v = b_f%v - a * (w_e%v - w_f%v) + if ( upd('pt',vars) ) b_f%pt = b_f%pt - a * (w_e%pt - w_f%pt) + if ( upd('q',vars) ) b_f%q = b_f%q - a * (w_e%q - w_f%q) + if ( upd('delp',vars) ) b_f%delp = b_f%delp - a * (w_e%delp - w_f%delp) ! Write out the updated bias ! -------------------------- @@ -178,7 +175,7 @@ program ibc_upd print *, 'ibc_upd: successfully completed' - call exit(0) + stop !................................................................................... @@ -224,7 +221,7 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, character(len=*), parameter :: myname = 'init' - integer i, iarg, argc, iargc, n + integer i, iarg, argc, n character(len=255) argv, prefix print * @@ -246,7 +243,7 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, alpha = 0.1 out_a = 'undef' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage_() iarg = 0 @@ -254,11 +251,11 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-b' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_b ) + call get_command_argument ( iArg, dyn_b ) else if (index(argv,'-noremap' ) .gt. 0 ) then remap = .false. else if (index(argv,'-nors' ) .gt. 0 ) then @@ -266,23 +263,23 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, else if (index(argv,'-a' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, out_a ) + call get_command_argument ( iArg, out_a ) else if (index(argv,'-vars' ) .gt. 0 ) then if ( iarg+2 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, vars ) + call get_command_argument ( iArg, vars ) else if (index(argv,'-alpha' ) .gt. 0 ) then if ( iarg+2 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) alpha else if (index(argv,'-pick' ) .gt. 0 ) then if ( iarg+2 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nymd_f iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nhms_f pick = .true. else @@ -290,7 +287,7 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, call FileResolv ( trim(prefix), nymd_f, nhms_f, argv, dyn_f ) if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) n = n + 1 call FileResolv ( trim(prefix), nymd_f, nhms_f, argv, dyn_a ) end if @@ -335,10 +332,22 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, print *, ' Alpha: ', alpha print * + + contains + end subroutine Init_ !....................................................................... + logical function upd(str,vars) + + character(len=*), intent(in) :: str + character(len=*), intent(in) :: vars + + upd = index(vars,str) .gt. 0 + + end function upd + subroutine usage_() print * print *, 'SYNOPSIS ' diff --git a/GMAO_hermes/lcv2prs.F90 b/GMAO_hermes/lcv2prs.F90 index 6e80d7ee..07257850 100644 --- a/GMAO_hermes/lcv2prs.F90 +++ b/GMAO_hermes/lcv2prs.F90 @@ -1279,7 +1279,7 @@ Program lcv2prs ! All done ! -------- - call exit(0) + stop CONTAINS @@ -1385,7 +1385,6 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& !------------------------------------------------------------------------- integer iarg, argc - integer :: iargc character(len=4096) argv, prsFile character(len=255) rcfile, Vars(mVars), tmp, tmp1 @@ -1402,7 +1401,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& real xWest, xSouth, deltaPhi, deltaj, p logical :: debug = .false. - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) call usage_() ! Defaults @@ -1444,11 +1443,11 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& if ( iarg .gt. argc ) then exit endif - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if(index(argv,'-o') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, outFile ) + call get_command_argument ( iArg, outFile ) else if(index(argv,'-edge') .gt. 0 ) then onEdges = .true. else if(index(argv,'-lcv') .gt. 0 ) then @@ -1466,108 +1465,108 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& else if(index(argv,'-cvs') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, cvsFile ) + call get_command_argument ( iArg, cvsFile ) else if(index(argv,'-format') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, format ) + call get_command_argument ( iArg, format ) else if(index(argv,'-date') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) date else if(index(argv,'-inc') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) inc_hhmmss else if(index(argv,'-start') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) startTime else if(index(argv,'-rc') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, rcfile ) + call get_command_argument ( iArg, rcfile ) else if(index(argv,'-hist') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrHistory ) + call get_command_argument ( iArg, usrHistory ) else if(index(argv,'-convention') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrConvention ) + call get_command_argument ( iArg, usrConvention ) else if(index(argv,'-inst') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrInstitution ) + call get_command_argument ( iArg, usrInstitution ) else if(index(argv,'-ref') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrReferences ) + call get_command_argument ( iArg, usrReferences ) else if(index(argv,'-comment') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrComment ) + call get_command_argument ( iArg, usrComment ) else if(index(argv,'-src') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrSource ) + call get_command_argument ( iArg, usrSource ) else if(index(argv,'-title') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrTitle ) + call get_command_argument ( iArg, usrTitle ) else if(index(argv,'-contact') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, usrContact ) + call get_command_argument ( iArg, usrContact ) else if(index(argv,'-im') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) im else if(index(argv,'-west') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) xWest else if(index(argv,'-south') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) xSouth else if(index(argv,'-jm') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) jm else if(index(argv,'-nbits') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nbit print *, "nbit: ", nbit else if(index(argv,'-tSteps') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) tSteps else if(index(argv,'-vars') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) call split_ ( ',', argv, mVars, Vars, nVars ) else if(index(argv,'-prsf') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, prsFile ) + call get_command_argument ( iArg, prsFile ) if (len(trim(prsFile)) .ge. 4096) call die (myNewName, '-prsf files are too long.') call split_ ( ',', prsFile, mFiles, prsFiles, nPsfs ) else if(index(argv,'-levels') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) call split_ ( ',', argv, mLevs, cLevs, nLevs ) allocate( Levs(nLevs), stat = rc) if ( rc /= 0 ) call die (myNewName, 'wrong in allocating nLevs') @@ -1578,7 +1577,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& else if(index(argv,'-prec') .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) outPrec else if(index(argv,'-eta') .gt. 0 ) then inType = 'eta' @@ -2942,7 +2941,7 @@ subroutine comp_slp(im,jm,km,pt,phis,delp,pe,pm,grav,pkz,inField) end do if ( k_bot .lt. 2 ) then print *, ': got k_bot<2 while computing T_ref' - call exit(1) + error stop 1 else k1 = k_bot - 1 k2 = k_bot diff --git a/GMAO_hermes/m_dyn_util.F90 b/GMAO_hermes/m_dyn_util.F90 index 211bf11d..17dfa368 100644 --- a/GMAO_hermes/m_dyn_util.F90 +++ b/GMAO_hermes/m_dyn_util.F90 @@ -10,6 +10,7 @@ module m_dyn_util ! !USES: ! use m_dyn + use iso_fortran_env implicit NONE private @@ -439,8 +440,8 @@ subroutine horiz_grid_ (jn1, jweights, glats) tlat=tlat+rlat glats(j,1)=pi180*ulat glats(j,2)=pi180*tlat - slats(j,1)=dsin(real(ulat,8)) - slats(j,2)=dsin(real(tlat,8)) + slats(j,1)=sin(real(ulat,REAL64)) + slats(j,2)=sin(real(tlat,REAL64)) enddo ! jweights(1,1)=0.d0 ! not used diff --git a/GMAO_hermes/m_insitu.F b/GMAO_hermes/m_insitu.F index 5d80d64f..4bebf2d9 100644 --- a/GMAO_hermes/m_insitu.F +++ b/GMAO_hermes/m_insitu.F @@ -1092,7 +1092,7 @@ subroutine Insitu_Prep(im, jm, km, end do if ( k_bot .lt. 2 ) then print *, myname//': got k_bot<2 while computing T_ref' - call exit(1) + error stop 1 else k1 = k_bot - 1 k2 = k_bot diff --git a/GMAO_hermes/m_interp.F90 b/GMAO_hermes/m_interp.F90 index 401e1d77..07fe1414 100644 --- a/GMAO_hermes/m_interp.F90 +++ b/GMAO_hermes/m_interp.F90 @@ -1144,7 +1144,7 @@ end subroutine Interp_Field subroutine die ( myname, msg ) character(len=*) :: myname, msg write(*,'(a)') trim(myname) // ': ' // trim(msg) - call exit(1) + error stop 1 end subroutine die !................................................................. diff --git a/GMAO_hermes/m_topo_remap.F90 b/GMAO_hermes/m_topo_remap.F90 index 69ca44e5..a02c7b7f 100644 --- a/GMAO_hermes/m_topo_remap.F90 +++ b/GMAO_hermes/m_topo_remap.F90 @@ -102,8 +102,7 @@ subroutine dyn_topo_remap_( w_f,phis_new, dyntype, info ) deallocate ( ple ) else print *, ' not coded for old dyn' - call exit(1) - stop + error stop 1 endif call dyn_topo_remap( w_f%ps,w_f%delp,w_f%u,w_f%v,thv,w_f%q,w_f%phis,phis_new, & @@ -192,8 +191,7 @@ subroutine dyn_real_eta_( w_f, dyntype, info ) deallocate ( pke ) else print *, ' not coded for old dyn' - call exit(1) - stop + error stop 1 endif call ps_remap0_( ple_cur,ple_new,w_f%u,w_f%v,thv,w_f%q, & diff --git a/GMAO_hermes/maph_pert.f90 b/GMAO_hermes/maph_pert.f90 index 7fd8cbea..f5000eb0 100755 --- a/GMAO_hermes/maph_pert.f90 +++ b/GMAO_hermes/maph_pert.f90 @@ -129,7 +129,7 @@ program maph_pert print *, '--------------------------' print * - call exit(0) + stop !................................................................................... @@ -159,7 +159,7 @@ subroutine init_ () !EOP !----------------------------------------------------------------------- - integer i, iarg, argc, iargc + integer i, iarg, argc character(len=255) argv logical pin, lon_res, lat_res, pick @@ -174,7 +174,7 @@ subroutine init_ () dyn_pin = 'NONE' dyn_pout = 'maph_pert.nc4' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage_() iarg = 0 @@ -183,16 +183,16 @@ subroutine init_ () if ( iarg .gt. argc ) then exit endif - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-op' ) .gt. 0 ) then if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_pout ) + call get_command_argument ( iArg, dyn_pout ) else if (index(argv,'-p' ) .gt. 0 ) then pin = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, dyn_pin ) + call get_command_argument ( iArg, dyn_pin ) else if (index(argv,'-verbose' ) .gt. 0 ) then verb = .true. else if (index(argv,'-hs' ) .gt. 0 ) then @@ -203,22 +203,22 @@ subroutine init_ () lon_res = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) in else if (index(argv,'-lat' ) .gt. 0 ) then lat_res = .true. if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) jn else if (index(argv,'-pick' ) .gt. 0 ) then pick = .true. if ( iarg+2 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nymd_p iarg = iarg + 1 - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) read(argv,*) nhms_p end if end do @@ -289,7 +289,7 @@ subroutine die ( myname, msg ) print * print *, trim(myname) // ': ' // trim(msg) print * - call exit(1) + error stop 1 end subroutine die !....................................................................... diff --git a/GMAO_hermes/recalcsfc.F90 b/GMAO_hermes/recalcsfc.F90 index 88fd44e3..64c91560 100644 --- a/GMAO_hermes/recalcsfc.F90 +++ b/GMAO_hermes/recalcsfc.F90 @@ -168,7 +168,7 @@ Program ReCalcSFC if(debug) print *, 'Overwrote surface file: ', trim(bkgsfc) call zeit_co ( 'recalcsfc' ) - call exit(0) + stop CONTAINS @@ -408,7 +408,7 @@ subroutine Init ( obkgeta, rbkgeta, bkgsfc, nymd, nhms, dyntype, debug ) character(len=*), parameter :: myname = 'Init' - integer i, iarg, argc, iargc, n + integer i, iarg, argc, n logical debug character(len=255) argv @@ -424,7 +424,7 @@ subroutine Init ( obkgeta, rbkgeta, bkgsfc, nymd, nhms, dyntype, debug ) ! Parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() if ( argc .lt. 3 ) call usage() iarg = 0 @@ -434,7 +434,7 @@ subroutine Init ( obkgeta, rbkgeta, bkgsfc, nymd, nhms, dyntype, debug ) if ( iarg .gt. argc ) then exit endif - call GetArg ( iArg, argv ) + call get_command_argument ( iArg, argv ) if (index(argv,'-v' ) .gt. 0 ) then debug = .true. else if (index(argv,'-g5' ) .gt. 0 ) then diff --git a/GMAO_hermes/reset_time.f b/GMAO_hermes/reset_time.f index 09292684..73f1411c 100644 --- a/GMAO_hermes/reset_time.f +++ b/GMAO_hermes/reset_time.f @@ -10,7 +10,6 @@ INTEGER fdate, fhhmmss_beg, finc character(len=256) fileName character(len=256) argv - integer :: iargc integer hh, mm, ss character(len=2) chh, cmm, css integer yyyy, mon, day @@ -18,7 +17,7 @@ character(len=2) cmon, cday character*80 timeUnits - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) then print *, "Usage: reset_time.x fname yyyymmdd hhmmss time_inc" print *, " " @@ -34,18 +33,18 @@ end if iarg = 1 - call GetArg ( iarg, fileName ) + call get_command_argument ( iarg, fileName ) ! print * , "fileName: ", trim(fileName) iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) date ! print * , "date: ", date iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) hhmmss_beg ! print * , "hhmmss_beg: ", hhmmss_beg iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) read(argv,*) inc ! print * , "inc: ", inc diff --git a/GMAO_hermes/rs52dyn.f90 b/GMAO_hermes/rs52dyn.f90 index cd65bc43..55307dff 100644 --- a/GMAO_hermes/rs52dyn.f90 +++ b/GMAO_hermes/rs52dyn.f90 @@ -53,7 +53,7 @@ program main character*120, allocatable :: arg(:) character*8 date character*2 hour - integer n,nargs,iargc,i,j,L,rc + integer n,nargs,i,j,L,rc integer prec, ks real*8 ptop, pint @@ -80,11 +80,11 @@ program main nhms_ana = -999 prec = 0 - nargs = iargc() + nargs = command_argument_count() if(nargs==0) call usage() allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage() @@ -365,6 +365,6 @@ subroutine usage() print * print *, " Last updated 26Jan2006, Elena N." print * - call exit(7) + error stop 7 end diff --git a/GMAO_hermes/write_eta.F90 b/GMAO_hermes/write_eta.F90 index f7250f1f..1d93c1c3 100644 --- a/GMAO_hermes/write_eta.F90 +++ b/GMAO_hermes/write_eta.F90 @@ -31,14 +31,14 @@ program write_eta nxt = 1 filename = 'eta.rc' - call getarg(nxt,arg) + call get_command_argument(nxt,arg) do while(arg(1:1)=='-') opt=arg(2:2) if(len(trim(arg))==2) then nxt = nxt + 1 - call getarg(nxt,arg) + call get_command_argument(nxt,arg) else arg = arg(3:) end if @@ -58,7 +58,7 @@ program write_eta stop Usage end select nxt = nxt + 1 - call getarg(nxt,arg) + call get_command_argument(nxt,arg) end do if (use_sigma /=0 ) then @@ -85,7 +85,7 @@ program write_eta write(unit,'(A)') "ak-bk: " do k = 1,levels+1 - write(unit,'(2ES23.15)'), ak(k), bk(k) + write(unit,'(2ES23.15)') ak(k), bk(k) enddo write(unit,'(A, ES23.15)') "REF_PRESSURE: ",p0 diff --git a/GMAO_mpeu/m_random.F b/GMAO_mpeu/m_random.F index 7f0a08cd..3a736891 100644 --- a/GMAO_mpeu/m_random.F +++ b/GMAO_mpeu/m_random.F @@ -545,7 +545,7 @@ double precision function mysecond() c c Generic Unix version real xx(2) -#if defined(sysAIX) || defined(__GFORTRAN__) +#if defined(sysAIX) || defined(__GFORTRAN__) || defined (__NAG_COMPILER_RELEASE) call get_zeits(xx(1)) #else call etime(xx) From b3813efc1b3a3bb26290280d2ee3eef871b29345 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 26 Apr 2021 12:25:36 -0400 Subject: [PATCH 2/8] More NAG updates --- GEOS_Util/post/CMakeLists.txt | 24 +++---- GEOS_Util/post/checkdate.F | 8 +-- GEOS_Util/post/convert_aerosols.F | 8 +-- GEOS_Util/post/convert_eta.F | 26 ++++---- GEOS_Util/post/ec_eta2fv.F | 10 +-- GEOS_Util/post/ec_prs2eta.F | 38 ++++++------ GEOS_Util/post/ec_prs2fv.F | 20 +++--- GEOS_Util/post/era5_prs2eta.F | 12 ++-- GEOS_Util/post/eta2prs.F | 8 +-- GEOS_Util/post/eta2rst.F | 12 ++-- GEOS_Util/post/fire.F | 6 +- GEOS_Util/post/fix_undef.F90 | 38 ++++++------ GEOS_Util/post/gg2eta.F | 10 +-- GEOS_Util/post/gg2fv.F | 16 ++--- GEOS_Util/post/hdf2rs.F | 26 ++++---- GEOS_Util/post/makeiau.F | 10 +-- GEOS_Util/post/merra2scm.F | 100 +++++++++++++++--------------- GEOS_Util/post/ncep_prs2fv.F | 20 +++--- GEOS_Util/post/rs2hdf.F | 8 +-- GEOS_Util/post/rs_hinterp.F | 8 +-- GEOS_Util/post/rs_vinterp.F90 | 8 +-- GEOS_Util/post/rs_vinterp_scm.F90 | 8 +-- GEOS_Util/post/rsg3_vinterp.F | 8 +-- GEOS_Util/post/stats.F90 | 47 +++++++++----- GEOS_Util/post/swapendian_FV.f90 | 15 ++--- GEOS_Util/post/swapendian_RST.f90 | 17 +++-- GEOS_Util/post/tick.F | 4 +- GEOS_Util/post/time_ave.F | 10 +-- 28 files changed, 271 insertions(+), 254 deletions(-) diff --git a/GEOS_Util/post/CMakeLists.txt b/GEOS_Util/post/CMakeLists.txt index 223a1b41..69d9fff9 100644 --- a/GEOS_Util/post/CMakeLists.txt +++ b/GEOS_Util/post/CMakeLists.txt @@ -72,27 +72,27 @@ set_property(SOURCE PWSSSP.F APPEND_STRING PROPERTY COMPILE_FLAGS "${FREAL8} ${E set_property(SOURCE alias.F APPEND_STRING PROPERTY COMPILE_FLAGS "${BYTERECLEN}") target_link_libraries (convert_eta.x ${this} GMAO_hermes MAPL) -target_link_libraries (eta2prs.x ${this} GMAO_gfio_r4 MAPL GEOS_Shared) -target_link_libraries (ec_prs2eta.x ${this} GMAO_gfio_r4 MAPL) -target_link_libraries (era5_prs2eta.x ${this} GMAO_gfio_r4 MAPL) -target_link_libraries (ec_prs2fv.x ${this} GMAO_gfio_r4 MAPL) -target_link_libraries (stats.x post_nompi GMAO_gfio_r4 MAPL ${ESMF_LIBRARIES}) +target_link_libraries (eta2prs.x ${this} MAPL GEOS_Shared) +target_link_libraries (ec_prs2eta.x ${this} MAPL) +target_link_libraries (era5_prs2eta.x ${this} MAPL) +target_link_libraries (ec_prs2fv.x ${this} MAPL) +target_link_libraries (stats.x post_nompi MAPL ${ESMF_LIBRARIES}) target_link_libraries (flat2hdf.x post_nompi) target_link_libraries (gg2fv.x post) target_link_libraries (rs2hdf.x post) -target_link_libraries (time_ave.x ${this} GMAO_gfio_r4 MAPL ) +target_link_libraries (time_ave.x ${this} MAPL ) target_link_libraries (rsg3_vinterp.x ${this} GMAO_hermes) target_link_libraries (rs_vinterp.x ${this} GMAO_hermes) target_link_libraries (eta2rst.x ${this} GMAO_hermes ${MPI_Fortran_LIBRARIES}) target_link_libraries (fvrst.x GMAO_gfio_r4 MAPL) set_target_properties (fvrst.x PROPERTIES LINK_FLAGS "${OpenMP_Fortran_FLAGS}") -target_link_libraries (gg2eta.x ${this} GMAO_gfio_r4) -target_link_libraries (gg2fv.x ${this} GMAO_gfio_r4) -target_link_libraries (hdf2rs.x ${this} GMAO_gfio_r4 ${MPI_Fortran_LIBRARIES}) -target_link_libraries (makeiau.x ${this} GMAO_gfio_r4 ${MPI_Fortran_LIBRARIES}) -target_link_libraries (merra2scm.x ${this} GMAO_gfio_r4 ${MPI_Fortran_LIBRARIES}) -target_link_libraries (rs2hdf.x ${this} GMAO_gfio_r4) +target_link_libraries (gg2eta.x ${this}) +target_link_libraries (gg2fv.x ${this} ) +target_link_libraries (hdf2rs.x ${this} ${MPI_Fortran_LIBRARIES}) +target_link_libraries (makeiau.x ${this} ${MPI_Fortran_LIBRARIES}) +target_link_libraries (merra2scm.x ${this} ${MPI_Fortran_LIBRARIES}) +target_link_libraries (rs2hdf.x ${this} ) target_link_libraries (rs_hinterp.x ${this} MAPL) set_target_properties (rs_hinterp.x PROPERTIES LINK_FLAGS "${OpenMP_Fortran_FLAGS}") diff --git a/GEOS_Util/post/checkdate.F b/GEOS_Util/post/checkdate.F index b3952fc7..49797637 100644 --- a/GEOS_Util/post/checkdate.F +++ b/GEOS_Util/post/checkdate.F @@ -49,7 +49,7 @@ program main character*1 char data output /'eta2prs'/ - integer n,m,nargs,iargc,L,nbeg,nfiles,mlev + integer n,m,nargs,L,nbeg,nfiles,mlev integer ny,nm,nd real*8 lonbeg @@ -121,13 +121,13 @@ end subroutine read_hdf hdf = .true. quad = .false. - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-im' ) read(arg(n+1),*) im_out @@ -600,5 +600,5 @@ subroutine usage() print * print *, " -eta eta_fname(s): Filename(s) in eta HDF format" print * - call exit(7) + error stop 7 end subroutine usage diff --git a/GEOS_Util/post/convert_aerosols.F b/GEOS_Util/post/convert_aerosols.F index bad1dac7..7482f9a7 100644 --- a/GEOS_Util/post/convert_aerosols.F +++ b/GEOS_Util/post/convert_aerosols.F @@ -75,7 +75,7 @@ program convert_aerosols character*2 time,hour0,mins0 character*1 char - integer n,m,nargs,iargc,L,nbeg,nfiles,npfiles,mlev + integer n,m,nargs,L,nbeg,nfiles,npfiles,mlev real undef,psmax,psmin integer i,j,ndt,ks @@ -119,13 +119,13 @@ end subroutine read_eta_meta lmout = -999 psnetcdf = .true. - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs @@ -960,7 +960,7 @@ subroutine usage() . " -tag output_tag: Optional Filename Tag for output: fname(s).tag (default: grid.IMxJM)" ,/ . ,/ . ) - call exit(7) + error stop 7 end subroutine usage subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef,msgn,norder,check ) diff --git a/GEOS_Util/post/convert_eta.F b/GEOS_Util/post/convert_eta.F index efb50559..c5a1f6a1 100644 --- a/GEOS_Util/post/convert_eta.F +++ b/GEOS_Util/post/convert_eta.F @@ -1,5 +1,7 @@ program convert_eta + use iso_fortran_env + implicit none c ********************************************************************** @@ -57,7 +59,7 @@ program convert_eta character*2 hour0,mins0 character*1 char - integer n,m,nargs,iargc,nfiles + integer n,m,nargs,nfiles real undef integer ndt @@ -107,13 +109,13 @@ end subroutine read_eta_meta phisname = 'NULL' - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs @@ -419,6 +421,7 @@ subroutine convert ( q2d,q3d,name2d,titl2d,unit2d,name3d,titl3d,unit3d,n2d,n3d,u use MAPL_ConstantsMod use m_set_eta, only: set_eta + use iso_fortran_env implicit none c Input Variables @@ -428,6 +431,7 @@ subroutine convert ( q2d,q3d,name2d,titl2d,unit2d,name3d,titl3d,unit3d,n2d,n3d,u real q2d(im,jm, n2d) real q3d(im,jm,lm,n3d) + integer imo,jmo,lmo real phis(imo,jmo) real ps(imo,jmo) real dp(imo,jmo,lm) @@ -436,7 +440,6 @@ subroutine convert ( q2d,q3d,name2d,titl2d,unit2d,name3d,titl3d,unit3d,n2d,n3d,u real t(imo,jmo,lm) real q(imo,jmo,lm,2) - integer imo,jmo,lmo real z2d(imo,jmo, n2d) real z3d(imo,jmo,lm,n3d) @@ -476,7 +479,7 @@ subroutine convert ( q2d,q3d,name2d,titl2d,unit2d,name3d,titl3d,unit3d,n2d,n3d,u integer nu,nv,kdum real undef, pi,dx,dy, qmin, qmax - real*8 ptop, rdum + real(kind=REAL64) ptop, rdum integer precision,id,timeinc,rc,nhmsf character*256 title @@ -495,8 +498,8 @@ subroutine convert ( q2d,q3d,name2d,titl2d,unit2d,name3d,titl3d,unit3d,n2d,n3d,u real, allocatable :: ple(:,:,:) real, allocatable :: logpl(:,:,:) real, allocatable :: logplo(:,:,:) - real*8, allocatable :: ak(:) - real*8, allocatable :: bk(:) + real(kind=REAL64), allocatable :: ak(:) + real(kind=REAL64), allocatable :: bk(:) real dpref dpref(L) = ( ak(L+1)-ak(L) ) + ( bk(L+1)-bk(L) ) * 98400.0 @@ -1082,7 +1085,7 @@ subroutine usage() . " -tag output_tag: Optional Filename Tag for output: fname(s).tag (default: grid.IMxJM)" ,/ . ,/ . ) - call exit(7) + error stop 7 end subroutine usage subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef ) @@ -2819,6 +2822,7 @@ subroutine remap ( ps1,dp1,u1,v1,thv1,q1,phis1,lm1, use MAPL_ConstantsMod use m_set_eta, only: set_eta + use iso_fortran_env implicit none integer im,jm,lm1,lm2,nt @@ -2852,13 +2856,13 @@ subroutine remap ( ps1,dp1,u1,v1,thv1,q1,phis1,lm1, real phi2(im,jm,lm2+1) real ptop1(im,jm) - real*8 rdum + real(kind=REAL64) rdum real kappa,cp,dum1,dum2 real rgas,eps,rvap,grav integer i,j,L,kdum - real*8, allocatable :: ak(:) - real*8, allocatable :: bk(:) + real(kind=REAL64), allocatable :: ak(:) + real(kind=REAL64), allocatable :: bk(:) kappa = MAPL_KAPPA rgas = MAPL_RGAS diff --git a/GEOS_Util/post/ec_eta2fv.F b/GEOS_Util/post/ec_eta2fv.F index 36fba73b..b5be3ac8 100644 --- a/GEOS_Util/post/ec_eta2fv.F +++ b/GEOS_Util/post/ec_eta2fv.F @@ -104,7 +104,7 @@ program main logical ihavetv,agridw integer precision - integer L,n,nargs,iargc,lrec + integer L,n,nargs,lrec character*256 ctlfile,format integer imncep,jmncep,lmncep,nvncep @@ -127,13 +127,13 @@ program main pbelow = 30.00 ! 30 mb precision = 0 ! 32-bit - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-rslv' ) read(arg(n+1),600) hres,lm @@ -684,7 +684,7 @@ subroutine getfile ( ku,filename,irec ) 1002 continue print *, 'ERROR!! File: ',trim(filename) print *, 'ERROR!! is neither BIG nor LITTLE ENDIAN' - call exit(7) + error stop 7 endif end @@ -1978,7 +1978,7 @@ subroutine usage() print *, " -tag tag: Optional Prefix tag for output files" print *, " -ozone Optional Flag to add ozone" print * - call exit(7) + error stop 7 end subroutine interp_h ( q_cmp,im,jm,lm, diff --git a/GEOS_Util/post/ec_prs2eta.F b/GEOS_Util/post/ec_prs2eta.F index e285e345..849277c0 100644 --- a/GEOS_Util/post/ec_prs2eta.F +++ b/GEOS_Util/post/ec_prs2eta.F @@ -95,7 +95,7 @@ program main character*256, allocatable :: arg(:) integer precision - integer i,j,k,L,n,nargs,iargc,ks + integer i,j,k,L,n,nargs,ks logical gmaoprs logical norecon @@ -133,13 +133,13 @@ program main gmaoprs =.false. norecon =.false. - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-ecmwf' ) prsdata = trim(arg(n+1)) @@ -475,7 +475,7 @@ subroutine interp ( q,qana,logp,logpl,pana,pl,ple,im,jm,lm,lmana,undef,name,nite real zana (im,jm,lmana) real erana(im,jm,lmana) real logpl(im,jm,lmana) - character*8 name + character*4 name integer i,j,L,n @@ -603,7 +603,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'Mean_sea_level_pressure',nymd,nhms,imana,jmana,0,1 ,dum2d,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF SLP variable' - call exit(7) + error stop 7 endif if( im.ne.imana .or. jm.ne.jmana ) then call hinterp ( dum2d,imana,jmana,slp,im,jm,1,undef ) @@ -618,7 +618,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, dum2d = exp(dum2d) else print *, 'Could not find ECMWF Surface Pressure variable' - call exit(7) + error stop 7 endif endif if( im.ne.imana .or. jm.ne.jmana ) then @@ -630,7 +630,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'Height',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF Height variable' - call exit(7) + error stop 7 endif call zflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -644,12 +644,12 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'U_velocity',nymd,nhms,imana,jmana,1,lmana,dumu,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF U-Wind variable' - call exit(7) + error stop 7 endif call gfio_getvar ( id,'V_velocity',nymd,nhms,imana,jmana,1,lmana,dumv,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF V-Wind variable' - call exit(7) + error stop 7 endif call zflip( dumu,imana,jmana,lmana ) @@ -671,7 +671,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'Temperature',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF Temperature variable' - call exit(7) + error stop 7 endif call zflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -685,7 +685,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'Relative_humidity',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF Rel.Hum. variable' - call exit(7) + error stop 7 endif call zflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -1005,7 +1005,7 @@ subroutine usage() print *, " -tag tag: Optional Prefix tag for Output (Default: ec_prs2eta)" print *, " -gmaoprs : Indicates input is really GMAO prs file (used for test only)" print * - call exit(7) + error stop 7 end subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef ) @@ -2010,7 +2010,7 @@ subroutine get_gmaoana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'slp',nymd,nhms,imana,jmana,0,1 ,dum2d,rc ) if( rc.ne.0 ) then print *, 'Could not find GMAO SLP variable' - call exit(7) + error stop 7 endif if( im.ne.imana .or. jm.ne.jmana ) then call hinterp ( dum2d,imana,jmana,slp,im,jm,1,undef ) @@ -2021,7 +2021,7 @@ subroutine get_gmaoana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'ps',nymd,nhms,imana,jmana,0,1 ,dum2d ,rc ) ! New ECMWF Format 2011/05/11 06z if( rc.ne.0 ) then print *, 'Could not find GMAO Surface Pressure variable' - call exit(7) + error stop 7 endif if( im.ne.imana .or. jm.ne.jmana ) then call hinterp ( dum2d,imana,jmana,ps,im,jm,1,undef ) @@ -2032,7 +2032,7 @@ subroutine get_gmaoana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'hght',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find GMAO Height variable' - call exit(7) + error stop 7 endif call zflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -2046,12 +2046,12 @@ subroutine get_gmaoana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'u',nymd,nhms,imana,jmana,1,lmana,dumu,rc ) if( rc.ne.0 ) then print *, 'Could not find GMAO U-Wind variable' - call exit(7) + error stop 7 endif call gfio_getvar ( id,'v',nymd,nhms,imana,jmana,1,lmana,dumv,rc ) if( rc.ne.0 ) then print *, 'Could not find GMAO V-Wind variable' - call exit(7) + error stop 7 endif call zflip( dumu,imana,jmana,lmana ) @@ -2073,7 +2073,7 @@ subroutine get_gmaoana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'tmpu',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find GMAO Temperature variable' - call exit(7) + error stop 7 endif call zflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -2087,7 +2087,7 @@ subroutine get_gmaoana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'rh',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find GMAO Rel.Hum. variable' - call exit(7) + error stop 7 endif call zflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then diff --git a/GEOS_Util/post/ec_prs2fv.F b/GEOS_Util/post/ec_prs2fv.F index 4baac1c1..7fd42926 100644 --- a/GEOS_Util/post/ec_prs2fv.F +++ b/GEOS_Util/post/ec_prs2fv.F @@ -107,7 +107,7 @@ program main logical recon integer precision - integer i,j,k,L,n,nargs,iargc + integer i,j,k,L,n,nargs c Analysis Grads CTL File Variables c --------------------------------- @@ -134,13 +134,13 @@ program main nymd = -999 nhms = -999 - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-dyn' ) dynrst = trim(arg(n+1)) @@ -763,7 +763,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'logarithm_of_su',nymd,nhms,imana,jmana,0,1 ,dum2d ,rc ) ! Old ECMWF Format if( rc.ne.0 ) then print *, 'Could not find ECMWF Surface Pressure variable' - call exit(7) + error stop 7 endif dum2d = exp(dum2d) endif @@ -777,7 +777,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'height',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF Height variable' - call exit(7) + error stop 7 endif if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -791,12 +791,12 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'u_velocity',nymd,nhms,imana,jmana,1,lmana,dumu,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF U-Wind variable' - call exit(7) + error stop 7 endif call gfio_getvar ( id,'v_velocity',nymd,nhms,imana,jmana,1,lmana,dumv,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF V-Wind variable' - call exit(7) + error stop 7 endif #if 0 @@ -830,7 +830,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'temperature',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF Temperature variable' - call exit(7) + error stop 7 endif if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -844,7 +844,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'relative_humidi',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF Rel.Hum. variable' - call exit(7) + error stop 7 endif if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -2219,7 +2219,7 @@ subroutine usage() print *, " -tag tag: Optional Prefix tag for output files" print *, " -ozone Optional Flag to add ozone" print * - call exit(7) + error stop 7 end subroutine get_slp ( ps,phis,slp,pe,pk,tv,rgas,grav,im,jm,km ) diff --git a/GEOS_Util/post/era5_prs2eta.F b/GEOS_Util/post/era5_prs2eta.F index 2aff5862..5c7d6596 100644 --- a/GEOS_Util/post/era5_prs2eta.F +++ b/GEOS_Util/post/era5_prs2eta.F @@ -106,7 +106,7 @@ program main character*256, allocatable :: arg(:) integer precision - integer i,j,k,L,n,nargs,iargc,ks + integer i,j,k,L,n,nargs,ks integer nt,nv,ng,imphis,jmphis,lmphis logical norecon logical Lzflip @@ -176,13 +176,13 @@ end subroutine gfio_get tag = '' norecon =.false. - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-ecmwf' ) prsdata = trim(arg(n+1)) @@ -568,7 +568,7 @@ subroutine interp ( q,qana,logp,logpl,pana,pl,ple,im,jm,lm,lmana,undef,name,nite real zana (im,jm,lmana) real erana(im,jm,lmana) real logpl(im,jm,lmana) - character*8 name + character*4 name integer i,j,L,n @@ -756,7 +756,7 @@ subroutine mpi_gfio_getvar ( id,name,nymd,nhms,im,jm,lbeg,lm,q,rc,lattice ) call gfio_getvar ( id,trim(name),nymd,nhms,img,jmg,lbeg,lm,glo,rc ) if( rc.ne.0 ) then print *, 'Could not find ECMWF ',trim(name),' RC = ',rc - call exit(7) + error stop 7 endif endif do L=1,lm @@ -1073,7 +1073,7 @@ subroutine usage() print *, " -j0 j0: Optional Global J-Gridpoint for Diagnostics" print *, " -norecon Optional Flag to Turn OFF H for Diagnostics" print * - call exit(7) + error stop 7 end subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef ) diff --git a/GEOS_Util/post/eta2prs.F b/GEOS_Util/post/eta2prs.F index 287fe51e..6cde3469 100644 --- a/GEOS_Util/post/eta2prs.F +++ b/GEOS_Util/post/eta2prs.F @@ -63,7 +63,7 @@ program main character*1 char data output /'eta2prs'/ - integer n,m,nargs,iargc,L,nfiles,npfiles,mlev + integer n,m,nargs,L,nfiles,npfiles,mlev real*8 lonbeg real undef @@ -118,13 +118,13 @@ end subroutine read_hdf_meta nopres = .false. underg = .false. - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-ptop' ) read(arg(n+1),*) ptop @@ -2534,7 +2534,7 @@ subroutine usage() . " -noquad : Implies No Computation of Quadratics (default: quadratics are computed )" ,/ . " -hdf : Logical Flag for HDF Output (default: .TRUE., .FALSE. implies flat binary file)" ,/ . ) - call exit(7) + error stop 7 end subroutine usage subroutine get_slp ( ps,phis,slp,pe,pk,thv,rgas,grav,im,jm,km ) implicit none diff --git a/GEOS_Util/post/eta2rst.F b/GEOS_Util/post/eta2rst.F index a116569a..4ef36b23 100644 --- a/GEOS_Util/post/eta2rst.F +++ b/GEOS_Util/post/eta2rst.F @@ -78,7 +78,7 @@ program main character*256, allocatable :: arg(:) character*8 date character*2 hour - integer n,nargs,iargc,L,ID,rc,method + integer n,nargs,L,ID,rc,method logical agrid_ana logical dgrid_ana @@ -133,12 +133,12 @@ program main nhms = -999 method = -999 - nargs = iargc() + nargs = command_argument_count() if(nargs.eq.0) call usage(myid) allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage(myid) @@ -171,7 +171,7 @@ program main . trim(moistrst).eq.'x' ) then if( myid.eq.0 ) print *, 'You must supply DYNRST, MOISTRST, and ANARST Files!' call my_finalize - call exit (7) + error stop 7 stop endif @@ -426,7 +426,7 @@ program main if( trim(topofile).eq.'x' ) then if( myid.eq.0 ) print *, 'You must supply TOPO File at Model Resolution!' call my_finalize - call exit (7) + error stop 7 stop else if( myid.eq.0 ) print *, 'Reading ',trim(topofile),' from PE: ',myid @@ -759,7 +759,7 @@ subroutine readit ( q,im,jm,lm,ku,lattice,filename,rc ) else if( rc.gt.0 ) then if( lattice%myid.eq.0 ) print *, 'Error Reading File: ',trim(filename) call my_finalize - call exit (7) + error stop 7 endif enddo deallocate ( a,glo ) diff --git a/GEOS_Util/post/fire.F b/GEOS_Util/post/fire.F index 8b10e4ae..717ed40c 100644 --- a/GEOS_Util/post/fire.F +++ b/GEOS_Util/post/fire.F @@ -68,7 +68,7 @@ program main character*1 char data output /'ascii'/ - integer n,m,nargs,iargc,L,nbeg,nfiles,nsfiles,npfiles,mlev + integer n,m,nargs,L,nbeg,nfiles,nsfiles,npfiles,mlev real*8 lonbeg real undef @@ -138,13 +138,13 @@ end subroutine read_hdf_meta quad = .true. nopres = .false. - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then stop else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs diff --git a/GEOS_Util/post/fix_undef.F90 b/GEOS_Util/post/fix_undef.F90 index 20df312e..b9669d99 100644 --- a/GEOS_Util/post/fix_undef.F90 +++ b/GEOS_Util/post/fix_undef.F90 @@ -13,7 +13,7 @@ program main character*256 :: filename,filename1,filename2 character*256 :: arg(2) - integer :: n,nargs,iargc,id,rc + integer :: n,nargs,id,rc ! First File ! ---------- @@ -82,13 +82,13 @@ program main ! READ INPUT ! ---------- - nargs = iargc() + nargs = command_argument_count() if( nargs<1 .or. nargs>2 ) then call usage() end if do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo read(arg(1),'(a)') filename1 @@ -103,12 +103,12 @@ program main call gfio_open ( trim(filename1),0,id1,rc ) if( rc.ne.0 ) then print *, 'File: ',trim(filename1),' not found!' - call exit(1) + error stop 1 endif call gfio_diminquire ( id1,im,jm,lm,ntimes,nvars,ngatts,rc ) if( rc.ne.0 ) then print *, 'Failed GFIO_DIMINQUIRE on File: ',trim(filename1) - call exit(1) + error stop 1 endif allocate ( lon(im) ) @@ -131,7 +131,7 @@ program main vrange,prange,rc ) if( rc.ne.0 ) then print *, 'Failed GFIO_INQUIRE on File: ',trim(filename1) - call exit(1) + error stop 1 endif if( lev(lm).gt.lev(1) ) then @@ -140,7 +140,7 @@ program main print *, 'contains Levels ordered top -> bottom (Eta?)' print *, 'LEVS: ',lev print * - call exit(1) + error stop 1 endif found_ps = .FALSE. @@ -157,18 +157,18 @@ program main call gfio_open ( trim(filename2),2,id2,rc ) if( rc.ne.0 ) then print *, 'File: ',trim(filename2),' not found!' - call exit(1) + error stop 1 endif call gfio_diminquire ( id2,im2,jm2,lm2,ntimes2,nvars2,ngatts2,rc ) if( rc.ne.0 ) then print *, 'Failed GFIO_DIMINQUIRE on File: ',trim(filename2) - call exit(1) + error stop 1 endif if( im2.ne.im .or. jm2.ne.jm ) then print *, 'File Horizontal Dimensions do not match!' print *, 'File: ',trim(filename1),' IM: ',im, ' JM: ',jm print *, 'File: ',trim(filename2),' IM: ',im2,' JM: ',jm2 - call exit(1) + error stop 1 endif allocate ( lon2(im2) ) @@ -194,7 +194,7 @@ program main print *, 'File Time Frequencies do not match!' print *, 'File: ',trim(filename1),' TIMINC: ',timinc print *, 'File: ',trim(filename2),' TIMINC: ',timinc2 - call exit(1) + error stop 1 endif found_ps2 = .FALSE. @@ -210,11 +210,11 @@ program main if( nargs.eq.1 .and. .not.found_ps ) then print *, 'Cannot find PS in File: ',trim(filename1) - call exit(1) + error stop 1 endif if( nargs.eq.2 .and. .not.found_ps .and. .not.found_ps2 ) then print *, 'Cannot find PS in File: ',trim(filename1),' or ',trim(filename2) - call exit(1) + error stop 1 endif ! ************************************************************************* @@ -241,7 +241,7 @@ program main call gfio_getvar ( id1,trim(PSNAME),nymd,nhms,im,jm,0, 1,ps,rc ) if( rc.ne.0 ) then print *, 'Failed to get PS from ',trim(filename1),' for: ',nymd,nhms - call exit(1) + error stop 1 endif endif @@ -250,13 +250,13 @@ program main call gfio_getvar ( id2,trim(PSNAME),nymd,nhms,im,jm,0, 1,ps2,rc ) if( rc.ne.0 ) then print *, 'Failed to get PS from ',trim(filename1),' for: ',nymd,nhms - call exit(1) + error stop 1 endif if( found_ps ) then checkps(1) = count( ps.ne.ps2 ) if( checkps(1).ne.0 ) then print *, 'PS from ',trim(filename1),' and ',trim(filename2),' do not match!' - call exit(1) + error stop 1 endif else ps = ps2 @@ -278,14 +278,14 @@ program main call gfio_getvar ( id1,trim(vname(k)),nymd,nhms,im,jm,L,1,q,rc ) if( rc.ne.0 ) then print *, 'Failed to get ',trim(vname(k)),' for: ',nymd,nhms,' at Level: ',L - call exit(1) + error stop 1 endif plev = lev(L)*100 where( ps.lt.plev ) q = undef call gfio_putvar ( id1,trim(vname(k)),nymd,nhms,im,jm,L,1,q,rc ) if( rc.ne.0 ) then print *, 'Failed to write ',trim(vname(k)),' for: ',nymd,nhms,' at Level: ',L - call exit(1) + error stop 1 endif endif enddo @@ -310,6 +310,6 @@ subroutine usage() ,/ & " PRS_filename (required) is the name of the PRS file which is to be fixed" ,/ & " PS_filename (optional) is the name of the file containing PS (if not present in PRS_filename)" ,/ ) - call exit(1) + error stop 1 end subroutine usage diff --git a/GEOS_Util/post/gg2eta.F b/GEOS_Util/post/gg2eta.F index f97eecd9..1b7bf7a2 100644 --- a/GEOS_Util/post/gg2eta.F +++ b/GEOS_Util/post/gg2eta.F @@ -48,7 +48,7 @@ program main character*120, allocatable :: arg(:) integer precision - integer n,nargs,iargc + integer n,nargs c NCEP Grads CTL File Variables c ----------------------------- @@ -86,13 +86,13 @@ end subroutine read_ctl ext = 'nc4' tag = '' - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-ncep' ) ana_data = trim(arg(n+1)) @@ -462,7 +462,7 @@ subroutine getfile ( ku,filename,irec ) 1002 continue print *, 'ERROR!! File: ',trim(filename) print *, 'ERROR!! is neither BIG nor LITTLE ENDIAN' - call exit(7) + error stop 7 endif end @@ -562,7 +562,7 @@ subroutine usage() print *, " -ctl ncep.ctl : Filename of NCEP sigma-level analysis ctl (from ss2gg)" print *, " -tag tag : Optional Prefix tag for output files" print * - call exit(7) + error stop 7 end subroutine read_ctl ( ctlfile,im,jm,lm,undef,format, diff --git a/GEOS_Util/post/gg2fv.F b/GEOS_Util/post/gg2fv.F index 7ae970fd..44d7438a 100644 --- a/GEOS_Util/post/gg2fv.F +++ b/GEOS_Util/post/gg2fv.F @@ -117,7 +117,7 @@ program main logical :: lwiflag = .false. integer precision - integer L,n,nargs,iargc,ks + integer L,n,nargs,ks c NCEP Grads CTL File Variables c ----------------------------- @@ -162,13 +162,13 @@ end subroutine read_ctl precision = 0 ! 32-bit ctlfile = 'xxx' - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-rslv' ) read(arg(n+1),600) hres,lm @@ -272,7 +272,7 @@ end subroutine read_ctl print *, 'NCEP Gridded Data: ',imncep,jmncep print *, ' BKG Gridded Data: ',im,jm print * - call exit(7) + error stop 7 endif if( mlev.ne.lmncep ) then print * @@ -280,7 +280,7 @@ end subroutine read_ctl print *, 'LMNCEP: ',lmncep print *, ' MLEV: ',mlev print * - call exit(7) + error stop 7 endif C ********************************************************************** @@ -363,7 +363,7 @@ end subroutine read_ctl if( rc.ne.0 ) then print *, 'Reading: ',trim(fv_data) print *, 'Surface Land Fractions not Available!' - call exit(7) + error stop 7 endif lwi = 1 ! Land where ( frocean+frlake >= 0.6 ) lwi = 0 ! Water @@ -878,7 +878,7 @@ subroutine getfile ( ku,filename,irec ) 1002 continue print *, 'ERROR!! File: ',trim(filename) print *, 'ERROR!! is neither BIG nor LITTLE ENDIAN' - call exit(7) + error stop 7 endif end @@ -2460,7 +2460,7 @@ subroutine usage() print *, " -tag tag: Optional Prefix tag for output files" print *, " -ozone Optional Flag to add ozone" print * - call exit(7) + error stop 7 end subroutine interp_h ( q_cmp,im,jm,lm, diff --git a/GEOS_Util/post/hdf2rs.F b/GEOS_Util/post/hdf2rs.F index 18dd34e0..382e7692 100644 --- a/GEOS_Util/post/hdf2rs.F +++ b/GEOS_Util/post/hdf2rs.F @@ -104,7 +104,7 @@ program main character*120, allocatable :: arg(:) character*8 date character*2 hour - integer n,nargs,iargc,L,ID,rc,method + integer n,nargs,L,ID,rc,method logical increment,ihaveth,doremap,do_o3,showdiv C ********************************************************************** @@ -156,12 +156,12 @@ program main method = -999 doremap = .false. - nargs = iargc() + nargs = command_argument_count() if(nargs.eq.0) call usage(myid) allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage(myid) @@ -214,7 +214,7 @@ program main . trim(inceta) .eq.'x' ) then if( myid.eq.0 ) print *, 'You must supply either ANAETA or INCETA Files!' call my_finalize - call exit (7) + error stop 7 stop else if ( trim(anaeta) .eq. 'x' ) then ! increment is provided as input increment = .true. @@ -227,7 +227,7 @@ program main . trim(bkgsfc) .eq.'x' ) then if( myid.eq.0 ) print *, 'You must supply DYNRST, MOISTRST, PCHEMRST, and BKGSFC Files!' call my_finalize - call exit (7) + error stop 7 stop endif else ! analyis is provided as input @@ -235,14 +235,14 @@ program main . trim(moistrst).eq.'x' ) then if( myid.eq.0 ) print *, 'You must supply at least DYNRST, and MOISTRST Files!' call my_finalize - call exit (7) + error stop 7 stop endif do_o3 = trim(pchemrst).ne.'x' .and. trim(bkgsfc).eq.'x' if ( bkgeta .ne. 'x' ) then if( myid.eq.0 ) print *, 'Opt not available: ANA BKG cannot be updated w/o INCs!' call my_finalize - call exit (7) + error stop 7 stop endif endif @@ -540,7 +540,7 @@ program main if ( imxglobal.ne.imaglobal .and. jmxglobal.ne.jmaglobal ) then if( myid.eq.0 ) print *, 'Dimension of ANA background incompatible w/ INCs!' call my_finalize - call exit (7) + error stop 7 stop endif @@ -574,7 +574,7 @@ program main if( lon(1) .eq. 0.0 ) then if( myid.eq.0 ) print *, 'Longitudes in BKG file incompatible with INC file!' call my_finalize - call exit (7) + error stop 7 stop endif @@ -680,7 +680,7 @@ program main if (imxglobal.ne.imaglobal .or. jmxglobal.ne.jmaglobal ) then if( myid.eq.0 ) print *, 'Dimension of BKG SFC file inconsistent w/ that of ANA ETA' call my_finalize - call exit (7) + error stop 7 endif allocate ( cosza(ima,jma) ) @@ -718,7 +718,7 @@ program main if( trim(topofile).eq.'x' ) then if( myid.eq.0 ) print *, 'You must supply TOPO File at Model Resolution!' call my_finalize - call exit (7) + error stop 7 stop else if( myid.eq.0 ) print *, 'Reading ',trim(topofile),' from PE: ',myid @@ -1310,7 +1310,7 @@ subroutine getit ( id,name,nymd,nhms,im,jm,lbeg,lm,q,lattice ) #endif if ( rc.ne.0 ) then call my_finalize - call exit (7) + error stop 7 endif call timebeg (' Scatter') do L=1,lm @@ -1377,7 +1377,7 @@ subroutine readit ( q,im,jm,lm,ku,lattice,filename,rc ) else if( rc.gt.0 ) then if( lattice%myid.eq.0 ) print *, 'Error Reading File: ',trim(filename) call my_finalize - call exit (7) + error stop 7 endif enddo deallocate ( a,glo ) diff --git a/GEOS_Util/post/makeiau.F b/GEOS_Util/post/makeiau.F index 055f1339..500b5e9e 100644 --- a/GEOS_Util/post/makeiau.F +++ b/GEOS_Util/post/makeiau.F @@ -128,7 +128,7 @@ program main character*256, allocatable :: arg(:) character*8 date character*2 hour - integer n,nargs,iargc,L,ID,rc,method + integer n,nargs,L,ID,rc,method real, parameter :: tauana = 21600.0 @@ -170,12 +170,12 @@ program main imoglobal = -999 jmoglobal = -999 - nargs = iargc() + nargs = command_argument_count() if(nargs.eq.0) call usage(myid) allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage(myid) @@ -220,7 +220,7 @@ program main print *, 'You must supply BOTH parameters: IMOUT & JMOUT!' endif call my_finalize - call exit (7) + error stop 7 stop endif @@ -306,7 +306,7 @@ program main print *, 'thv_flag: ',thvflag_ana endif call my_finalize - call exit (7) + error stop 7 stop endif diff --git a/GEOS_Util/post/merra2scm.F b/GEOS_Util/post/merra2scm.F index 0f23c75f..baa58850 100644 --- a/GEOS_Util/post/merra2scm.F +++ b/GEOS_Util/post/merra2scm.F @@ -781,8 +781,8 @@ subroutine getmylatlon2(latbegin,lonbegin,latend,lonend,lats,lons, . imN,jmN,fieldin,fieldscm) implicit none real latbegin,lonbegin,latend,lonend - real lats(jmN),lons(imN) integer imN,jmN + real lats(jmN),lons(imN) real fieldin(imN,jmN),fieldscm real dlat, dlon @@ -811,8 +811,8 @@ subroutine getmylatlon3(n,latbegin,lonbegin,latend,lonend,lats,lons, . imC,jmC,lmC,fieldin,undef,fieldscm) implicit none real latbegin,lonbegin,latend,lonend - real lats(jmC),lons(imC) integer n,imC,jmC,lmC + real lats(jmC),lons(imC) real fieldin(imC,jmC,lmC),fieldscm(1000,100) real undef @@ -912,86 +912,86 @@ subroutine writer_upper(n,lmC,tscm,qvscm,uscm,vscm,omegascm,dtdtdynscm,dqvdtdyns zeros = 0. - write(20,*),"Number of Multi-Level Fields: " - write(20,*)," 11" + write(20,*) "Number of Multi-Level Fields: " + write(20,*) " 11" - write(20,*), 1, " & Temp_(K)" - write(20,*),"K" + write(20,*) 1, " & Temp_(K)" + write(20,*) "K" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk write(20,2000)(tscm(kk,ii),ii=1,numlev) enddo -c write(20,*), 2, " & H2O_Mixing_Ratio_(g/kg)" - write(20,*), 2, " & H2O_Mixing_Ratio_(kg/kg)" - write(20,*),"g/kg" +c write(20,*) 2, " & H2O_Mixing_Ratio_(g/kg)" + write(20,*) 2, " & H2O_Mixing_Ratio_(kg/kg)" + write(20,*) "g/kg" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk c write(20,2000)(qvscm(kk,ii)*1000.,ii=1,numlev) write(20,2000)(qvscm(kk,ii),ii=1,numlev) enddo - write(20,*), 3, " & U_wind_(m/sec)" - write(20,*),"m/sec" + write(20,*) 3, " & U_wind_(m/sec)" + write(20,*) "m/sec" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk write(20,2000)(uscm(kk,ii),ii=1,numlev) enddo - write(20,*), 4, " & V_wind_(m/sec)" - write(20,*),"m/sec" + write(20,*) 4, " & V_wind_(m/sec)" + write(20,*) "m/sec" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk write(20,2000)(vscm(kk,ii),ii=1,numlev) enddo - write(20,*), 5, " & Omega_(mb/hour)" - write(20,*),"mb/hour" + write(20,*) 5, " & Omega_(mb/hour)" + write(20,*) "mb/hour" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk write(20,2000)(omegascm(kk,ii)*36.,ii=1,numlev) enddo - write(20,*), 6, " & Horizontal_Temp_Advec_(K/hour) dtdtdynscm" - write(20,*),"K/hour" + write(20,*) 6, " & Horizontal_Temp_Advec_(K/hour) dtdtdynscm" + write(20,*) "K/hour" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk write(20,2000)(dtdtdynscm(kk,ii)*3600.,ii=1,numlev) enddo - write(20,*), 7, " & Vertical_Temp_Advec_(K/hour)" - write(20,*),"K/hour" + write(20,*) 7, " & Vertical_Temp_Advec_(K/hour)" + write(20,*) "K/hour" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk write(20,2000)(zeros(kk,ii),ii=1,numlev) enddo - write(20,*), 8, " & Horizontal_q_Advec_(g/kg/hour)dqvdtdynscm" - write(20,*),"K/hour" + write(20,*) 8, " & Horizontal_q_Advec_(g/kg/hour)dqvdtdynscm" + write(20,*) "K/hour" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk write(20,2000)(dqvdtdynscm(kk,ii)*3600000.,ii=1,numlev) enddo - write(20,*), 9, " & Vertical_q_Advec_(g/kg/hour)" - write(20,*),"K/hour" + write(20,*) 9, " & Vertical_q_Advec_(g/kg/hour)" + write(20,*) "K/hour" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk write(20,2000)(zeros(kk,ii),ii=1,numlev) enddo c---------------SVETA------------- - write(20,*), 10, " & Horizontal_Temp_Advec_(K/hour) dtdtanascm" - write(20,*),"K/hour" + write(20,*) 10, " & Horizontal_Temp_Advec_(K/hour) dtdtanascm" + write(20,*) "K/hour" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk write(20,2000)(dtdtanascm(kk,ii)*3600.,ii=1,numlev) enddo - write(20,*), 11, " & Horizontal_q_Advec_(g/kg/hour)dqvdtanascm" - write(20,*),"K/hour" + write(20,*) 11, " & Horizontal_q_Advec_(g/kg/hour)dqvdtanascm" + write(20,*) "K/hour" do kk=1,numtim - write(20,*), "nt=", kk + write(20,*) "nt=", kk write(20,2000)(dqvdtanascm(kk,ii)*3600.,ii=1,numlev) enddo @@ -1011,36 +1011,36 @@ subroutine writer_surface(n,psscm,tsscm,efluxscm,hfluxscm,prectotscm) ! write(20,1000) ! write(20,1001) ! write(20,1002) - write(20,*),'Number of Single-Level Fields:' - write(20,*), 5 + write(20,*) 'Number of Single-Level Fields:' + write(20,*) 5 - write(20,*), 1, " & SH_(W/m**2)" - write(20,*),"W/m**2" + write(20,*) 1, " & SH_(W/m**2)" + write(20,*) "W/m**2" do ii = 1,n write(20,2000)hfluxscm(ii) enddo - write(20,*), 2, " & LH_(W/m**2)" - write(20,*),"W/m**2" + write(20,*) 2, " & LH_(W/m**2)" + write(20,*) "W/m**2" do ii = 1,n write(20,2000)efluxscm(ii) enddo - write(20,*), 3, " & TS_(K)" - write(20,*),"K" + write(20,*) 3, " & TS_(K)" + write(20,*) "K" do ii = 1,n write(20,2000)tsscm(ii) enddo - write(20,*), 4, " & PS_(mb)" - write(20,*),"mb" + write(20,*) 4, " & PS_(mb)" + write(20,*) "mb" do ii = 1,n write(20,2000)psscm(ii)/100. enddo - write(20,*), 5, " & Prec_(mm/hour)" - write(20,*),"mm/hour" + write(20,*) 5, " & Prec_(mm/hour)" + write(20,*) "mm/hour" do ii = 1,n write(20,2000)prectotscm(ii)*3600. enddo diff --git a/GEOS_Util/post/ncep_prs2fv.F b/GEOS_Util/post/ncep_prs2fv.F index 28799145..2160eec6 100644 --- a/GEOS_Util/post/ncep_prs2fv.F +++ b/GEOS_Util/post/ncep_prs2fv.F @@ -125,7 +125,7 @@ program main logical recon logical ihavetv,agridw integer precision - integer i,j,k,L,n,nargs,iargc + integer i,j,k,L,n,nargs c Analysis Grads CTL File Variables c --------------------------------- @@ -158,13 +158,13 @@ program main nymd = -999 nhms = -999 - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-dyn' ) dynrst = trim(arg(n+1)) @@ -790,7 +790,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'ps',nymd,nhms,imana,jmana,0,1 ,dum2d ,rc ) if( rc.ne.0 ) then print *, 'Could not find NCEP Surface Pressure variable' - call exit(7) + error stop 7 endif if( lonbeg.eq.0.0 ) call hflip( dum2d,imana,jmana,1 ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -802,7 +802,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'hght',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find NCEP Height variable' - call exit(7) + error stop 7 endif if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -816,12 +816,12 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'uwnd',nymd,nhms,imana,jmana,1,lmana,dumu,rc ) if( rc.ne.0 ) then print *, 'Could not find NCEP U-Wind variable' - call exit(7) + error stop 7 endif call gfio_getvar ( id,'vwnd',nymd,nhms,imana,jmana,1,lmana,dumv,rc ) if( rc.ne.0 ) then print *, 'Could not find NCEP V-Wind variable' - call exit(7) + error stop 7 endif #if 0 @@ -855,7 +855,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'tmpu',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find NCEP Temperature variable' - call exit(7) + error stop 7 endif if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -869,7 +869,7 @@ subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, call gfio_getvar ( id,'rh',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) if( rc.ne.0 ) then print *, 'Could not find NCEP Rel.Hum. variable' - call exit(7) + error stop 7 endif if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) if( im.ne.imana .or. jm.ne.jmana ) then @@ -2250,7 +2250,7 @@ subroutine usage() print *, " -tag tag: Optional Prefix tag for output files" print *, " -ozone Optional Flag to add ozone" print * - call exit(7) + error stop 7 end subroutine get_slp ( ps,phis,slp,pe,pk,tv,rgas,grav,im,jm,km ) diff --git a/GEOS_Util/post/rs2hdf.F b/GEOS_Util/post/rs2hdf.F index 7cf8e5c0..9a741836 100644 --- a/GEOS_Util/post/rs2hdf.F +++ b/GEOS_Util/post/rs2hdf.F @@ -56,7 +56,7 @@ program main character*5 extn character*8 date character*2 hour - integer n,nargs,iargc,i,j,L,nymd0,nhms0 + integer n,nargs,i,j,L,nymd0,nhms0 integer precision logical file_exists logical dtoa @@ -78,14 +78,14 @@ program main precision = 0 ! 32-bit: 0, 64-bit: 1 extn = 'nc4' - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage() @@ -903,7 +903,7 @@ subroutine usage() print *, "-------" print *, " tag.bkg.eta.yyyymmdd_hhz.nc4" print * - call exit(7) + error stop 7 end subroutine dtoa_winds ( ud,vd,ua,va,im,jm,lm ) diff --git a/GEOS_Util/post/rs_hinterp.F b/GEOS_Util/post/rs_hinterp.F index 365eedce..b2264234 100755 --- a/GEOS_Util/post/rs_hinterp.F +++ b/GEOS_Util/post/rs_hinterp.F @@ -63,7 +63,7 @@ program main character*8 date character*2 hour character*4 xdim ,ydim - integer m,n,nmax,nargs,iargc,i,j,L,rc + integer m,n,nmax,nargs,i,j,L,rc integer nlots,nrem,num,num_other_rst integer :: filetype,dimSizes(3),counter,nVars @@ -94,12 +94,12 @@ program main num_other_rst = 0 - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) call usage() allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-dyn' ) then @@ -2658,6 +2658,6 @@ subroutine usage() . " -jm JM_OUT: JM Dimension for Output" ,/ . ,/ . ) - call exit(7) + error stop 7 end subroutine usage diff --git a/GEOS_Util/post/rs_vinterp.F90 b/GEOS_Util/post/rs_vinterp.F90 index 77acc753..c811420e 100644 --- a/GEOS_Util/post/rs_vinterp.F90 +++ b/GEOS_Util/post/rs_vinterp.F90 @@ -58,7 +58,7 @@ program main character*1 char character*2 hour character*4 cim,cjm,clm - integer m,n,nargs,iargc,i,j,L + integer m,n,nargs,i,j,L integer num,num_other_rst,nbeg,nend integer, allocatable :: nt_other(:) logical verbose @@ -74,11 +74,11 @@ program main moistrst = 'moist_internal_restart' num_other_rst = 0 - nargs = iargc() + nargs = command_argument_count() if(nargs == 0 ) call usage() allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage() @@ -1186,5 +1186,5 @@ subroutine usage() print *, "creates updated restarts at new LM resolution" print *, "---------------------------------------------" print * - call exit(7) + error stop 7 end diff --git a/GEOS_Util/post/rs_vinterp_scm.F90 b/GEOS_Util/post/rs_vinterp_scm.F90 index 7f4b7001..7043c0cf 100644 --- a/GEOS_Util/post/rs_vinterp_scm.F90 +++ b/GEOS_Util/post/rs_vinterp_scm.F90 @@ -69,7 +69,7 @@ program main character*256, allocatable :: arg(:) character*1 char character*4 cim,cjm,clm - integer m,n,nargs,iargc,L + integer m,n,nargs,L integer num,num_other_rst,nbeg,nend integer, allocatable :: nt_other(:) logical verbose @@ -87,11 +87,11 @@ program main moistrst = 'moist_internal_rst' num_other_rst = 0 - nargs = iargc() + nargs = command_argument_count() if(nargs == 0 ) call usage() allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage() @@ -1298,5 +1298,5 @@ subroutine usage() write (*,1001) "---------------------------------------------" write (*,1001) 1001 format (A) - call exit(7) + error stop 7 end diff --git a/GEOS_Util/post/rsg3_vinterp.F b/GEOS_Util/post/rsg3_vinterp.F index 8e2e3e79..a8545ef1 100644 --- a/GEOS_Util/post/rsg3_vinterp.F +++ b/GEOS_Util/post/rsg3_vinterp.F @@ -71,7 +71,7 @@ program main character*8 date character*2 hour,clm character*3 cim,cjm - integer n,nargs,iargc,i,j,L + integer n,nargs,i,j,L C ********************************************************************** C **** Initialize Filenames **** @@ -82,11 +82,11 @@ program main moistrst = 'moist_internal_restart' iaurst = 'xxx' - nargs = iargc() + nargs = command_argument_count() if(nargs == 0 ) call usage() allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-h' ) call usage() @@ -1125,7 +1125,7 @@ subroutine usage() print *, "-------" print *, " New dynrst & moistrst restart files for ARIES" print * - call exit(7) + error stop 7 end SUBROUTINE CTOA ( qc,qa,im,jm,km,itype ) diff --git a/GEOS_Util/post/stats.F90 b/GEOS_Util/post/stats.F90 index b46e4841..e9497936 100644 --- a/GEOS_Util/post/stats.F90 +++ b/GEOS_Util/post/stats.F90 @@ -139,7 +139,6 @@ program stats integer ndates integer dates(3,1000) - integer iargc logical isPresent @@ -197,13 +196,13 @@ end subroutine init_levs fcsource="NULL" averify ="NULL" - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage() else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs @@ -338,7 +337,7 @@ end subroutine init_levs print* ,' -fcsrc FORECAST (e.g., gmao)' print* ,' -verif VERIFICATION (e.g., ncep)' print* ,' Aborting ...' - call exit(1) + error stop 1 endif gmaopy=.true. endif @@ -1091,7 +1090,7 @@ end subroutine init_levs close(51) datafile = trim(tag) // 'globl.' // bdate // bhour // "." // edate // ehour // ".data" - call system ("/bin/mv " // trim(statfile) // " " // trim(datafile) ) + call execute_command_line ("/bin/mv " // trim(statfile) // " " // trim(datafile) ) statfile = trim(tag) // 'stats.' // bdate // bhour // "." // edate // ehour // ".data" open (85,file=trim(statfile),form='unformatted',access='sequential') @@ -1357,9 +1356,6 @@ subroutine read_clim_hdf ( nymd,nhms,fields_2d,fields_3d,n2d,n3d,idim,jdim,nl,zl DATA DAYS /31,28,31,30,31,30,31,31,30,31,30,31/ INTEGER NSECF, NMONF, NDAYF - NSECF(N) = N/10000*3600 + MOD(N,10000)/100* 60 + MOD(N,100) - NMONF(N) = MOD(N,10000)/100 - NDAYF(N) = MOD(N,100) !********************************************************************* !**** Find Proper Month Boundaries from INPUT Date and Time **** @@ -1691,10 +1687,6 @@ subroutine read_clim_bin ( nymd,nhms,p,u,v,t,q,h,idim,jdim,ldim,undef ) INTEGER :: NSECF, NMONF, NDAYF, NHMS, NYMD - NSECF(N) = N/10000*3600 + MOD(N,10000)/100* 60 + MOD(N,100) - NMONF(N) = MOD(N,10000)/100 - NDAYF(N) = MOD(N,100) - if( first ) then open (90,file='ncep_1x1_clim.data', & form='unformatted',access='direct',recl=im*jm ) @@ -3139,7 +3131,6 @@ subroutine interp_time ( nymd1,nhms1, nymd2,nhms2, ntimes, num ) REAL MNDY(12,4), DUM(48) DATA MNDY /0,31,60,91,121,152,182,213,244,274,305,335,366,397,34*0/ - NSECF(N) = N/10000*3600 + MOD(N,10000)/100* 60 + MOD(N,100) EQUIVALENCE ( DUM(1), MNDY(1,1) ) DO I=15,48 @@ -3227,7 +3218,7 @@ subroutine usage() print *, "Tag_Name.stats.b{YYYYMMDD}.e{YYYYMMDD}.ctl1" print *, "Tag_Name.stats.b{YYYYMMDD}.e{YYYYMMDD}.ctl2" print * - call exit(7) + error stop 7 end subroutine usage subroutine tick (nymd,nhms,ndt) @@ -3351,6 +3342,34 @@ function nsecf (nhms) return end function nsecf + function nmonf (nymd) +!*********************************************************************** +! Purpose +! Converts NYMD format to month +! +!*********************************************************************** +!* GODDARD LABORATORY FOR ATMOSPHERES * +!*********************************************************************** + implicit none + integer nymd, nmonf + nmonf = mod(nymd,10000)/100 + return + end function nmonf + + function ndayf (nymd) +!*********************************************************************** +! Purpose +! Converts NYMD format to day +! +!*********************************************************************** +!* GODDARD LABORATORY FOR ATMOSPHERES * +!*********************************************************************** + implicit none + integer nymd, ndayf + ndayf = mod(nymd,100) + return + end function ndayf + function nhmsf (nsec) !*********************************************************************** ! Purpose diff --git a/GEOS_Util/post/swapendian_FV.f90 b/GEOS_Util/post/swapendian_FV.f90 index e9898678..a0be5ffb 100644 --- a/GEOS_Util/post/swapendian_FV.f90 +++ b/GEOS_Util/post/swapendian_FV.f90 @@ -11,20 +11,17 @@ program swapFV real*8,allocatable :: A(:,:) character(128) :: str, f_in, f_out - integer*4 :: iargc - external :: iargc - ! Begin - if (iargc() /= 2) then - call getarg(0,str) + if (command_argument_count() /= 2) then + call get_command_argument(0,str) write(*,*) "Usage:",trim(str)," " - call exit(2) + error stop 2 end if - call getarg(1,f_in) - call getarg(2,f_out) + call get_command_argument(1,f_in) + call get_command_argument(2,f_out) unitR = 7 unitW = 8 @@ -45,7 +42,7 @@ program swapFV print *, ' Resolution: ',im,jm,km allocate(C(KM+1), A(IM,JM), stat=status) - if (status /=0 ) call exit(1) + if (status /=0 ) error stop 1 read (unitR) C !AK write(unitW) C diff --git a/GEOS_Util/post/swapendian_RST.f90 b/GEOS_Util/post/swapendian_RST.f90 index aa8ae534..2783c6c1 100644 --- a/GEOS_Util/post/swapendian_RST.f90 +++ b/GEOS_Util/post/swapendian_RST.f90 @@ -9,19 +9,16 @@ program endian_convert integer*4 :: ftell external :: ftell - integer*4 :: iargc - external :: iargc - ! Begin - if (iargc() /= 2) then - call getarg(0,str) + if (command_argument_count() /= 2) then + call get_command_argument(0,str) write(*,*) "Usage:",trim(str)," " - call exit(2) + error stop 2 end if - call getarg(1,f_in) - call getarg(2,f_out) + call get_command_argument(1,f_in) + call get_command_argument(2,f_out) open(unit=10, file=trim(f_in), form='unformatted', convert="big_endian") open(unit=20, file=trim(f_out), form='unformatted', convert="native") @@ -40,7 +37,7 @@ program endian_convert allocate(var(rsize), stat=status) if (status /= 0) then print *, 'Error: allocation ', rsize, ' failed!' - call exit(11) + error stop 11 end if read (10) var @@ -54,6 +51,6 @@ program endian_convert stop 200 print *,'Error reading file ',trim(f_in) - call exit(11) + error stop 11 end diff --git a/GEOS_Util/post/tick.F b/GEOS_Util/post/tick.F index 64f15379..0591133a 100644 --- a/GEOS_Util/post/tick.F +++ b/GEOS_Util/post/tick.F @@ -5,14 +5,14 @@ program main integer nargs character*256, allocatable :: arg(:) - nargs = iargc() + nargs = command_argument_count() if( nargs .lt.1 .or. nargs .gt.3 ) then call usage else allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo read( arg(1),*) nymd diff --git a/GEOS_Util/post/time_ave.F b/GEOS_Util/post/time_ave.F index 13932a17..dbf3e792 100644 --- a/GEOS_Util/post/time_ave.F +++ b/GEOS_Util/post/time_ave.F @@ -3,6 +3,7 @@ program time_ave use ESMF use dynamics_lattice_module + use ieee_arithmetic, only: isnan => ieee_is_nan implicit none type ( dynamics_lattice_type ) lattice @@ -54,7 +55,7 @@ program time_ave data doutput /'NULL'/ data template/'NULL'/ - integer n,m,nargs,iargc,L,nfiles,nv,km,mvars,mv,ndvars + integer n,m,nargs,L,nfiles,nv,km,mvars,mv,ndvars real plev,qming,qmaxg real undef @@ -108,7 +109,6 @@ program time_ave logical, allocatable :: lzstar(:) integer NSECF, ntmin, ntcrit, nhmsf, nc - NSECF(N) = N/10000*3600 + MOD(N,10000)/100* 60 + MOD(N,100) C ********************************************************************** C **** Initialization **** @@ -147,7 +147,7 @@ program time_ave ndt = -999 ntod = -999 ntmin = -999 - nargs = iargc() + nargs = command_argument_count() if( nargs.eq.0 ) then call usage(root) else @@ -158,7 +158,7 @@ program time_ave ignore_nan = .FALSE. allocate ( arg(nargs) ) do n=1,nargs - call getarg(n,arg(n)) + call get_command_argument(n,arg(n)) enddo do n=1,nargs if( trim(arg(n)).eq.'-template' ) template = arg(n+1) @@ -1129,8 +1129,8 @@ subroutine zstar (q,qp,im,jm,undef,lattice) subroutine check_quad ( quad,vname,nvars,aliases,nalias,qloc ) implicit none - character*256 quad(2), aliases(2,nalias), vname(nvars) integer nvars, nalias, qloc(2) + character*256 quad(2), aliases(2,nalias), vname(nvars) integer m,n c Initialize Location of Quadratics From f5c2f62a2b8bb047d02389e31d3111daf8a0520a Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 15 Dec 2021 12:09:41 -0500 Subject: [PATCH 3/8] More NAG updates --- GMAO_hermes/dyn_blob.f90 | 10 ++++++---- GMAO_hermes/dyn_fsens_conv.f90 | 8 ++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/GMAO_hermes/dyn_blob.f90 b/GMAO_hermes/dyn_blob.f90 index 9dcd97e5..416ac4fc 100644 --- a/GMAO_hermes/dyn_blob.f90 +++ b/GMAO_hermes/dyn_blob.f90 @@ -7,6 +7,8 @@ program dyn_blob use m_const, only: radius_earth use m_die, only: die +use iso_fortran_env + implicit none character(len=*), parameter :: fname = 'bkg.eta.nc4' @@ -99,7 +101,7 @@ program dyn_blob subroutine wrtout_(lu,fld) integer, intent(in) :: lu real, intent(in) :: fld(:,:) - real(4),allocatable:: fld4(:,:) + real(REAL32),allocatable:: fld4(:,:) integer myim,myjm,ndim myim=size(fld,1) myjm=size(fld,2) @@ -115,7 +117,7 @@ end subroutine wrtout_ subroutine readin_(lu,fld) integer, intent(in) :: lu real, intent(in) :: fld(:,:) - real(4),allocatable:: fld4(:,:) + real(REAL32),allocatable:: fld4(:,:) integer myim,myjm,ndim myim=size(fld,1) myjm=size(fld,2) @@ -366,9 +368,9 @@ subroutine lon_shift(field,im,jm) integer, intent(in) :: im integer, intent(in) :: jm - real(4), intent(inout) :: field(im,jm) + real(REAL32), intent(inout) :: field(im,jm) integer i, j - real(4) tmp + real(REAL32) tmp do j = 1, jm do i = 1, im/2 diff --git a/GMAO_hermes/dyn_fsens_conv.f90 b/GMAO_hermes/dyn_fsens_conv.f90 index e2ac6989..11fe95e1 100644 --- a/GMAO_hermes/dyn_fsens_conv.f90 +++ b/GMAO_hermes/dyn_fsens_conv.f90 @@ -11,7 +11,7 @@ program dyn_fsens_conv integer,parameter :: dyntype=5 integer,parameter :: nfiles=2 integer nymd, nhms, lu, n, freq, vectype, prec, ier, nstep - integer i, nf, iarg, argc, ndim2, ndim3, intarg, iargc + integer i, nf, iarg, argc, ndim2, ndim3, intarg character(len=255) :: ofile character(len=255) :: dynfile(nfiles) character(len=255) argv @@ -31,20 +31,20 @@ program dyn_fsens_conv verbose = .false. iarg=0 - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) call usage_() nf=0 do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument ( iarg, argv ) select case (trim(argv)) case ("-verbose") verbose = .true. case ("-o") if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iarg, ofile ) + call get_command_argument ( iarg, ofile ) case default nf = nf + 1 if ( nf .gt. nfiles ) call die(myname,'too many eta files:',nf) From 0b87a2cb76fe5c7b46f39c95f996ac7ea11a055e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 15 Dec 2021 15:23:29 -0500 Subject: [PATCH 4/8] Fix for rs_numtiles --- GEOS_Util/post/rs_numtiles.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/GEOS_Util/post/rs_numtiles.F90 b/GEOS_Util/post/rs_numtiles.F90 index 3e0a42f1..e9e3a2a2 100644 --- a/GEOS_Util/post/rs_numtiles.F90 +++ b/GEOS_Util/post/rs_numtiles.F90 @@ -57,7 +57,12 @@ program rs_numtiles else bpos=0 read (10) +#ifdef __NAG_COMPILER_RELEASE + write (*,*) 'NAG does not provide ftell. Use only netCDF' + error stop 1 +#else epos = ftell(10) ! ending position of file pointer +#endif ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; rewind 10 end if From b0820ac3800da5ca3d2791da50a1bba0d7b03d4e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 15 Dec 2021 19:41:22 -0500 Subject: [PATCH 5/8] Remove unneeded contains --- GMAO_hermes/ibc_upd.F | 2 -- 1 file changed, 2 deletions(-) diff --git a/GMAO_hermes/ibc_upd.F b/GMAO_hermes/ibc_upd.F index 118c593e..b8a756ff 100644 --- a/GMAO_hermes/ibc_upd.F +++ b/GMAO_hermes/ibc_upd.F @@ -333,8 +333,6 @@ subroutine Init_ ( dyn_f, dyn_b, dyn_a, out_a, remap, restart, print * - contains - end subroutine Init_ !....................................................................... From 5bb5facdf29ad6103c91c288c5094ac3bfaa5611 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 4 May 2026 10:49:30 -0400 Subject: [PATCH 6/8] Fix NAG compiler issues in GMAO_Shared - Fix m_ioutil.F90: Use TRANSFER() intrinsic for type-safe byte swapping in swapI4_ and swapI8_ functions instead of direct type punning - Fix mpi0/mpi0_copy.F90: Implement TRANSFER-based type conversions using BLOCK constructs for all non-INTEGER MPI types (REAL, DOUBLE_PRECISION, LOGICAL, CHARACTER) to satisfy NAG's strict type checking - Fix windfix.F90: Correct array section syntax from scalar notation (e.g., dglo(1,1,l)) to proper array slices (e.g., dglo(:,:,l)) for calls to GETDIV and VELPOT_SP - Update GMAO_mpeu/CMakeLists.txt: Comment out duplicate MISMATCH flags that are now in common_Fortran_flags to avoid compilation errors All changes maintain backwards compatibility with gfortran and other compilers while fixing NAG compiler strict type checking issues. --- GEOS_Shared/windfix.F90 | 6 ++-- GMAO_mpeu/CMakeLists.txt | 6 ++-- GMAO_mpeu/m_ioutil.F90 | 18 +++++----- GMAO_mpeu/mpi0/mpi0_copy.F90 | 64 +++++++++++++++++++++++++++++++----- 4 files changed, 72 insertions(+), 22 deletions(-) diff --git a/GEOS_Shared/windfix.F90 b/GEOS_Shared/windfix.F90 index 16f7dabc..5ea13e39 100644 --- a/GEOS_Shared/windfix.F90 +++ b/GEOS_Shared/windfix.F90 @@ -104,7 +104,7 @@ subroutine windfix ( ua,va,plea, & ! -------------------------------- if (size(uglo)>1) then do l=1,size(uglo,3) - call getdiv (uglo(1,1,l),vglo(1,1,l),dpglo(1,1,l),dglo(1,1,l),img,jmg ) + call getdiv (uglo(:,:,l),vglo(:,:,l),dpglo(:,:,l),dglo(:,:,l),img,jmg ) enddo end if @@ -134,7 +134,7 @@ subroutine windfix ( ua,va,plea, & ! -------------------------------- if (size(dpglo)>1) then do l=1,size(uglo,3) - call getdiv (uglo(1,1,l),vglo(1,1,l),dpglo(1,1,l),dglo(1,1,l),img,jmg ) + call getdiv (uglo(:,:,l),vglo(:,:,l),dpglo(:,:,l),dglo(:,:,l),img,jmg ) enddo end if @@ -211,7 +211,7 @@ subroutine windfix ( ua,va,plea, & ! ------------------------------------------------------------ if (size(dpglo)>1) then do l=1,size(dglo,3) - call VELPOT_SP (dglo(1,1,l),chi,img,jmg) + call VELPOT_SP (dglo(:,:,l),chi,img,jmg) call gradq (chi, uchi,vchi,img,jmg) uglo(:,:,l) = uglo(:,:,l) + uchi(:,:)/dpglo(:,:,l) vglo(:,:,l) = vglo(:,:,l) + vchi(:,:)/dpglo(:,:,l) diff --git a/GMAO_mpeu/CMakeLists.txt b/GMAO_mpeu/CMakeLists.txt index 986ceaa7..bbc348c6 100644 --- a/GMAO_mpeu/CMakeLists.txt +++ b/GMAO_mpeu/CMakeLists.txt @@ -57,9 +57,9 @@ file (MAKE_DIRECTORY ${esma_etc}/GMAO_eu) set_source_files_properties (m_FileResolv.f90 PROPERTIES COMPILE_FLAGS ${PP}) # NAG notices if the same procedure is called with varying types in the absence -# of an explicit interface. -target_compile_options (${this} PRIVATE $<$:${MISMATCH}>) -target_compile_options (GMAO_eu PRIVATE $<$:${MISMATCH}>) +# of an explicit interface. The MISMATCH flag is now in common_Fortran_flags. +# target_compile_options (${this} PRIVATE $<$:${MISMATCH}>) +# target_compile_options (GMAO_eu PRIVATE $<$:${MISMATCH}>) file (COPY assert.H DESTINATION ${include_${this}}) file (COPY assert.H DESTINATION ${esma_include}/GMAO_eu) diff --git a/GMAO_mpeu/m_ioutil.F90 b/GMAO_mpeu/m_ioutil.F90 index 342e2d1a..e7f81c0d 100644 --- a/GMAO_mpeu/m_ioutil.F90 +++ b/GMAO_mpeu/m_ioutil.F90 @@ -497,11 +497,12 @@ function swapI4_(ibuf) !EOP ___________________________________________________________________ character(len=*),parameter :: myname_=myname//'::swapI4_' + character(len=1),dimension(4*size(ibuf)) :: cbuf_in, cbuf_out - ! TRANSFER() should be used. The current implementation may be - ! not fully portable. - - call ioutil_byteswap_(size(ibuf),4,ibuf,swapI4_) + ! Use TRANSFER() for proper type conversion (NAG-safe) + cbuf_in = transfer(ibuf, cbuf_in) + call ioutil_byteswap_(size(ibuf),4,cbuf_in,cbuf_out) + swapI4_ = transfer(cbuf_out, swapI4_) end function swapI4_ @@ -527,11 +528,12 @@ function swapI8_(ibuf) !EOP ___________________________________________________________________ character(len=*),parameter :: myname_=myname//'::swapI8_' + character(len=1),dimension(8*size(ibuf)) :: cbuf_in, cbuf_out - ! TRANSFER() should be used. The current implementation may be - ! not fully portable. - - call ioutil_byteswap_(size(ibuf),8,ibuf,swapI8_) + ! Use TRANSFER() for proper type conversion (NAG-safe) + cbuf_in = transfer(ibuf, cbuf_in) + call ioutil_byteswap_(size(ibuf),8,cbuf_in,cbuf_out) + swapI8_ = transfer(cbuf_out, swapI8_) end function swapI8_ end module m_ioutil diff --git a/GMAO_mpeu/mpi0/mpi0_copy.F90 b/GMAO_mpeu/mpi0/mpi0_copy.F90 index 0b360e15..79f46072 100644 --- a/GMAO_mpeu/mpi0/mpi0_copy.F90 +++ b/GMAO_mpeu/mpi0/mpi0_copy.F90 @@ -42,25 +42,73 @@ subroutine mpi0_copy(sbuf,scount,stype,rbuf,rcount,rtype,ier) if( stype==MPI_INTEGER ) then call copy_INTEGER(sbuf,rbuf,scount) elseif( stype==MPI_REAL ) then - call copy_REAL(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + real,dimension(scount) :: sbuf_real, rbuf_real + sbuf_real = transfer(sbuf(1:scount), sbuf_real) + call copy_REAL(sbuf_real,rbuf_real,scount) + rbuf(1:scount) = transfer(rbuf_real, rbuf(1:scount)) + end block elseif( stype==MPI_DOUBLE_PRECISION ) then - call copy_DOUBLE_PRECISION(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + double precision,dimension(scount) :: sbuf_dbl, rbuf_dbl + sbuf_dbl = transfer(sbuf(1:scount), sbuf_dbl) + call copy_DOUBLE_PRECISION(sbuf_dbl,rbuf_dbl,scount) + rbuf(1:scount) = transfer(rbuf_dbl, rbuf(1:scount)) + end block elseif( stype==MPI_LOGICAL ) then - call copy_LOGICAL(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + logical,dimension(scount) :: sbuf_log, rbuf_log + sbuf_log = transfer(sbuf(1:scount), sbuf_log) + call copy_LOGICAL(sbuf_log,rbuf_log,scount) + rbuf(1:scount) = transfer(rbuf_log, rbuf(1:scount)) + end block elseif( stype==MPI_CHARACTER ) then - call copy_CHARACTER(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + character,dimension(scount) :: sbuf_char, rbuf_char + sbuf_char = transfer(sbuf(1:scount), sbuf_char) + call copy_CHARACTER(sbuf_char,rbuf_char,scount) + rbuf(1:scount) = transfer(rbuf_char, rbuf(1:scount)) + end block elseif( stype==MPI_INTEGER4 ) then call copy_INTEGER4(sbuf,rbuf,scount) elseif( stype==MPI_REAL4 ) then - call copy_REAL4(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + real,dimension(scount) :: sbuf_r4, rbuf_r4 + sbuf_r4 = transfer(sbuf(1:scount), sbuf_r4) + call copy_REAL4(sbuf_r4,rbuf_r4,scount) + rbuf(1:scount) = transfer(rbuf_r4, rbuf(1:scount)) + end block elseif( stype==MPI_REAL8 ) then - call copy_REAL8(sbuf,rbuf,scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + double precision,dimension(scount) :: sbuf_r8, rbuf_r8 + sbuf_r8 = transfer(sbuf(1:scount), sbuf_r8) + call copy_REAL8(sbuf_r8,rbuf_r8,scount) + rbuf(1:scount) = transfer(rbuf_r8, rbuf(1:scount)) + end block elseif( stype==MPI_2INTEGER ) then call copy_INTEGER(sbuf,rbuf,2*scount) elseif( stype==MPI_2REAL ) then - call copy_REAL(sbuf,rbuf,2*scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + real,dimension(2*scount) :: sbuf_real, rbuf_real + sbuf_real = transfer(sbuf(1:2*scount), sbuf_real) + call copy_REAL(sbuf_real,rbuf_real,2*scount) + rbuf(1:2*scount) = transfer(rbuf_real, rbuf(1:2*scount)) + end block elseif( stype==MPI_2DOUBLE_PRECISION ) then - call copy_DOUBLE_PRECISION(sbuf,rbuf,2*scount) + ! Use TRANSFER for type safety (NAG-compatible) + block + double precision,dimension(2*scount) :: sbuf_dbl, rbuf_dbl + sbuf_dbl = transfer(sbuf(1:2*scount), sbuf_dbl) + call copy_DOUBLE_PRECISION(sbuf_dbl,rbuf_dbl,2*scount) + rbuf(1:2*scount) = transfer(rbuf_dbl, rbuf(1:2*scount)) + end block else ier=stype if(stype==0) ier=MPI_UNDEFINED From 99e210b44020227e08a4aa94e18f3fb25d205614 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Tue, 5 May 2026 13:26:24 -0400 Subject: [PATCH 7/8] Fix NAG compiler issues in GMAO_gfio and GMAO_hermes - GMAO_gfio/CMakeLists.txt: add -wmismatch for legacy NetCDF-2 C API routines (NCVDEF, NCAPT, NCVPT, NCAGT, NCVGT, NCVGT1) called with varying Fortran types intentionally - GMAO_hermes/CMakeLists.txt: remove duplicate ${MISMATCH} from CMAKE_Fortran_FLAGS_RELEASE (already in common_Fortran_flags); add -wmismatch for GFIO_PUTREALATT/GFIO_GETREALATT type-punning - GMAO_hermes/m_nc_JEDIinc.f90: replace byte-count kind literal real(4) with portable real(selected_real_kind(6)) via parameter r4 - GMAO_hermes/m_nc_akbk.f90: replace double precision with real(real64) from iso_fortran_env so NF90_PUT_VAR generic resolves correctly when compiled with -r8 --- GMAO_gfio/CMakeLists.txt | 6 ++++ GMAO_hermes/CMakeLists.txt | 6 +++- GMAO_hermes/m_nc_JEDIinc.f90 | 59 +++++++++++++++++++----------------- GMAO_hermes/m_nc_akbk.f90 | 5 +-- 4 files changed, 45 insertions(+), 31 deletions(-) diff --git a/GMAO_gfio/CMakeLists.txt b/GMAO_gfio/CMakeLists.txt index 5fe73bf6..141e2db2 100644 --- a/GMAO_gfio/CMakeLists.txt +++ b/GMAO_gfio/CMakeLists.txt @@ -27,6 +27,12 @@ if (EXTENDED_SOURCE) endif() set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) +# NAG: legacy NetCDF-2 C API (NCVDEF, NCAPT, NCVPT, NCAGT, NCVGT, NCVGT1) is +# called with varying Fortran types intentionally — suppress type mismatch errors +if (CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + target_compile_options(${this} PRIVATE $<$:-wmismatch=NCVDEF,NCAPT,NCVPT,NCAGT,NCVGT,NCVGT1>) +endif() + # Specs for r8 version if (precision STREQUAL "r8") string(REPLACE " " ";" tmp ${FREAL8}) diff --git a/GMAO_hermes/CMakeLists.txt b/GMAO_hermes/CMakeLists.txt index b06cc58c..77c1b8f4 100644 --- a/GMAO_hermes/CMakeLists.txt +++ b/GMAO_hermes/CMakeLists.txt @@ -3,7 +3,7 @@ esma_set_this() add_definitions (-DHERMES -DDEBUG_SHAVE -Dunix -D__unix__) string (REPLACE " " ";" flags ${FREAL8}) add_compile_options(${flags}) -set (CMAKE_Fortran_FLAGS_RELEASE "-O3 ${common_Fortran_flags} ${ALIGNCOM} ${MISMATCH}") +set (CMAKE_Fortran_FLAGS_RELEASE "-O3 ${common_Fortran_flags} ${ALIGNCOM}") if ( NOT HERMES_LIGHT ) @@ -20,6 +20,10 @@ if ( NOT HERMES_LIGHT ) esma_add_library(${this} SRCS ${srcs} DEPENDENCIES GMAO_mpeu GMAO_gfio_r8) target_compile_options(${this} PRIVATE ${flags}) + # NAG: suppress GFIO type-punning mismatches + if (CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + target_compile_options(${this} PRIVATE $<$:-wmismatch=GFIO_PUTREALATT,GFIO_GETREALATT>) + endif() if (EXTENDED_SOURCE) set_source_files_properties (m_interpack.F PROPERTIES COMPILE_FLAGS ${EXTENDED_SOURCE}) diff --git a/GMAO_hermes/m_nc_JEDIinc.f90 b/GMAO_hermes/m_nc_JEDIinc.f90 index 8942eab3..2117966b 100644 --- a/GMAO_hermes/m_nc_JEDIinc.f90 +++ b/GMAO_hermes/m_nc_JEDIinc.f90 @@ -3,6 +3,9 @@ module m_nc_JEDIinc implicit none private +! NAG: use portable kind parameter instead of byte-count literal real(r4) +integer, parameter :: r4 = selected_real_kind(6) + public :: nc_JEDIinc_vars_init public :: nc_JEDIinc_vars_final public :: nc_JEDIinc_vars_comp @@ -20,19 +23,19 @@ module m_nc_JEDIinc logical :: initialized=.false. integer :: nlon,nlat,nsig logical :: gsiset=.false. - real(4),pointer,dimension(:):: ak=>NULL(),bk=>NULL() - real(4),pointer,dimension(:,:,:):: dp=>NULL() - real(4),pointer,dimension(:,:,:):: tv=>NULL() - real(4),pointer,dimension(:,:,:):: t=>NULL() - real(4),pointer,dimension(:,:,:):: u=>NULL(),v=>NULL() - real(4),pointer,dimension(:,:,:):: qv=>NULL() - real(4),pointer,dimension(:,:,:):: qi=>NULL(),ql=>NULL(),qr=>NULL(),qs=>NULL() - real(4),pointer,dimension(:,:,:):: oz=>NULL() - real(4),pointer,dimension(:,:) :: ps=>NULL(),ts=>NULL() + real(r4),pointer,dimension(:):: ak=>NULL(),bk=>NULL() + real(r4),pointer,dimension(:,:,:):: dp=>NULL() + real(r4),pointer,dimension(:,:,:):: tv=>NULL() + real(r4),pointer,dimension(:,:,:):: t=>NULL() + real(r4),pointer,dimension(:,:,:):: u=>NULL(),v=>NULL() + real(r4),pointer,dimension(:,:,:):: qv=>NULL() + real(r4),pointer,dimension(:,:,:):: qi=>NULL(),ql=>NULL(),qr=>NULL(),qs=>NULL() + real(r4),pointer,dimension(:,:,:):: oz=>NULL() + real(r4),pointer,dimension(:,:) :: ps=>NULL(),ts=>NULL() ! - real(4),pointer,dimension(:) :: v1d=>NULL() - real(4),pointer,dimension(:,:) :: v2d=>NULL() - real(4),pointer,dimension(:,:,:):: v3d=>NULL() + real(r4),pointer,dimension(:) :: v1d=>NULL() + real(r4),pointer,dimension(:,:) :: v2d=>NULL() + real(r4),pointer,dimension(:,:,:):: v3d=>NULL() end type nc_JEDIinc_vars character(len=*), parameter :: myname = 'm_nc_JEDIinc' @@ -153,7 +156,7 @@ subroutine read_JEDIinc_ (fname,bvars,rc, myid,root, gsiset) integer :: ndims_, nvars_, ngatts_, unlimdimid_ integer :: nlat_,nlon_,nlev_ integer :: mype_,root_ - real(4), allocatable :: data_in(:,:,:) + real(r4), allocatable :: data_in(:,:,:) logical :: verbose logical :: init_ logical :: gsi_ @@ -330,10 +333,10 @@ subroutine write_JEDIinc_ (fname,bvars,lats,lons,rc, myid,root,plevs) implicit none character(len=*), intent(in) :: fname ! input filename type(nc_JEDIinc_vars),intent(in) :: bvars ! background error variables - real(4), intent(in) :: lats(:) ! latitudes per GSI: increase index from South to North Pole - real(4), intent(in) :: lons(:) ! longitude per GSI: increase index from East to West + real(r4), intent(in) :: lats(:) ! latitudes per GSI: increase index from South to North Pole + real(r4), intent(in) :: lons(:) ! longitude per GSI: increase index from East to West integer, intent(out) :: rc - real(4), intent(in), optional :: plevs(:) + real(r4), intent(in), optional :: plevs(:) integer, intent(in), optional :: myid,root ! accommodate MPI calling programs character(len=*), parameter :: myname_ = myname//"::read_" @@ -352,8 +355,8 @@ subroutine write_JEDIinc_ (fname,bvars,lats,lons,rc, myid,root,plevs) ! This is the data array we will write. It will just be filled with ! a progression of integers for this example. - real(4), allocatable :: data_out(:,:,:) - real(4), allocatable :: idlevs(:) + real(r4), allocatable :: data_out(:,:,:) + real(r4), allocatable :: idlevs(:) ! Consistency check if (bvars%gsiset) then @@ -625,7 +628,7 @@ subroutine get_pointer_2d_ (vname, bvars, ptr, rc ) implicit none character(len=*), intent(in) :: vname type(nc_JEDIinc_vars) bvars -real(4),pointer,intent(inout) :: ptr(:,:) +real(r4),pointer,intent(inout) :: ptr(:,:) integer,intent(out) :: rc rc=-1 if(trim(vname)=='ps') then @@ -642,7 +645,7 @@ subroutine get_pointer_3d_ (vname, bvars, ptr, rc ) implicit none character(len=*), intent(in) :: vname type(nc_JEDIinc_vars) bvars -real(4),pointer,intent(inout) :: ptr(:,:,:) +real(r4),pointer,intent(inout) :: ptr(:,:,:) integer,intent(out) :: rc character(len=5) :: var rc=-1 @@ -804,8 +807,8 @@ subroutine hflip3_ ( q,im,jm,km, gsi ) implicit none integer im,jm,km,i,j,k logical gsi - real(4), intent(inout) :: q(:,:,:) - real(4), allocatable :: dum(:) + real(r4), intent(inout) :: q(:,:,:) + real(r4), allocatable :: dum(:) allocate ( dum(im) ) if (gsi) then do k=1,km @@ -835,8 +838,8 @@ subroutine hflip2_ ( q,im,jm, gsi ) implicit none integer im,jm,i,j logical gsi - real(4), intent(inout) :: q(:,:) - real(4), allocatable :: dum(:) + real(r4), intent(inout) :: q(:,:) + real(r4), allocatable :: dum(:) allocate ( dum(im) ) if (gsi) then do j=1,jm @@ -861,8 +864,8 @@ end subroutine hflip2_ subroutine vflip_(q,im,jm,km) implicit none integer,intent(in) :: im,jm,km - real(4),intent(inout) :: q(im,jm,km) - real(4), allocatable :: dum(:) + real(r4),intent(inout) :: q(im,jm,km) + real(r4), allocatable :: dum(:) integer i,j allocate(dum(km)) do j=1,jm @@ -901,7 +904,7 @@ end subroutine summary_ real function stddev2_(x) implicit none - real(4) :: x(:,:) + real(r4) :: x(:,:) integer im,jm real mean im = size(x,1) @@ -912,7 +915,7 @@ end function stddev2_ real function stddev3_(x) implicit none - real(4) :: x(:,:,:) + real(r4) :: x(:,:,:) integer im,jm,km real mean im = size(x,1) diff --git a/GMAO_hermes/m_nc_akbk.f90 b/GMAO_hermes/m_nc_akbk.f90 index 7d8398c0..a4759585 100644 --- a/GMAO_hermes/m_nc_akbk.f90 +++ b/GMAO_hermes/m_nc_akbk.f90 @@ -1,5 +1,6 @@ module m_nc_akbk use netcdf +use iso_fortran_env, only: real64 implicit none private public :: write_nc_akbk @@ -12,14 +13,14 @@ module m_nc_akbk subroutine write_nc_akbk_ (fname,ak, bk) character(len=*), intent(in) :: fname - double precision, intent(in) :: ak(:), bk(:) + real(real64), intent(in) :: ak(:), bk(:) ! NetCDF variables integer :: ncid, dimid_edge integer :: varid_edge, varid_ak, varid_bk integer :: rc integer :: i, km - double precision, allocatable :: edge(:) + real(real64), allocatable :: edge(:) km = size(ak) allocate(edge(km)) From 83994e8a97b42faaebf203cb8ee21ce1a927d55b Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Wed, 6 May 2026 12:03:31 -0400 Subject: [PATCH 8/8] changed by Claude --- CMakeLists.txt | 2 +- GEOS_Util/plots/zonal.f | 1369 ----- GEOS_Util/post/binarytile.F90 | 84 - GEOS_Util/post/checkdate.F | 604 --- GEOS_Util/post/convert_aerosols.F | 3112 ----------- GEOS_Util/post/convert_eta.F | 3527 ------------ GEOS_Util/post/ec_eta2fv.F | 2887 ---------- GEOS_Util/post/ec_prs2eta.F | 2126 -------- GEOS_Util/post/ec_prs2fv.F | 4742 ---------------- GEOS_Util/post/era5_prs2eta.F | 2138 -------- GEOS_Util/post/eta2prs.F | 2790 ---------- GEOS_Util/post/eta2rst.F | 2143 -------- GEOS_Util/post/fire.F | 615 --- GEOS_Util/post/fix_undef.F90 | 315 -- GEOS_Util/post/flat2hdf.F | 1055 ---- GEOS_Util/post/fvrst.F | 285 - GEOS_Util/post/gg2eta.F | 901 ---- GEOS_Util/post/gg2fv.F | 3368 ------------ GEOS_Util/post/hdf2rs.F | 3987 -------------- GEOS_Util/post/makeiau.F | 3672 ------------- GEOS_Util/post/merra2scm.F | 1198 ----- GEOS_Util/post/mpi_util.F | 1532 ------ GEOS_Util/post/ncep_prs2fv.F | 4777 ----------------- GEOS_Util/post/rs2hdf.F | 1391 ----- GEOS_Util/post/rs_hinterp.F | 2663 --------- GEOS_Util/post/rs_numtiles.F90 | 83 - GEOS_Util/post/rs_vinterp.F90 | 1190 ---- GEOS_Util/post/rs_vinterp_scm.F90 | 1302 ----- GEOS_Util/post/rsg3_vinterp.F | 3820 ------------- GEOS_Util/post/stats.F90 | 3588 ------------- GEOS_Util/post/swapendian_FV.f90 | 62 - GEOS_Util/post/swapendian_RST.f90 | 56 - GEOS_Util/post/tick.F | 185 - GEOS_Util/post/time_ave.F | 1346 ----- GEOS_Util/post/timer.F | 173 - .../pre/NSIDC-OSTIA_SST-ICE_blend/check.F90 | 13 - .../lake_data_EIGTHdeg.F90 | 235 - .../proc_SST_FRACI.F90 | 355 -- .../proc_SST_FRACI_ostia_quart.F90 | 259 - GMAO_gfio/CMakeLists.txt | 5 + GMAO_gfio/ut_cyclic.f90 | 2 +- GMAO_hermes/CMakeLists.txt | 10 +- GMAO_hermes/GFIO_remap.f90 | 2 +- GMAO_hermes/blendq.f90 | 4 +- GMAO_hermes/dyn2dyn.f90 | 6 +- GMAO_hermes/dyn_hydro.f90 | 6 +- GMAO_hermes/dyn_jediupd.f90 | 20 +- GMAO_hermes/dyndiff.f90 | 2 +- GMAO_hermes/dyndims.f | 2 +- GMAO_hermes/eta_echo.f90 | 2 +- GMAO_hermes/extract_stations.F90 | 6 +- GMAO_hermes/fv2prs.F90 | 8 +- GMAO_hermes/geos2fv.f | 14 +- GMAO_hermes/m_dyn_util.F90 | 2 +- GMAO_hermes/rout2prs.f | 4 +- GMAO_hermes/ut_ana2dyn.f90 | 2 +- GMAO_hermes/ut_dyn_ipert.f90 | 4 +- 57 files changed, 58 insertions(+), 63993 deletions(-) delete mode 100644 GEOS_Util/plots/zonal.f delete mode 100644 GEOS_Util/post/binarytile.F90 delete mode 100644 GEOS_Util/post/checkdate.F delete mode 100644 GEOS_Util/post/convert_aerosols.F delete mode 100644 GEOS_Util/post/convert_eta.F delete mode 100644 GEOS_Util/post/ec_eta2fv.F delete mode 100644 GEOS_Util/post/ec_prs2eta.F delete mode 100644 GEOS_Util/post/ec_prs2fv.F delete mode 100644 GEOS_Util/post/era5_prs2eta.F delete mode 100644 GEOS_Util/post/eta2prs.F delete mode 100644 GEOS_Util/post/eta2rst.F delete mode 100644 GEOS_Util/post/fire.F delete mode 100644 GEOS_Util/post/fix_undef.F90 delete mode 100644 GEOS_Util/post/flat2hdf.F delete mode 100644 GEOS_Util/post/fvrst.F delete mode 100644 GEOS_Util/post/gg2eta.F delete mode 100644 GEOS_Util/post/gg2fv.F delete mode 100644 GEOS_Util/post/hdf2rs.F delete mode 100644 GEOS_Util/post/makeiau.F delete mode 100644 GEOS_Util/post/merra2scm.F delete mode 100644 GEOS_Util/post/mpi_util.F delete mode 100644 GEOS_Util/post/ncep_prs2fv.F delete mode 100644 GEOS_Util/post/rs2hdf.F delete mode 100755 GEOS_Util/post/rs_hinterp.F delete mode 100644 GEOS_Util/post/rs_numtiles.F90 delete mode 100644 GEOS_Util/post/rs_vinterp.F90 delete mode 100644 GEOS_Util/post/rs_vinterp_scm.F90 delete mode 100644 GEOS_Util/post/rsg3_vinterp.F delete mode 100644 GEOS_Util/post/stats.F90 delete mode 100644 GEOS_Util/post/swapendian_FV.f90 delete mode 100644 GEOS_Util/post/swapendian_RST.f90 delete mode 100644 GEOS_Util/post/tick.F delete mode 100644 GEOS_Util/post/time_ave.F delete mode 100644 GEOS_Util/post/timer.F delete mode 100644 GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/check.F90 delete mode 100644 GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/lake_data_EIGTHdeg.F90 delete mode 100644 GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI.F90 delete mode 100644 GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI_ostia_quart.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index c81c7d1f..51504c16 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -11,7 +11,7 @@ if ( NOT HERMES_LIGHT ) GMAO_mpeu GMAO_pilgrim GMAO_etc - GEOS_Util + @GEOS_Util LANL_Shared GMAO_perllib GMAO_transf diff --git a/GEOS_Util/plots/zonal.f b/GEOS_Util/plots/zonal.f deleted file mode 100644 index dde8eead..00000000 --- a/GEOS_Util/plots/zonal.f +++ /dev/null @@ -1,1369 +0,0 @@ - PROGRAM main - implicit none - character*120 title - character*120 begdate - - real, allocatable :: uz(:,:) - real, allocatable :: vz(:,:) - real, allocatable :: tz(:,:) - real, allocatable :: wz(:,:) - real, allocatable :: thz(:,:) - real, allocatable :: upvpz(:,:) - real, allocatable :: upwpz(:,:) - real, allocatable :: vptpz(:,:) - real, allocatable :: vpthpz(:,:) - real, allocatable :: pl(:,:) - real, allocatable :: pk(:,:) - real, allocatable :: strm(:,:) - real, allocatable :: res(:,:) - real, allocatable :: vstar(:,:) - real, allocatable :: wstar(:,:) - real, allocatable :: wmean(:,:) - real, allocatable :: weddy(:,:) - real, allocatable :: psi1(:,:) ! Residual Mass StreamFunction (Method 1) - real, allocatable :: psi2(:,:) ! Residual Mass StreamFunction (Method 2) - real, allocatable :: psim(:,:) ! Mean Mass StreamFunction - real, allocatable :: epfy(:,:) ! Eliassen-Palm Flux in Northward Direction - real, allocatable :: epfz(:,:) ! Eliassen-Palm Flux in Upward Direction - real, allocatable :: epfdiv(:,:) ! Eliassen-Palm Flux Divergence - real, allocatable :: vstr(:,:) - real*4, allocatable :: dum(:) - - real,allocatable :: upvp (:,:) - real,allocatable :: upwp (:,:) - real,allocatable :: dudp (:,:) - real,allocatable :: dudphi(:,:) - real,allocatable :: psie (:,:) - real,allocatable :: dfdphi(:,:) - real,allocatable :: dfdp (:,:) - real,allocatable :: plz (:,:) - real,allocatable :: delp (:,:) - - character*120, allocatable :: arg(:) - character*120 tag, output - real undef, lat0 - integer im,jm,lm,tm - integer j,L,n,nt,lrec - integer rc,nargs - - undef = 1e15 - - nargs = command_argument_count() - if( nargs.ne.0 ) then - allocate( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-tag' ) tag = '.' // arg(n+1) - enddo - else - tag = "" - endif - -c Read TXT Files to determine resolution -c -------------------------------------- - open (10,file='LAT0' // trim(tag) // '.txt',form='formatted') - read (10,*) lat0 - print *, 'LAT0 = ',lat0 - close(10) - open (10,file='XDIM' // trim(tag) // '.txt',form='formatted') - read (10,*) im - print *, 'IM = ',im - close(10) - open (10,file='YDIM' // trim(tag) // '.txt',form='formatted') - read (10,*) jm - print *, 'JM = ',jm - close(10) - open (10,file='ZDIM' // trim(tag) // '.txt',form='formatted') - read (10,*) lm - print *, 'LM = ',lm - close(10) - open (10,file='TDIM' // trim(tag) // '.txt',form='formatted') - read (10,*) tm - print *, 'TDIM = ',tm - close(10) - open (10,file='BEGDATE' // trim(tag) // '.txt',form='formatted') - read (10,*) begdate - close(10) - - allocate( uz(jm,lm) ) - allocate( vz(jm,lm) ) - allocate( tz(jm,lm) ) - allocate( wz(jm,lm) ) - allocate( thz(jm,lm) ) - allocate( upvpz(jm,lm) ) - allocate( upwpz(jm,lm) ) - allocate( vptpz(jm,lm) ) - allocate( vpthpz(jm,lm) ) - allocate( pl(jm,lm) ) - allocate( pk(jm,lm) ) - allocate( strm(jm,lm) ) - allocate( res(jm,lm) ) - allocate( vstar(jm,lm) ) - allocate( wstar(jm,lm) ) - allocate( wmean(jm,lm) ) - allocate( weddy(jm,lm) ) - allocate( psi1(jm,lm) ) - allocate( psi2(jm,lm) ) - allocate( psim(jm,lm) ) - allocate( epfy(jm,lm) ) - allocate( epfz(jm,lm) ) - allocate( epfdiv(jm,lm) ) - allocate( vstr(jm,lm) ) - allocate( dum(jm) ) - - allocate (upvp (jm,LM) ) - allocate (upwp (jm,LM) ) - allocate (dudp (jm,LM) ) - allocate (dudphi(jm,LM) ) - allocate (psie (jm,LM) ) - allocate (dfdphi(jm,LM) ) - allocate (dfdp (jm,LM) ) - allocate (plz (jm,LM) ) - allocate (delp (jm,LM) ) - -c GRADS Datasets -c -------------- - open (10,file= 'grads' // trim(tag) // '.fwrite',form='unformatted',access='direct',recl=jm*4) - open (20,file='residual' // trim(tag) // '.data' ,form='unformatted',access='sequential') - open (30,file='residual' // trim(tag) // '.ctl' ,form='formatted') - -c Read data from grads.fwrite -c --------------------------- - nt = 0 - rc = 0 - lrec = 1 - do n=1,tm - if(n.eq.1) print *, 'Reading VZ' - do L=1,lm - read(10,rec=lrec,iostat=rc) dum - if( rc.eq.0 ) then - vz(:,L) = dum(:) - else - vz(:,L) = undef - if( L.eq.1 ) print *, 'Error Reading VZ, setting to UNDEF' - endif - lrec = lrec+1 - enddo - if(n.eq.1) print *, 'Reading TZ' - do L=1,lm - read(10,rec=lrec,iostat=rc) dum - if( rc.eq.0 ) then - tz(:,L) = dum(:) - else - tz(:,L) = undef - if( L.eq.1 ) print *, 'Error Reading TZ, setting to UNDEF' - endif - lrec = lrec+1 - enddo - if(n.eq.1) print *, 'Reading VPTPZ' - do L=1,lm - read(10,rec=lrec,iostat=rc) dum - if( rc.eq.0 ) then - vptpz(:,L) = dum(:) - else - vptpz(:,L) = undef - if( L.eq.1 ) print *, 'Error Reading VPTPZ, setting to UNDEF' - endif - lrec = lrec+1 - enddo - if(n.eq.1) print *, 'Reading PL' - do L=1,lm - read(10,rec=lrec,iostat=rc) dum - if( rc.eq.0 ) then - pl(:,L) = dum(:) - else - pl(:,L) = undef - if( L.eq.1 ) print *, 'Error Reading PL, setting to UNDEF' - endif - lrec = lrec+1 - enddo - if(n.eq.1) print *, 'Reading PK' - do L=1,lm - read(10,rec=lrec,iostat=rc) dum - if( rc.eq.0 ) then - pk(:,L) = dum(:) - else - pk(:,L) = undef - if( L.eq.1 ) print *, 'Error Reading PK, setting to UNDEF' - endif - lrec = lrec+1 - enddo - if(n.eq.1) print *, 'Reading UZ' - do L=1,lm - read(10,rec=lrec,iostat=rc) dum - if( rc.eq.0 ) then - uz(:,L) = dum(:) - else - uz(:,L) = undef - if( L.eq.1 ) print *, 'Error Reading UZ, setting to UNDEF' - endif - lrec = lrec+1 - enddo - if(n.eq.1) print *, 'Reading UPVPZ' - do L=1,lm - read(10,rec=lrec,iostat=rc) dum - if( rc.eq.0 ) then - upvpz(:,L) = dum(:) - else - upvpz(:,L) = undef - if( L.eq.1 ) print *, 'Error Reading UPVPZ, setting to UNDEF' - endif - lrec = lrec+1 - enddo - if(n.eq.1) print *, 'Reading UPWPZ' - do L=1,lm - read(10,rec=lrec,iostat=rc) dum - if( rc.eq.0 ) then - upwpz(:,L) = dum(:) - else - upwpz(:,L) = undef - if( L.eq.1 ) print *, 'Error Reading UPWPZ, setting to UNDEF' - endif - lrec = lrec+1 - enddo - - nt = nt+1 - do L=1,lm - do j=1,jm - if( abs(tz(j,L)-undef).gt.0.1 ) then - thz(j,L) = tz(j,L)/pk(j,L) ! K/mb**kappa - else - thz(j,L) = undef - endif - if( abs(vptpz(j,L)-undef).gt.0.1 ) then - vpthpz(j,L) = vptpz(j,L)/pk(j,L) ! m/sec K/mb**kappa - else - vpthpz(j,L) = undef - endif - enddo - enddo - -c Compute Meridional Streamfunction -c --------------------------------- - call stream ( vz,pl,jm,lm,strm,undef ) - - call make_psi ( uz,vz,thz,upvpz,upwpz,vpthpz,pl,jm,lm,psi1,psi2,psim,epfy,epfz,epfdiv,undef, - . upvp,upwp,dudp,dudphi,psie,dfdphi,dfdp,plz,delp) - -c Compute Mean Vertical Velocity from Continuity -c ---------------------------------------------- - call make_w ( vz,pl,jm,lm,wz,undef ) - -c Compute Residual Circulation -c ---------------------------- - call residual ( vz,vpthpz,thz,wz,pl,jm,lm,res,vstar,wstar,wmean,weddy,undef ) - - call GLAWRT (strm ,jm,LM,20) - call GLAWRT (res ,jm,LM,20) - call GLAWRT (vstar ,jm,LM,20) - call GLAWRT (wstar ,jm,LM,20) - call GLAWRT (wmean ,jm,LM,20) - call GLAWRT (weddy ,jm,LM,20) - call GLAWRT (psi1 ,jm,LM,20) - call GLAWRT (psi2 ,jm,LM,20) - call GLAWRT (psim ,jm,LM,20) - call GLAWRT (epfy ,jm,LM,20) - call GLAWRT (epfz ,jm,LM,20) - call GLAWRT (epfdiv,jm,LM,20) - - call GLAWRT (upvp ,jm,LM,20) - call GLAWRT (upwp ,jm,LM,20) - call GLAWRT (dudp ,jm,LM,20) - call GLAWRT (dudphi,jm,LM,20) - call GLAWRT (psie ,jm,LM,20) - call GLAWRT (dfdphi,jm,LM,20) - call GLAWRT (dfdp ,jm,LM,20) - call GLAWRT (plz ,jm,LM,20) - call GLAWRT (delp ,jm,LM,20) - - enddo - close(10) - -c Write Grads Control File -c ------------------------ - output = '^residual' // trim(tag) // '.data' - title = 'Streamfunction and Residual Circulation' - - write(30,101) trim(output),trim(title),undef,jm,lat0,2*abs(lat0)/(jm-1),lm - do L=1,lm - print *, 'Pressure = ',pl(1,L) - write(30,102) pl(1,L) - enddo - print *, 'Finished , nt = ',nt - write(30,103) nt,trim(begdate),lm,lm,lm,lm,lm,lm,lm,lm,lm,lm,lm,lm, - . lm,lm,lm,lm,lm,lm,lm,lm,lm - 101 format('dset ',a,/, - . 'title ',a,/, - . 'options sequential ',/, - . 'undef ',e15.6,/, - . 'xdef 1 linear -180 1',/, - . 'ydef ',i4,' linear ',f8.3,2x,f8.3,/, - . 'zdef ',i3,' levels ') - 102 format(10x,f8.3) - 103 format('tdef ',i3,' linear ',a,' 1mo',/, - . 'vars 21',/, - . 'str ',i3,' 0 Streamfunction',/, - . 'res ',i3,' 0 Residual Circulation',/, - . 'vstar ',i3,' 0 Vstar',/, - . 'wstar ',i3,' 0 wstar',/, - . 'wmean ',i3,' 0 wmean ',/, - . 'weddy ',i3,' 0 weddy ',/, - . 'psi1 ',i3,' 0 Res1 streamfunction ',/, - . 'psi2 ',i3,' 0 Res2 streamfunction ',/, - . 'psim ',i3,' 0 Mass streamfunction ',/, - . 'epfy ',i3,' 0 Eliassen-Palm flux y',/, - . 'epfz ',i3,' 0 Eliassen-Palm flux z',/, - . 'epfdiv ',i3,' 0 Eliassen-Palm flux Divergence',/, - . 'upvp ',i3,' 0 Uprime Vprim',/, - . 'upwp ',i3,' 0 Uprime Omegaprime',/, - . 'dudp ',i3,' 0 DuDp',/, - . 'dudphi ',i3,' 0 DuDphi',/, - . 'psie ',i3,' 0 Eddy Streamfunction',/, - . 'dfdphi ',i3,' 0 DfDphi',/, - . 'dfdp ',i3,' 0 DfDp',/, - . 'plz ',i3,' 0 Pressure',/, - . 'delp ',i3,' 0 Pressure Thickness',/, - . 'endvars') - - stop - end - - SUBROUTINE ZONAL ( A,AZ,IM,JNP,undef ) - DIMENSION A(IM,JNP), AZ(JNP) - - DO J=1,JNP - AZ(J) = 0.0 - IC = 0 - DO I = 1, IM - IF( abs(A(I,J)-UNDEF).gt.0.1 ) THEN - AZ(J) = AZ(J) + A(I,J) - IC = IC + 1 - ENDIF - ENDDO - IF(IC.NE.0) AZ(J) = AZ(J) / IC - IF(IC.eq.0) AZ(J) = UNDEF - ENDDO - - RETURN - END - SUBROUTINE GLAWRT (A, IM,LM, KTP) - real A (IM,LM) - real*4 TEM (IM) - DO L=1,LM - DO I=1,IM - if( abs(a(i,L)).gt.1.e-20 ) then - TEM (I) = A(I,L) - else - TEM (I) = 0. - endif - ENDDO - WRITE(KTP) TEM - ENDDO - RETURN - END - - subroutine make_psi( u0,v0,th0,upvp0,upwp0,vpthp0,p0,jm,lm,psi1,psi2,psim,epfy,epfz,epfdiv,undef, - . upvp,upwp,dudp,dudphi,psie,dfdphi,dfdp,p,delp) - use MAPL_ConstantsMod - implicit none - integer j,k,L,jm,lm - real undef,dphi,a,g,pi,phi,pk0 - logical defined - - real th0(jm,lm), th(jm,lm) - real upvp0(jm,lm), upvp(jm,lm) - real upwp0(jm,lm), upwp(jm,lm) - real vpthp0(jm,lm), vpthp(jm,lm) - real u0(jm,lm), u(jm,lm) - real v0(jm,lm), v(jm,lm) - real p0(jm,lm), p(jm,lm) - - real psi1(jm,lm) - real psi2(jm,lm) - real psim(jm,lm) - real epfy(jm,lm) - real epfz(jm,lm) - real epfdiv(jm,lm) - - real dudp(jm,lm) - real dfdp(jm,lm) - real dthdp(jm,lm) - real dudphi(jm,lm) - real dfdphi(jm,lm) - real psie(jm,lm) - real delp(jm,lm) - real veddy(jm,lm) - real vstar(jm,lm) - real stuff(jm,lm) - real the(jm,0:lm) ! theta_edge - real ple(jm,0:lm) ! p_edge - real ue(jm,0:lm) ! u_edge - real epfze(jm,0:lm) ! epfz_edge - real f(jm) - real dum(jm) - integer method - -c Define Constants -c ---------------- - pi = 4.*atan(1.) - dphi = pi/(jm-1) - a = MAPL_RADIUS - g = MAPL_GRAV - - Method = 0 - -c Invert level index (in order to be top=>bottom) -c ----------------------------------------------- - do L=1,lm - u(:,L) = u0(:,lm-L+1) ! m/sec - v(:,L) = v0(:,lm-L+1) ! m/sec - p(:,L) = p0(:,lm-L+1) ! mb - th(:,L) = th0(:,lm-L+1) ! K/mb**kappa - upvp(:,L) = upvp0(:,lm-L+1) ! m/sec m/sec - upwp(:,L) = upwp0(:,lm-L+1) ! m/sec Pa/sec - vpthp(:,L) = vpthp0(:,lm-L+1) ! m/sec K/mb**kappa - enddo - - pk0 = (1000.0)**(2.0/7.0) ! mb**kappa - - where( abs(p -undef).gt.0.1 ) ; p = p*100 ; endwhere - where( abs(th -undef).gt.0.1 ) ; th = th*pk0 ; endwhere - where( abs(vpthp-undef).gt.0.1 ) ; vpthp = vpthp*pk0 ; endwhere - -c Compute PLE Edge Values -c ----------------------- - ple(:,0) = max( 0.0, p(:,1) - 0.5*( p(:,2)-p(:,1) ) ) - do L=1,lm-1 - do j=1,jm - ple(j,L) = ( p(j,L+1)+ p(j,L) )*0.5 - enddo - enddo - ple(:,lm) = p(:,lm) + 0.5*( p(:,lm)-p(:,lm-1) ) - - do L=1,lm - delp(:,L) = ple(:,L)-ple(:,L-1) - enddo - -c Compute Mass Streamfunction -c --------------------------- - pi = 4.*atan(1.) - dphi = pi/(jm-1) - a = MAPL_RADIUS - g = MAPL_GRAV - - do L=1,LM - dum(:) = 0.0 - do k=1,L - where( abs(v(:,k)-undef).gt.0.1 ) - dum(:) = dum(:) + v(:,k)*delp(:,k) - endwhere - enddo - do j=1,jm - phi = -pi/2 + (j-1)*dphi - psim(j,L) = 2*pi*a*cos(phi)/g * dum(j) - enddo - enddo - -c Define Eddy Streamfunction = vpthp/dthdp -c ---------------------------------------- - - ! call compute_edge( th,p,ple,jm,lm,undef,the ) - call map1_cubic( lm,p,th, lm+1,ple,the, jm, Method, undef) - call compute_dqdp( the,delp,jm,lm,undef,dthdp ) - - do L=1,lm - do j=1,jm - if( defined(dthdp(j,L),undef) .and. - . defined(vpthp(j,L),undef) ) then - dthdp(j,L) = min( -0.003*pk0/100, dthdp(j,L) ) - psie(j,L) = vpthp(j,L) / dthdp(j,L) - else - psie(j,L) = undef - endif - enddo - enddo - -c Compute Veddy = D/Dp[ psie ] -c ---------------------------- - do L=2,lm-1 - do j=1,jm - if( defined(psie(j,L+1),undef) .and. - . defined(psie(j,L-1),undef) ) then - veddy(j,L) = ( psie(j,L+1)-psie(j,L-1) )/ ( 2*(ple(j,L)-ple(j,L-1)) ) - else - veddy(j,L) = undef - endif - enddo - enddo - do j=1,jm - veddy(j,1) = veddy(j,2) - veddy(j,lm) = veddy(j,lm-1) - enddo - -c Compute Vstar = v - veddy -c ------------------------- - do L=1,lm - do j=1,jm - if( defined( veddy(j,L),undef) .and. - . defined( v(j,L),undef) ) then - vstar(j,L) = v(j,L) - veddy(j,L) - else - vstar(j,L) = undef - endif - enddo - enddo - - -c Construct Residual Streamfunction from Vstar (Method 1) -c ------------------------------------------------------- - do L=1,LM - dum(:) = 0.0 - do k=1,L - where( abs(vstar(:,k)-undef).gt.0.1 ) - dum(:) = dum(:) + vstar(:,k)*delp(:,k) - endwhere - enddo - do j=1,jm - phi = -pi/2 + (j-1)*dphi - psi1(j,L) = 2*pi*a*cos(phi)/g * dum(j) - enddo - enddo - - -c Compute Residual Streamfunction (Method 2) -c ------------------------------------------ - do L=1,lm - do j=1,jm - phi = -pi/2 + (j-1)*dphi - if( defined(psie(j,L),undef) ) then - psi2(j,L) = 2*pi*a*cos(phi)/g * psie(j,L) - else - psi2(j,L) = undef - endif - enddo - enddo - - do L=1,lm - where( abs(psim(:,L)-undef).gt.0.1 .and. - . abs(psi2(:,L)-undef).gt.0.1 ) - psi2(:,L) = psim(:,L) - psi2(:,L) - elsewhere - psi2(:,L) = undef - endwhere - enddo - - -c Compute Eliassen-Palm Flux -c -------------------------- - do j=1,jm - phi = -pi/2 + (j-1)*dphi - f(j) = 2*MAPL_OMEGA*sin(phi) - enddo - - !------------------------- Compute du/dp -------------------------------- - - ! call compute_edge( u,p,ple,jm,lm,undef,ue ) - call map1_cubic( lm,p,u, lm+1,ple,ue, jm, Method, undef) - call compute_dqdp( ue,delp,jm,lm,undef,dudp ) - - !--------------------- Compute d(u*cos)/(a*cos*dphi) --------------------- - - do L=1,lm - do j=1,jm - phi = -pi/2 + (j-1)*dphi - if( defined(u(j,L),undef) ) then - stuff(j,L) = u(j,L)*cos(phi) - else - stuff(j,L) = undef - endif - enddo - enddo - - do L=1,lm - dudphi(1 ,L) = undef - dudphi(jm,L) = undef - do j=2,jm-1 - phi = -pi/2 + (j-1)*dphi - if( defined(stuff(j+1,L),undef) .and. - . defined(stuff(j-1,L),undef) ) then - dudphi(j,L) = ( stuff(j+1,L)-stuff(j-1,L) )/(a*cos(phi)*2*dphi) - else - dudphi(j,L) = undef - endif - enddo - enddo - - !----------------------- Compute epfy & epfz ---------------------------- - - do L=1,lm - do j=1,jm - phi = -pi/2 + (j-1)*dphi - if( defined( dudp(j,L),undef) .and. - . defined( psie(j,L),undef) .and. - . defined( upvp(j,L),undef) ) then - epfy(j,L) = a*cos(phi)*( dudp(j,L)*psie(j,L) - upvp(j,L) ) - else - epfy(j,L) = undef - endif - if( defined( dudphi(j,L),undef) .and. - . defined( psie(j,L),undef) .and. - . defined( upwp(j,L),undef) ) then - epfz(j,L) = a*cos(phi)*( (f(j)-dudphi(j,L))*psie(j,L) - upwp(j,L) ) - else - epfz(j,L) = undef - endif - enddo - enddo - - !----------------------- Compute d(epfy*cos)/(a*cos*dphi) ----------------------- - - do L=1,lm - do j=1,jm - phi = -pi/2 + (j-1)*dphi - if( defined(epfy(j,L),undef) ) then - stuff(j,L) = epfy(j,L)*cos(phi) - else - stuff(j,L) = undef - endif - enddo - enddo - - do L=1,lm - dfdphi(1 ,L) = undef - dfdphi(jm,L) = undef - do j=2,jm-1 - phi = -pi/2 + (j-1)*dphi - if( defined(stuff(j+1,L),undef) .and. - . defined(stuff(j-1,L),undef) ) then - dfdphi(j,L) = ( stuff(j+1,L)-stuff(j-1,L) )/(a*cos(phi)*2*dphi) - else - dfdphi(j,L) = undef - endif - enddo - enddo - - !------------------------- Compute d(epfz)/dp --------------------------- - - ! call compute_edge( epfz,p,ple,jm,lm,undef,epfze ) - call map1_cubic( lm,p,epfz, lm+1,ple,epfze, jm, Method, undef) - call compute_dqdp( epfze,delp,jm,lm,undef,dfdp ) - - !----------------------- Compute EPFlux Divergence ---------------------- - - do L=1,lm - do j=1,jm - if( defined( dfdp(j,L),undef) .and. - . defined( dfdphi(j,L),undef) ) then - epfdiv(j,L) = dfdphi(j,L) + dfdp(j,L) - else - epfdiv(j,L) = undef - endif - enddo - enddo - -c Invert Streamfunction for grads output (in order to be bottom=>top) -c ------------------------------------------------------------------- - - call flipz( psim ,jm,lm,1.0e-10 ,undef ) - call flipz( psi1 ,jm,lm,1.0e-10*2.4892,undef ) - call flipz( psi2 ,jm,lm,1.0e-10*2.4892,undef ) - call flipz( epfy ,jm,lm,1.0 ,undef ) - call flipz( epfz ,jm,lm,1.0 ,undef ) - call flipz( epfdiv,jm,lm,1.0 ,undef ) - - call flipz( upvp ,jm,lm,1.0 ,undef ) - call flipz( upwp ,jm,lm,1.0 ,undef ) - call flipz( dudp ,jm,lm,1.0 ,undef ) - call flipz( dudphi,jm,lm,1.0 ,undef ) - call flipz( psie ,jm,lm,1.0 ,undef ) - call flipz( dfdphi,jm,lm,1.0 ,undef ) - call flipz( dfdp ,jm,lm,1.0 ,undef ) - call flipz( p ,jm,lm,1.0 ,undef ) - call flipz( delp ,jm,lm,1.0 ,undef ) - - return - end - - subroutine flipz( q,jm,lm,scale,undef ) - implicit none - integer j,L,jm,lm - real undef,scale - logical defined - real q(jm,lm) - real z(jm,lm) - do L=1,lm - where( abs(q(:,LM-L+1)-undef).gt.0.1 ) - z(:,L) = q(:,LM-L+1)*scale - elsewhere - z(:,L) = undef - endwhere - enddo - do L=1,lm - q(:,L) = z(:,L) - enddo - - return - end - - subroutine stream ( v0,p0,jm,lm,s,undef ) - use MAPL_ConstantsMod - implicit none - integer j,k,L,jm,lm - real pi,dp,a,g,const,phi,undef - - real v(jm,lm), v0(jm,lm) - real s(jm,lm) - real p0(jm,lm), p(jm,lm) - real dum(jm) - - real ple(jm,0:lm) - real delp(jm, lm) - -c Invert VWND and P level index (in order to be top=>bottom) -c ---------------------------------------------------------- - do L=1,lm - p(:,L) = p0(:,lm-L+1) - v(:,L) = v0(:,lm-L+1) - enddo - -c Compute Edge Pressures and Thickness -c ------------------------------------ - ple(:,0) = max( 0.0, p(:,1) - 0.5*( p(:,2)-p(:,1) ) ) - do L=1,lm-1 - ple(:,L) = ( p(:,L)+ p(:,L+1) )*0.5 - enddo - ple(:,lm) = p(:,lm) + 0.5*( p(:,lm)-p(:,lm-1) ) - do L=1,lm - delp(:,L) = ple(:,L)-ple(:,L-1) - enddo - - pi = 4.*atan(1.) - dp = pi/(jm-1) - a = MAPL_RADIUS - g = MAPL_GRAV - - const = 2*pi*a/g * 1.0e-8 - - do k=1,lm - dum(:) = 0.0 - do L=1,k - do j=1,jm - phi = -pi/2+(j-1)*dp - if( abs(v(j,L)-undef).gt.0.1 ) then - dum(j) = dum(j) + v(j,L)*cos(phi)*delp(j,L) - endif - enddo - enddo - s(:,k) = dum(:)*const - enddo - -c Invert Streamfunction for grads output (in order to be bottom=>top) -c ------------------------------------------------------------------- - do k=1,lm - do j=1,jm - v(j,k) = s(j,lm-k+1) - enddo - enddo - - do k=1,lm - do j=1,jm - s(j,k) = v(j,k) - enddo - enddo - - return - end - subroutine residual ( v0,vpthp0,th0,w0,p0,jm,lm,res,vstar,wstar,wmean,weddy,undef ) - use MAPL_ConstantsMod - implicit none - integer j,k,L,jm,lm - real pi,dp,a,g,H,ps,ts,rhos,z,phi,undef - real airmw,runiv,cpd,rgas,akap - - real v0(jm,lm), v(jm,lm) - real w0(jm,lm), w(jm,lm) - real vpthp0(jm,lm), th0(jm,lm) - real vpthp (jm,lm), th (jm,lm), dthdp(jm,lm) - real stuff (jm,lm) - real res (jm,lm) - real vtlda(jm,lm) - real vstar(jm,lm) - real wstar(jm,lm), wmean(jm,lm), weddy(jm,lm) - real s (jm,lm) - real p0(jm,lm), p(jm,lm), rho0(jm,lm) - real cosp(jm), dum(jm,lm) - real ddcosp(jm,lm) - real the(jm,0:lm) - real ple(jm,0:lm) - real delp(jm, lm) - logical defined - - PARAMETER ( AIRMW = MAPL_AIRMW ) - PARAMETER ( RUNIV = MAPL_RUNIV ) - PARAMETER ( CPD = MAPL_CP ) - PARAMETER ( RGAS = RUNIV/AIRMW ) - PARAMETER ( AKAP = MAPL_KAPPA ) - -c Invert v,th,vpthp, and P level index (in order to be top=>bottom) -c ----------------------------------------------------------------- - do L=1,lm - w(:,L) = w0(:,lm-L+1) - v(:,L) = v0(:,lm-L+1) - p(:,L) = p0(:,lm-L+1) - th(:,L) = th0(:,lm-L+1) - vpthp(:,L) = vpthp0(:,lm-L+1) - enddo - - pi = 4.*atan(1.) - dp = pi/(jm-1) - a = MAPL_RADIUS - g = MAPL_GRAV - H = 7000.0 - ps = 1000.0 - ts = 240.0 - rhos = ps/(rgas*ts) - - print *, ' rhos = ', rhos - print *, '1/rhos = ',1.0/rhos - -c Compute Mean Air Density -c ------------------------ - do L=1,lm - do j=1,jm - z = -H*log(p(j,L)/ps) - rho0(j,L) = rhos*exp(-z/H) - enddo - enddo - - do j=1,jm - phi = -pi/2 + (j-1)*dp - cosp(j) = cos(phi) - enddo - -c Compute Edge Pressures and Thickness -c ------------------------------------ - the(:,0) = th(:,1) - ple(:,0) = max( 0.0, p(:,1) - 0.5*( p(:,2)-p(:,1) ) ) - do L=1,lm-1 - do j=1,jm - ple(j,L) = ( p(j,L)+ p(j,L+1) )*0.5 - the(j,L) = undef - if( defined(th(j,L ),undef) ) the(j,L) = th(j,L) - if( defined(th(j,L+1),undef) ) the(j,L) = th(j,L+1) - if( defined(th(j,L+1),undef) .and. defined(th(j,L),undef) ) the(j,L) = ( th(j,L+1)+th(j,L) )*0.5 - enddo - enddo - ple(:,lm) = p(:,lm) + 0.5*( p(:,lm)-p(:,lm-1) ) - - the(:,lm) = undef - where( abs(th(:,lm)-undef).gt.0.1 .and. abs(the(:,lm-1)-undef).gt.0.1 ) - the(:,lm) = the(:,lm-1) + ( th(:,lm)-the(:,lm-1) ) * ( ple(:,lm)-ple(:,lm-1) )/( p(:,lm)-ple(:,lm-1) ) - endwhere - - do L=1,lm - delp(:,L) = ple(:,L)-ple(:,L-1) - enddo - - -c Compute D(Theta)/DZ (with a forced minimum to prevent dthdz => 0) -c ----------------------------------------------------------------- - do L=1,lm - do j=1,jm - if( defined(the(j,L ),undef ) .and. - . defined(the(j,L-1),undef ) ) then - dthdp(j,L) = min( -0.003, ( the(j,L)-the(j,L-1) )/ delp(j,L) ) - else - dthdp(j,L) = undef - endif - enddo - enddo - -c Compute Vtlda based on D(rho*vpthp/dthdz)/DZ -c -------------------------------------------- - do L=1,lm - do j=1,jm - if( defined(dthdp(j,L),undef) .and. - . defined(vpthp(j,L),undef) .and. - . dthdp(j,L).ne.0.0 ) then - stuff(j,L) = rho0(j,L)*vpthp(j,L)/(p(j,L)*dthdp(j,L)) - else - stuff(j,L) = undef - endif - enddo - enddo - - do L=2,lm-1 - do j=1,jm - if( defined(stuff(j,L+1),undef) .and. - . defined(stuff(j,L-1),undef) ) then - vtlda(j,L) = p(j,L)/rho0(j,L) * ( stuff(j,L+1)-stuff(j,L-1) )/ ( 2*(ple(j,L)-ple(j,L-1)) ) - else - vtlda(j,L) = undef - endif - enddo - enddo - do j=1,jm - vtlda(j,1) = vtlda(j,2) - vtlda(j,lm) = vtlda(j,lm-1) - enddo - -c Compute Vstar -c ------------- - do L=1,lm - do j=1,jm - if( defined( vtlda(j,L),undef) .and. - . defined( v(j,L),undef) ) then - vstar(j,L) = v(j,L) - vtlda(j,L) - else - vstar(j,L) = undef - endif - enddo - enddo - -c Construct Residual Streamfunction from Vstar -c -------------------------------------------- - do k=1,lm - dum(:,1) = 0.0 - do L=1,k - do j=1,jm - if( defined(vstar(j,L),undef) ) then - dum(j,1) = dum(j,1) + vstar(j,L)*delp(j,L)*cosp(j)*rho0(j,L)*H/p(j,L) - endif - enddo - enddo - res(:,k) = dum(:,1) - enddo - -c Invert Streamfunction and Vstar for grads output (in order to be bottom=>top) -c ----------------------------------------------------------------------------- - do L=1,lm - do j=1,jm - dum(j,L) = res(j,LM-L+1) - enddo - enddo - do L=1,lm - do j=1,jm - res(j,L) = dum(j,L) - enddo - enddo - - do L=1,lm - do j=1,jm - dum(j,L) = vstar(j,LM-L+1) - enddo - enddo - do L=1,lm - do j=1,jm - vstar(j,L) = dum(j,L) - enddo - enddo - -c Compute D(cos*vpthp/dthdz)/Dphi -c ------------------------------- - do L=1,lm - do j=1,jm - if( defined(vpthp(j,L),undef) .and. - . defined(dthdp(j,L),undef) .and. - . dthdp(j,L).ne.0.0 ) then - stuff(j,L) = -H*cosp(j)*vpthp(j,L)/(p(j,L)*dthdp(j,L)) - else - stuff(j,L) = undef - endif - enddo - enddo - - do L=1,lm - do j=1,jm - if( j.gt.1 .and. j.lt.jm ) then - if( defined(stuff(j+1,L),undef) .and. - . defined(stuff(j-1,L),undef) ) then - ddcosp(j,L) = ( stuff(j+1,L)-stuff(j-1,L) )/(2*dp) - else - ddcosp(j,L) = undef - endif - else - ddcosp(j,L) = undef - endif - enddo - enddo - -c Compute Wstar -c ------------- - do L=1,lm - do j=1,jm - if( defined(ddcosp(j,L),undef) ) then - wmean(j,Lm-L+1) = w(j,L) - weddy(j,Lm-L+1) = ddcosp(j,L)/(a*cosp(j)) - wstar(j,Lm-L+1) = w(j,L) + ddcosp(j,L)/(a*cosp(j)) - else - wstar(j,Lm-L+1) = undef - wmean(j,Lm-L+1) = undef - weddy(j,Lm-L+1) = undef - endif - enddo - enddo - - - return - end - - subroutine make_w ( v0,p0,jm,lm,w,undef ) - use MAPL_ConstantsMod - implicit none - integer j,k,L,jm,lm - - real v0(jm,lm), v(jm,lm) - real p0(jm,lm), p(jm,lm) - real w(jm,lm), rho0(jm,lm) - real s(jm,lm), cosp(jm) - real dum(jm) - real dvcos_dphi(jm,lm) - real ple(jm,0:lm) - real delp(jm, lm) - logical defined - real airmw,runiv,cpd,rgas,akap - real pi,dp,a,g,H,ps,ts,rhos,phi,z,undef - - PARAMETER ( AIRMW = MAPL_AIRMW ) - PARAMETER ( RUNIV = MAPL_RUNIV ) - PARAMETER ( CPD = MAPL_CP ) - PARAMETER ( RGAS = RUNIV/AIRMW ) - PARAMETER ( AKAP = MAPL_KAPPA ) - -c Invert v and P level index (in order to be top=>bottom) -c ------------------------------------------------------- - do L=1,lm - v(:,L) = v0(:,lm-L+1) - p(:,L) = p0(:,lm-L+1) - enddo - - pi = 4.*atan(1.) - dp = pi/(jm-1) - a = MAPL_RADIUS - g = MAPL_GRAV - H = 7000.0 - ps = 1000.0 - ts = 240.0 - rhos = ps/(rgas*ts) - - do L=1,lm - do j=1,jm - phi = -pi/2 + (j-1)*dp - cosp(j) = cos(phi) - z = -H*log(p(j,L)/ps) - rho0(j,L) = rhos*exp(-z/H) - enddo - enddo - - do L=1,lm - do j=1,jm - if( j.gt.1 .and. j.lt.jm ) then - if( defined(v(j+1,L),undef) .and. - . defined(v(j-1,L),undef) ) then - dvcos_dphi(j,L) = ( v(j+1,L)*cosp(j+1)-v(j-1,L)*cosp(j-1) )/(2*dp) - else - dvcos_dphi(j,L) = undef - endif - else - dvcos_dphi(j,L) = undef - endif - enddo - enddo - -c Compute Edge Pressures and Thickness -c ------------------------------------ - ple(:,0) = max( 0.0, p(:,1) - 0.5*( p(:,2)-p(:,1) ) ) - do L=1,lm-1 - ple(:,L) = ( p(:,L)+ p(:,L+1) )*0.5 - enddo - ple(:,lm) = p(:,lm) + 0.5*( p(:,lm)-p(:,lm-1) ) - - do L=1,lm - delp(:,L) = ple(:,L)-ple(:,L-1) - enddo - -c Construct W from Continuity -c --------------------------- - do k=1,lm - dum(:) = 0.0 - do L=1,k - do j=1,jm - phi = -pi/2+(j-1)*dp - if( dvcos_dphi(j,L).ne.undef ) then - dum(j) = dum(j) + dvcos_dphi(j,L)*delp(j,L)*rho0(j,L)*H/(p(j,L)*a*cosp(j)) - endif - enddo - enddo - s(:,k) = dum(:)/rho0(:,k) - enddo - -c Invert Streamfunction for grads output (in order to be bottom=>top) -c ------------------------------------------------------------------- - do k=1,lm - do j=1,jm - w(j,k) = s(j,lm-k+1) - enddo - enddo - - return - end - - ! ************************************************************************************************************ - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*undef - return - end function defined - - ! ************************************************************************************************************ - - subroutine compute_edge( q,p,pe,jm,lm,undef,qe ) - implicit none - integer j,L,jm,lm - real undef - logical defined - real q(jm, lm), p(jm, lm) - real qe(jm,0:lm), pe(jm,0:lm) - - qe(:,0) = q(:,1) - do L=1,lm-1 - do j=1,jm - qe(j,L) = undef - if( defined( q(j,L ),undef) ) qe(j,L) = q(j,L) - if( defined( q(j,L+1),undef) ) qe(j,L) = q(j,L+1) - ! if( defined( q(j,L+1),undef) .and. defined( q(j,L),undef) ) qe(j,L) = ( q(j,L+1)+ q(j,L) )*0.5 - - ! Linear Interpolation to Pressure Edge - ! ------------------------------------- - if( defined( q(j,L+1),undef) .and. defined( q(j,L),undef) ) then - qe(j,L) = q(j,L) + ( q(j,L+1)-q(j,L) )*( log(pe(j,L)/p(j,L)) )/( log(p(j,L+1)/p(j,L)) ) - ! qe(j,L) = q(j,L) + ( q(j,L+1)-q(j,L) )*( pe(j,L) - p(j,L) )/( p(j,L+1)-p(j,L) ) - ! or qe(j,L) = q(j,L+1) - ( q(j,L+1)-q(j,L) )*( p(j,L+1)-pe(j,L) )/( p(j,L+1)-p(j,L) ) - endif - - enddo - enddo - qe(:,lm) = undef - where( abs( q(:,lm)-undef).gt.0.1 .and. abs( qe(:,lm-1)-undef).gt.0.1 ) - qe(:,lm) = qe(:,lm-1) + ( q(:,lm)- qe(:,lm-1) ) * ( log(pe(:,lm)/pe(:,lm-1)) )/( log(p(:,lm)/pe(:,lm-1)) ) - ! qe(:,lm) = qe(:,lm-1) + ( q(:,lm)- qe(:,lm-1) ) * ( pe(:,lm)-pe(:,lm-1) )/( p(:,lm)-pe(:,lm-1) ) - endwhere - - return - end - - ! ************************************************************************************************************ - - subroutine compute_dqdp( qe,dp,jm,lm,undef,dqdp ) - implicit none - integer j,L,jm,lm - real undef - logical defined - real dp(jm, lm) - real qe(jm,0:lm) - real dqdp(jm,lm) - - do L=1,lm - do j=1,jm - if( defined(qe(j,L-1),undef) .and. defined(qe(j,L),undef) ) then - dqdp(j,L) = ( qe(j,L)-qe(j,L-1) )/ dp(j,L) - else - dqdp(j,L) = undef - endif - enddo - enddo - - return - end - - ! ************************************************************************************************************ - - subroutine map1_cubic( km, pe1, q1, kn, pe2, q2, jm, Method, undef) - use MAPL_ConstantsMod - implicit none - - real, intent(in) :: undef - integer, intent(in) :: Method ! 0: Linear in P - ! 1: Linear in Log(P) - ! 2: Linear in P**kappa - integer, intent(in) :: jm ! Latitude dimension - integer, intent(in) :: km ! Original vertical dimension - integer, intent(in) :: kn ! Target vertical dimension - - real, intent(in) :: pe1(jm,km) ! pressure at mid-layers - ! in the original vertical coordinate - - real, intent(in) :: pe2(jm,kn) ! pressure at mid-layers - ! in the new vertical coordinate - - real, intent(in) :: q1(jm,km) ! Field input - real, intent(inout):: q2(jm,kn) ! Field output - -! !DESCRIPTION: -! -! Perform Cubic Interpolation in the vertical -! ------------------------------------------- -! pe1: pressure associated with q1 -! pe2: pressure associated with q2 -! -!----------------------------------------------------------------------- -! - real qx(jm,km) - real logpl1(jm,km) - real logpl2(jm,kn) - real dlogp1(jm,km) - real am2,am1,ap0,ap1,P,PLP1,PLP0,PLM1,PLM2,DLP0,DLM1,DLM2 - - integer j, k, LM2,LM1,LP0,LP1 - logical defined - - real airmw,runiv,cpd,rgas,akap - PARAMETER ( AIRMW = MAPL_AIRMW ) - PARAMETER ( RUNIV = MAPL_RUNIV ) - PARAMETER ( CPD = MAPL_CP ) - PARAMETER ( RGAS = RUNIV/AIRMW ) - PARAMETER ( AKAP = MAPL_KAPPA ) - -! Initialization -! -------------- - - select case (Method) - - ! Linear in P - ! ----------- - case(0) - do k=1,km - qx(:,k) = q1(:,k) - logpl1(:,k) = pe1(:,k) - enddo - do k=1,kn - logpl2(:,k) = pe2(:,k) - enddo - - do k=1,km-1 - dlogp1(:,k) = logpl1(:,k+1)-logpl1(:,k) - enddo - - ! Linear in Log(P) - ! ---------------- - case(1) - do k=1,km - qx(:,k) = q1(:,k) - logpl1(:,k) = log( pe1(:,k) ) - enddo - do k=1,kn - logpl2(:,k) = log( pe2(:,k) ) - enddo - - do k=1,km-1 - dlogp1(:,k) = logpl1(:,k+1)-logpl1(:,k) - enddo - - ! Linear in P**kappa - ! ------------------ - case(2) - do k=1,km - qx(:,k) = q1(:,k) - logpl1(:,k) = exp( akap*log( pe1(:,k) )) - enddo - do k=1,kn - logpl2(:,k) = exp( akap*log( pe2(:,k) )) - enddo - - do k=1,km-1 - dlogp1(:,k) = logpl1(:,k+1)-logpl1(:,k) - enddo - - end select - -! Interpolate Q1 onto target Pressures -! ------------------------------------ - do j=1,jm - do k=1,kn - LM1 = 1 - LP0 = 1 - do while( LP0.le.km ) - if (logpl1(j,LP0).lt.logpl2(j,k)) then - LP0 = LP0+1 - else - exit - endif - enddo - LM1 = max(LP0-1,1) - LP0 = min(LP0, km) - -! Extrapolate Linearly above first model level -! -------------------------------------------- - if( LM1.eq.1 .and. LP0.eq.1 ) then - q2(j,k) = qx(j,1) - if( defined(qx(j,2),undef) ) q2(j,k) = qx(j,2) - if( defined(qx(j,1),undef) .and. defined(qx(j,2),undef) ) then - q2(j,k) = qx(j,1) + ( qx(j,2)-qx(j,1) )*( logpl2(j,k)-logpl1(j,1) ) - . /( logpl1(j,2)-logpl1(j,1) ) - endif - -! Extrapolate Linearly below last model level -! ------------------------------------------- - else if( LM1.eq.km .and. LP0.eq.km ) then - q2(j,k) = qx(j,km) - if( defined(qx(j,km-1),undef) ) q2(j,k) = qx(j,km-1) - if( defined(qx(j,km-1),undef) .and. defined(qx(j,km),undef) ) then - q2(j,k) = qx(j,km) + ( qx(j,km)-qx(j,km-1) )*( logpl2(j,k )-logpl1(j,km ) ) - . /( logpl1(j,km)-logpl1(j,km-1) ) - endif - -! Interpolate Linearly between levels 1 => 2 and km-1 => km -! --------------------------------------------------------- - else if( LM1.eq.1 .or. LP0.eq.km ) then - q2(j,k) = qx(j,LP0) - if( defined(qx(j,LM1),undef) ) q2(j,k) = qx(j,LM1) - if( defined(qx(j,LP0),undef) .and. defined(qx(j,LM1),undef) ) then - q2(j,k) = qx(j,LP0) + ( qx(j,LM1)-qx(j,LP0) )*( logpl2(j,k )-logpl1(j,LP0) ) - . /( logpl1(j,LM1)-logpl1(j,LP0) ) - endif - -! Interpolate Cubicly between other model levels -! ---------------------------------------------- - else - LP1 = LP0+1 - LM2 = LM1-1 - P = logpl2(j,k) - PLP1 = logpl1(j,LP1) - PLP0 = logpl1(j,LP0) - PLM1 = logpl1(j,LM1) - PLM2 = logpl1(j,LM2) - DLP0 = dlogp1(j,LP0) - DLM1 = dlogp1(j,LM1) - DLM2 = dlogp1(j,LM2) - - ap1 = (P-PLP0)*(P-PLM1)*(P-PLM2)/( DLP0*(DLP0+DLM1)*(DLP0+DLM1+DLM2) ) - ap0 = (PLP1-P)*(P-PLM1)*(P-PLM2)/( DLP0* DLM1 *( DLM1+DLM2) ) - am1 = (PLP1-P)*(PLP0-P)*(P-PLM2)/( DLM1* DLM2 *(DLP0+DLM1 ) ) - am2 = (PLP1-P)*(PLP0-P)*(PLM1-P)/( DLM2*(DLM1+DLM2)*(DLP0+DLM1+DLM2) ) - - if( defined(qx(j,LP1),undef) .and. - . defined(qx(j,LP0),undef) .and. - . defined(qx(j,LM1),undef) .and. - . defined(qx(j,LM2),undef) ) then - q2(j,k) = ap1*qx(j,LP1) + ap0*qx(j,LP0) + am1*qx(j,LM1) + am2*qx(j,LM2) - - else if( defined(qx(j,LP0),undef) .and. defined(qx(j,LM1),undef) ) then - q2(j,k) = qx(j,LP0) + ( qx(j,LM1)-qx(j,LP0) )*( logpl2(j,k )-logpl1(j,LP0) ) - . /( logpl1(j,LM1)-logpl1(j,LP0) ) - - else - q2(j,k) = undef - endif - - endif - - enddo - enddo - - return - end subroutine map1_cubic diff --git a/GEOS_Util/post/binarytile.F90 b/GEOS_Util/post/binarytile.F90 deleted file mode 100644 index cdf5e420..00000000 --- a/GEOS_Util/post/binarytile.F90 +++ /dev/null @@ -1,84 +0,0 @@ -Program binarytile - - implicit none - - integer, parameter :: unitR=7 - integer, parameter :: unitW=8 - integer, parameter :: NumGlobalVars=4 - integer, parameter :: NumGridVars=3 - integer :: N - integer :: NT, NPFAF, line_size - integer :: IM - integer :: JM - integer :: N_GRIDS,pfaf_number - integer :: grid_info(2),status - real, allocatable :: AVR(:,:) - real :: DUMMY - character(len=128) :: NAME - character(len=128) :: filenameIN - character(len=128) :: filenameOUT - integer, parameter :: max_rec=2 - - call get_command_argument(1,filenameIN) - if (filenameIN == "") filenameIN = 'input' - call get_command_argument(2,filenameOUT) - if (filenameOUT == "") filenameOUT = 'output' - - open(unit=unitR, file=filenameIN, form='FORMATTED') - open(unit=unitW, file=filenameOUT,form='UNFORMATTED') - !READ (unitR, *) NT, NPFAF - !WRITE(unitW ) NT, NPFAF - -! Number of grids that can be attached -!------------------------------------- - - grid_info(2)=-1 - do n=1,max_rec - rewind(unitR) - read(unitR,*,iostat=status)grid_info(1:n) - if (status<0) exit - enddo - nt=grid_info(1) - !pfaf_number=grid_info(2) - WRITE (unitW) grid_info - -! Number of grids that can be attached -!------------------------------------- - - READ (unitR, *) N_GRIDS - WRITE(unitW ) N_GRIDS - -! The names and sizes of the grids to be tiled -!--------------------------------------------- - - do N=1,N_GRIDS - READ (unitR, *) NAME - WRITE(unitW ) NAME - READ (unitR, *) IM - WRITE(unitW ) IM - READ (unitR, *) JM - WRITE(unitW ) JM - enddo - - -! Read location stream file into AVR -!--------------------------------------- - - allocate(AVR(NT,NumGlobalVars+NumGridVars*N_GRIDS)) - - do N=1, NT - READ(unitR, *) AVR(N,1),AVR(N,10),AVR(N,2:6),DUMMY,AVR(N,7:9) - end do - - close(unitR) - - do N=1,size(AVR,2) - write(unitW) AVR(:,N) - end do - -! write(unitW) AVR(:,1:3) -! write(unitW) AVR(:,4:6) -! write(unitW) AVR(:,7:9) - close(unitW) - -end Program binarytile diff --git a/GEOS_Util/post/checkdate.F b/GEOS_Util/post/checkdate.F deleted file mode 100644 index 49797637..00000000 --- a/GEOS_Util/post/checkdate.F +++ /dev/null @@ -1,604 +0,0 @@ - program main - - implicit none - include 'alias.com' - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to check for consistency between filename **** -c **** and internal HDF datestamp **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm,nt - - integer nymd,nhms - integer im_out, jm_out - integer nymd0,nhms0,hour,day,month,year - integer nymdb,nhmsb - - -c Generic Model Variables -c ----------------------- - real, allocatable :: ps(:,:) - real, allocatable :: dp(:,:,:) - real, allocatable :: q2d(:,:,:) - real, allocatable :: q3d(:,:,:,:) - - -c HDF and other Local Variables -c ----------------------------- - logical, pointer :: Lsurf (:) - character*128, pointer :: names (:) - character*128, pointer :: name2d(:), name3d(:) - character*128, pointer :: titl2d(:), titl3d(:) - - integer id,rc,fid,nhmsf,n2d,n3d - integer nvars,ngatts,ntime,ntimes,gfrc - - real, allocatable :: plevs(:) - character*128, allocatable :: arg(:) - character*128, allocatable :: fname(:) - character*128 dummy, name - character*128 output, hdfile, ctlfile - - character*8 date,date0 - character*2 time,time0 - character*1 char - data output /'eta2prs'/ - - integer n,m,nargs,L,nbeg,nfiles,mlev - integer ny,nm,nd - - real*8 lonbeg - real undef - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - character*128 title - character*128 source - character*128 contact - character*128 levunits - character*128, allocatable :: vname(:) - character*128, allocatable :: vtitle(:) - character*128, allocatable :: vunits(:) - - integer i,j,ndt - integer imax,jmax - logical hdf, quad - logical hdfcreate - logical ctl_exists - logical edges - - character*8 cdate - - interface - subroutine read_ctl ( ctlfile,im,jm,lm,n2d,n3d,lonbeg,undef, - . nvars,names,Lsurf,name2d,titl2d,name3d,titl3d ) - logical, pointer :: Lsurf (:) - character*128, pointer :: names (:) - character*128, pointer :: name2d(:), name3d(:) - character*128, pointer :: titl2d(:), titl3d(:) - character*128 ctlfile - integer im,jm,lm,n2d,n3d,nvars - real undef - real*8 lonbeg - end subroutine read_ctl - subroutine read_hdf ( hdffile,im,jm,lm,n2d,n3d,lonbeg,undef,id, - . nymdb,nhmsb,ndt,ntimes, - . nvars,names,Lsurf,name2d,titl2d,name3d,titl3d ) - logical, pointer :: Lsurf (:) - character*128, pointer :: names (:) - character*128, pointer :: name2d(:), name3d(:) - character*128, pointer :: titl2d(:), titl3d(:) - character*128 hdffile - integer id,im,jm,lm,n2d,n3d,nvars - integer nymdb,nhmsb,ndt,ntimes - real undef - real*8 lonbeg - end subroutine read_hdf - end interface - -C ********************************************************************** -C **** Initialization **** -C ********************************************************************** - - ctlfile = 'xxx' - im_out = -999 - jm_out = -999 - nymd0 = -999 - nhms0 = -999 - nt = 1 - ndt = 0 - hdf = .true. - quad = .false. - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-im' ) read(arg(n+1),*) im_out - if( trim(arg(n)).eq.'-jm' ) read(arg(n+1),*) jm_out - if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1),*) nymd0 - if( trim(arg(n)).eq.'-nhms' ) read(arg(n+1),*) nhms0 - if( trim(arg(n)).eq.'-ndt' ) read(arg(n+1),*) ndt - if( trim(arg(n)).eq.'-hdf' ) read(arg(n+1),*) hdf - if( trim(arg(n)).eq.'-quad' ) quad = .true. - if( trim(arg(n)).eq.'-flat' ) hdf = .false. - if( trim(arg(n)).eq.'-tag' ) output = arg(n+1) - if( trim(arg(n)).eq.'-ctl' ) ctlfile = arg(n+1) - - if( trim(arg(n)).eq.'-levs' ) then - mlev = 1 - read(arg(n+mlev),fmt='(a1)') char - do while (char.ne.'-' .and. n+mlev.lt.nargs ) - mlev = mlev+1 - read(arg(n+mlev),fmt='(a1)') char - enddo - if( char.eq.'-' ) mlev = mlev-1 - allocate ( plevs(mlev) ) - do m=1,mlev - read(arg(n+m),*) plevs(m) - enddo - endif - - if( trim(arg(n)).eq.'-eta' ) then - nfiles = 1 - read(arg(n+nfiles),fmt='(a1)') char - do while (char.ne.'-' .and. n+nfiles.ne.nargs ) - nfiles = nfiles+1 - read(arg(n+nfiles),fmt='(a1)') char - enddo - if( char.eq.'-' ) nfiles = nfiles-1 - allocate ( fname(nfiles) ) - do m=1,nfiles - fname(m) = arg(n+m) - enddo - endif - enddo - endif - -C ********************************************************************** -C **** Read Grads CLT or HDF Meta Data **** -C ********************************************************************** - -! Check whether ctl file exists -! ----------------------------- - - call read_hdf ( fname(1),im,jm,lm,n2d,n3d,lonbeg,undef,id, - . nymdb,nhmsb,ndt,ntimes, - . nvars,names,Lsurf,name2d,titl2d,name3d,titl3d ) - call gfio_close ( id,rc ) - - -C ********************************************************************** -C **** Summarize Input Variables **** -C ********************************************************************** - - allocate ( ps(im,jm) ) - allocate ( dp(im,jm,lm) ) - allocate ( q2d(im,jm, n2d) ) - allocate ( q3d(im,jm,lm,n3d) ) - - if( im_out.eq.-999 ) im_out = im - if( jm_out.eq.-999 ) jm_out = jm - - if( nymd0 == -999 ) nymd0 = nymdb - if( nhms0 == -999 ) nhms0 = nhmsb - - print * - print *, ' im: ',im_out - print *, ' jm: ',jm_out - print *, ' lm: ',lm - print *, 'Beginning Date: ',nymd0 - print *, 'Beginning Time: ',nhms0 - print *, 'Time Increment: ',nhmsf(ndt),' (',ndt,' seconds)' - print * - - print *, 'Files: ' - do n=1,nfiles - print *, n,trim(fname(n)) - enddo - print * - - -C ********************************************************************** -C **** Read and Interpolate Eta File **** -C ********************************************************************** - - nymd = nymd0 - nhms = nhms0 - edges = .false. - - do n=1,nfiles - write(date0,1000) nymd - write(time0,2000) nhms/10000 - 1000 format(i8.8) - 2000 format(i2.2) - - rc = 0 - ntime = 0 - dowhile (rc.eq.0) - ntime = ntime + 1 - - call read_hdf ( fname(n),im,jm,lm,n2d,n3d,lonbeg,undef,id, - . nymdb,nhmsb,ndt,ntimes, - . nvars,names,Lsurf,name2d,titl2d,name3d,titl3d ) - call gfio_close ( id,rc ) - - - if( nymd.ne.nymdb .or. nhms.ne.nhmsb ) then - print *, 'Opening: ',trim(fname(n)) - print *, 'Checking for nymd: ',nymd,' nhms: ',nhms - print *, ' Found nymd: ',nymdb,' nhms: ',nhmsb - print * - endif - - rc = 1 - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 + 1 - ND = MOD(NYMD,100) - if( nm.gt.12 ) then - nm = 1 - ny = ny+1 - endif - - nymd = ny*10000 + nm*100 + nd - enddo - enddo - - deallocate ( dp,ps,arg ) - - stop - end - - subroutine readit (q,im,jm,lm,ku) - implicit none - integer im,jm,lm,ku,L - real q(im,jm,lm) - real*4 dum(im,jm) - do L=1,lm - read(ku) dum - q(:,:,L) = dum(:,:) - enddo - return - end subroutine readit - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*undef - return - end function defined - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end function nsecf - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end function nhmsf - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - end subroutine tick - - function incymd (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - RETURN - end function incymd - - subroutine read_hdf ( hdffile,im,jm,lm,n2d,n3d,lonbeg,undef,id, - . nymd0,nhms0,ndt,ntime, - . nvars,names,Lsurf,name2d,titl2d,name3d,titl3d ) - implicit none - - logical, pointer :: Lsurf (:) - character*128, pointer :: names (:) - character*128, pointer :: name2d(:), name3d(:) - character*128, pointer :: titl2d(:), titl3d(:) - - character*128 hdffile - integer id,im,jm,lm,n2d,n3d,nvars,nsecf - integer ntime,ngatts,rc,timinc,nymd0,nhms0,ndt - real undef - real*8 lonbeg - integer L,m,n - character*128 dummy,name - - character*128 title - character*128 source - character*128 contact - character*128 levunits - character*128, allocatable :: vname(:) - character*128, allocatable :: vtitle(:) - character*128, allocatable :: vunits(:) - - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - integer, allocatable :: loc(:) - -C ********************************************************************** -C **** Read HDF File for Meta Data **** -C ********************************************************************** - - call gfio_open ( trim(hdffile),1,id,rc ) - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( names(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - timinc = 0 - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - - nymd0 = yymmdd(1) - nhms0 = hhmmss(1) - - return - end subroutine read_hdf - - subroutine read_ctl ( ctlfile,im,jm,lm,n2d,n3d,lonbeg,undef, - . nvars,names,Lsurf,name2d,titl2d,name3d,titl3d ) - implicit none - - logical, pointer :: Lsurf (:) - character*128, pointer :: names (:) - character*128, pointer :: name2d(:), name3d(:) - character*128, pointer :: titl2d(:), titl3d(:) - - character*128 ctlfile - integer im,jm,lm,n2d,n3d,nvars - real undef - real*8 lonbeg - integer L,m,n - character*128 dummy,name - -C ********************************************************************** -C **** Read Grads CLT File for Meta Data **** -C ********************************************************************** - - open (10,file=trim(ctlfile),form='formatted') - n2d = 0 - n3d = 0 - do - read(10,*,end=500) dummy - - if( trim(dummy).eq.'xdef' ) then - backspace(10) - read(10,*) dummy,im,dummy,lonbeg - endif - - if( trim(dummy).eq.'ydef' ) then - backspace(10) - read(10,*) dummy,jm - endif - - if( trim(dummy).eq.'zdef' ) then - backspace(10) - read(10,*) dummy,lm - endif - - if( trim(dummy).eq.'undef' ) then - backspace(10) - read(10,*) dummy,undef - endif - - if( trim(dummy).eq.'vars' ) then - backspace(10) - read(10,*) dummy,nvars - allocate( names(nvars) ) - do n=1,nvars - read(10,*) names(n),L - if( L.eq.0 ) then - n2d = n2d + 1 - else - n3d = n3d + 1 - endif - enddo - endif - enddo - 500 continue - rewind(10) - - if( n2d.eq.0 .and. n3d.eq.0 ) then - print *, 'Warning, n2d = n3d = 0!' - stop - endif - - allocate( Lsurf(nvars) ) - allocate( name2d(n2d) ) - allocate( titl2d(n2d) ) - allocate( name3d(n3d) ) - allocate( titl3d(n3d) ) - - n2d = 0 - n3d = 0 - do - read(10,*,end=501) dummy - if( trim(dummy).eq.'vars' ) then - backspace(10) - read(10,*) dummy,nvars - do n=1,nvars - read(10,*) name,L - backspace(10) - if( L.eq.0 ) then - Lsurf(n) = .true. - n2d = n2d + 1 - read(10,*) name2d(n2d),L,m,titl2d(n2d) - else - Lsurf(n) = .false. - n3d = n3d + 1 - read(10,*) name3d(n3d),L,m,titl3d(n3d) - endif - enddo - endif - enddo - 501 continue - - return - end subroutine read_ctl - - subroutine usage() - print *, "Usage: " - print * - print *, " checkdate_$ARCH.x -eta eta_fname(s)" - print * - print *, "where:" - print * - print *, " -eta eta_fname(s): Filename(s) in eta HDF format" - print * - error stop 7 - end subroutine usage diff --git a/GEOS_Util/post/convert_aerosols.F b/GEOS_Util/post/convert_aerosols.F deleted file mode 100644 index 7482f9a7..00000000 --- a/GEOS_Util/post/convert_aerosols.F +++ /dev/null @@ -1,3112 +0,0 @@ - program convert_aerosols - - use m_set_eta, only: set_eta - implicit none - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to convert ETA File (Resolution or Staggering) **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm,nt - - integer nymd ,nhms - integer nymd0 ,nhms0 - integer nymdr ,nhmsr - integer nymdb ,nhmsb - integer nymdb0,nhmsb0 - - integer hour,day,month,year,timinc - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - integer, allocatable :: loc(:) - -c Generic Model Variables -c ----------------------- - real, allocatable :: ps(:,:,:) - real*4, allocatable :: pstemp(:,:) - real, allocatable :: q2d(:,:,:) - real, allocatable :: q3d(:,:,:,:) - -c HDF and other Local Variables -c ----------------------------- - real, pointer :: lon (:) - real, pointer :: lat (:) - real, pointer :: lev (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - character*256, pointer :: unit2d(:), unit3d(:) - character*256, pointer :: namesp (:) - character*256, pointer :: name2dp(:), name3dp(:) - character*256, pointer :: titl2dp(:), titl3dp(:) - character*256, pointer :: unit2dp(:), unit3dp(:) - - integer id,rc,fid,nhmsf,n2d,n3d,psid - integer n2dp,n3dp,nvarsp - integer nvars,ngatts,ntime,ntimes,gfrc - - character*256, allocatable :: arg(:) - character*256, allocatable :: fname(:) - character*256 psfile - logical psnetcdf - character*256 name - character*256 hdfile, tag - character*256 ext - character*4 xdim,ydim,zdim - - character*8 date,date0 - character*4 time0 - character*2 time,hour0,mins0 - character*1 char - - integer n,m,nargs,L,nbeg,nfiles,npfiles,mlev - - real undef,psmax,psmin - integer i,j,ndt,ks - integer imout,jmout,lmout - logical hdfcreate - logical flip - integer imps,jmps,ntimeps - real lonps,latps - - character*8 cdate - - interface - subroutine read_eta_meta ( hdffile,im,jm,lm,n2d,n3d,lat,lon,lev,undef,id, - . nymdb,nhmsb,ndt,ntimes,levunits, - . nvars,names,name2d,titl2d,unit2d,name3d,titl3d,unit3d ) - real, pointer :: lat (:) - real, pointer :: lon (:) - real, pointer :: lev (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - character*256, pointer :: unit2d(:), unit3d(:) - character*256 hdffile - character*256 levunits - integer id,im,jm,lm,n2d,n3d,nvars - integer nymdb,nhmsb,ndt,ntimes - real undef - end subroutine read_eta_meta - end interface - -C ********************************************************************** -C **** Initialization **** -C ********************************************************************** - - nt = 1 - ndt = 0 - tag = 'NULL' - psfile = 'NULL' - imout = -999 - jmout = -999 - lmout = -999 - psnetcdf = .true. - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - - if( trim(arg(n)).eq.'-im' ) read(arg(n+1),*) imout - if( trim(arg(n)).eq.'-jm' ) read(arg(n+1),*) jmout - if( trim(arg(n)).eq.'-lm' ) read(arg(n+1),*) lmout - if( trim(arg(n)).eq.'-psfile' ) psfile = trim(arg(n+1)) - if( trim(arg(n)).eq.'-tag' ) tag = trim(arg(n+1)) - - if( trim(arg(n)).eq.'-f' ) then - nfiles = 1 - read(arg(n+nfiles),fmt='(a1)') char - do while (char.ne.'-' .and. n+nfiles.ne.nargs ) - nfiles = nfiles+1 - read(arg(n+nfiles),fmt='(a1)') char - enddo - if( char.eq.'-' ) nfiles = nfiles-1 - allocate ( fname(nfiles) ) - do m=1,nfiles - fname(m) = arg(n+m) - enddo - endif - - enddo - endif - -C ********************************************************************** -C **** Summarize Input Variables **** -C ********************************************************************** - - print * - print *, 'Eta Files: ' - do n=1,nfiles - print *, n,trim(fname(n)) - enddo - print * - name = fname(1) - n = index(trim(name),'.',back=.true.) - ext = trim(name(n+1:)) - -C ********************************************************************** -C **** Read PS File **** -C ********************************************************************** - - if(psnetcdf) then - - call gfio_open ( trim(psfile),1,psid,rc ) - call gfio_diminquire ( psid,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( names(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - allocate ( ps(im,jm,ntime) ) - - call gfio_inquire ( psid,im,jm,lm,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - - do n=1,ntime - nymd = yymmdd(n) - nhms = hhmmss(n) - print *, 'reading ',trim(psfile),' for: ',nymd,nhms - call gfio_getvar ( psid,'ps',nymd,nhms,im,jm,0,1,ps(1,1,n),rc ) - if (rc.ne.0) stop "variable not found. check case" - enddo - call gfio_close ( psid,rc ) - - imps = im - jmps = jm - ntimeps = ntime - - lonps = lon(1) - latps = lat(1) - - deallocate ( lon,lat,lev,yymmdd,hhmmss,vname,names,vtitle,vunits ) - deallocate ( kmvar,vrange,prange ) - - else - -! assume we know we have 12 months of ps data and it is at imps by jmps - - imps = 576 - jmps = 361 - -! what are the beginning lon and lat -! User *MUST* set these for binary - lonps = -999 - latps = -999 - - allocate ( ps(imps,jmps,12) ) - allocate ( pstemp(imps,jmps) ) - open(33,file=psfile,access='DIRECT',convert='BIG_ENDIAN', - . recl=imps*jmps*4) - - do n=1,12 - read(33,rec=n)pstemp - ps(:,:,n)=pstemp - enddo - - endif - -C ********************************************************************** -C **** Read and Interpolate Eta File **** -C ********************************************************************** - - do n=1,nfiles - print *, 'Opening: ',trim(fname(n)) - call read_eta_meta ( fname(n),im,jm,lm,n2d,n3d,lat,lon,lev,undef,id, - . nymdb,nhmsb,ndt,ntimes,levunits, - . nvars,names,name2d,titl2d,unit2d,name3d,titl3d,unit3d ) - - flip = lev(lm) < lev(1) - - if( imout.eq.-999 ) imout = im - if( jmout.eq.-999 ) jmout = jm - if( lmout.eq.-999 ) lmout = lm - - allocate ( q2d(im,jm, n2d) ) - allocate ( q3d(im,jm,lm,n3d) ) - - print * - print *, 'Input Resolution IM: ',im - print *, 'Input Resolution JM: ',jm - print *, 'Input Resolution LM: ',lm,' Flip: ',flip - print * - print *, 'Input PS Resolution IM: ',imps - print *, 'Input PS Resolution JM: ',jmps - print * - - if (im.ne.imps) then - print *, 'ERROR: PS File Resolution IM does not match Input Resolution IM' - stop - endif - if (jm.ne.jmps) then - print *, 'ERROR: PS File Resolution JM does not match Input Resolution JM' - stop - endif - - if (lonps.eq.-999) then - print *, 'ERROR: You are using binary PS. You must set the correct first longitude value' - stop - endif - if (lon(1).ne.lonps) then - print *, ' Input First Longitude: ', lon(1) - print *, 'Input PS First Longitude: ', lonps - print *, 'WARNING: Shifting PS Longitudes to match Input' - call lonshift(ps,imps,jmps,ntimeps) - endif - - if (latps.eq.-999) then - print *, 'ERROR: You are using binary PS. You must set the correct first latitude value' - stop - endif - if (lat(1).ne.latps .and. latps.ne.-999) then - print *, ' Input First Latitude: ', lat(1) - print *, 'Input PS First Latitude: ', latps - print *, 'WARNING: Shifting PS Latitudes to match Input' - call latshift(ps,imps,jmps,ntimeps) - endif - - print * - print *, '2-D Fields:' - print *, '-----------' - do m=1,n2d - print *, trim(name2d(m)),' ',trim(unit2d(m)),' ',trim(titl2d(m)) - enddo - print * - print *, '3-D Fields:' - print *, '-----------' - do m=1,n3d - print *, trim(name3d(m)),' ',trim(unit3d(m)),' ',trim(titl3d(m)) - enddo - - nymd = nymdb - nhms = nhmsb - - print * - print *, 'Beginning Date to Read: ',nymdb - print *, 'Beginning Time to Read: ',nhmsb - print *, 'Number of Time Periods: ',ntimes,' (ndt: ',ndt,' seconds)' - print * - - write(date0,1000) nymdb - write(hour0,2000) nhmsb/10000 - write(mins0,2000) (nhmsb-(nhmsb/10000)*10000)/100 - 1000 format(i8.8) - 2000 format(i2.2) - time0 = trim(hour0)//trim(mins0) - - hdfile = trim(fname(n)) - if( trim(tag).ne.'NULL' ) then - hdfile = trim(hdfile) // "." // trim(tag) - else - write(xdim,103) imout - write(ydim,103) jmout - write(zdim,103) lmout - 103 format(i4.4) - hdfile = trim(hdfile) // "." // xdim // "x" // ydim // "x" // zdim - endif - - call gfio_open ( trim(fname(n)),1,id,rc ) - rc = 0 - ntime = 0 - hdfcreate = .true. - dowhile (rc.eq.0) - ntime = ntime + 1 - - nymdr = nymd - nhmsr = nhms - print * - - call read_eta_data ( id,q2d,q3d,n2d,n3d,name2d,name3d,undef, - . im,jm,lm,nymdr,nhmsr,rc,ntime,ntimes ) - - if( rc.eq.0 ) then - year = nymd/10000 - month = mod(nymd,10000) / 100 - day = mod(nymd,100) - call convert ( q2d,q3d,name2d,titl2d,unit2d,name3d,titl3d,unit3d,n2d,n3d,undef, - . levunits,im,jm,lm,nt,lat,lon,lev,nymd,nhms,ndt, - . fid,hdfcreate,hdfile,imout,jmout,lmout,ps(1,1,month),flip ) - call tick (nymd,nhms,ndt) - hdfcreate = .false. - else - call gfio_close ( fid,gfrc ) - print *, 'Created: ',trim(hdfile) - print * - print * - deallocate ( q2d ) - deallocate ( q3d ) - endif - enddo - call gfio_close ( id,gfrc ) - enddo - - deallocate ( arg ) - - stop - end - - subroutine read_eta_data ( id,q2d,q3d,n2d,n3d,name2d,name3d,undef, - . im,jm,lm,nymd,nhms,rc,ntime,ntimes ) - implicit none - - integer im,jm,lm,nymd,nhms,id,rc - integer n2d,n3d,ntime,ntimes - integer nundef,nvndef - real q2d(im,jm ,n2d) - real q3d(im,jm,lm,n3d) - real u(im,jm,lm) - real v(im,jm,lm) - real undef - character*256 name2d(n2d) - character*256 name3d(n3d) - integer i,j,L,n - - rc = 0 - if( ntime <= ntimes ) then - - print *, 'Reading nymd: ',nymd,' nhms: ',nhms - -c Collect Eta Data -c ---------------- - do n=1,n2d - call gfio_getvar ( id,trim(name2d(n)),nymd,nhms,im,jm,0,1,q2d(1,1,n),rc ) - if( rc.ne.0 ) then - rc = 1 ! No more time periods in file - return - endif - enddo - - nundef = 0 - nvndef = 0 - do n=1,n3d - call gfio_getvar ( id,trim(name3d(n)),nymd,nhms,im,jm,1,lm,q3d(1,1,1,n),rc ) - enddo - - else - rc = 1 ! No more time periods in file - endif - - return - end subroutine read_eta_data - - subroutine convert ( q2d,q3d,name2d,titl2d,unit2d,name3d,titl3d,unit3d,n2d,n3d,undef, - . levunits,im,jm,lm,nt,lat,lon,lev,nymd,nhms,ninc, - . id,create,filename,imo,jmo,lmo,ps,flip ) - use m_set_eta, only: set_eta - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,nt,nymd,nhms,ninc,n2d,n3d - integer nymd0,nhms0 - - real ps(im,jm) - real q2d(im,jm, n2d) - real q3d(im,jm,lm,n3d) - - integer imo,jmo,lmo - real z2d(imo,jmo, n2d) - real z3d(imo,jmo,lm,n3d) - - real pso(imo,jmo) - real dum3d(imo,jmo,lmo) - real dum2d(imo,jmo) - - character*256 name2d(n2d), titl2d(n2d), unit2d(n2d) - character*256 name3d(n3d), titl3d(n3d), unit3d(n3d) - character*256 filename - character*256 topo - character*256 levunits - character*256 psname - character*256 dpname - character*256 uname - character*256 vname - character*256 tname - character*256 qname - character*256 ozname - character*256 phisname - - real lat(jm) ,lon (im) ,lev (lm) - real lats(jmo),lons(imo),levs(lmo) - logical create - logical flip - logical nativelevs - -c Local Variables -c --------------- - integer i,j,k,L,n,m,ks - integer nu,nv - - real undef, pi,dx,dy - real*8 ptop,pint - integer precision,id,timeinc,rc,nhmsf - - character*256 title - character*256 source - character*256 contact - - integer nvars - - character*256, allocatable :: vnames(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - integer, allocatable :: lmvar(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - - real, allocatable :: ple(:,:,:) - real, allocatable :: logpl(:,:,:) - real, allocatable :: logplo(:,:,:) - real*8, allocatable :: ak(:) - real*8, allocatable :: bk(:) - real, allocatable :: levsout(:) - - real dpref - dpref(L) = ( ak(L+1)-ak(L) ) + ( bk(L+1)-bk(L) ) * 98400.0 - -C ********************************************************************** -C **** Initialize Constants And Local Arrays **** -C ********************************************************************** - - nativelevs = .true. - pi = 4.*atan(1.) - dx = 360./ imo - dy = 180./(jmo-1) - if( im.ne.imo .or. jm.ne.jmo ) then - do j=1,jmo - lats(j) = lat(1) + (j-1)*dy - enddo - do i=1,imo - lons(i) = lon(1) + (i-1)*dx - enddo - else - lats = lat - lons = lon - endif - - nvars = n2d + n3d - -C ********************************************************************** -C **** Interpolate A-Grid Horizontal Fields **** -C ********************************************************************** - - if( im.ne.imo .or. jm.ne.jmo ) then - write(6,100) imo,jmo - 100 format(1x,'Interpolating to Horizontal Resolution (',i4,' x ',i4,') ...') - call hinterp ( ps,im,jm,pso,imo,jmo,1,undef,1,3,.false. ) - do n=1,n2d - call hinterp ( q2d(1,1,n),im,jm,z2d(1,1,n),imo,jmo,1,undef,1,3,.false. ) - enddo - do n=1,n3d - call hinterp ( q3d(1,1,1,n),im,jm,z3d(1,1,1,n),imo,jmo,lm,undef,1,3,.false. ) - enddo - else - pso=ps - z2d=q2d - z3d=q3d - endif - -C ********************************************************************** -C **** Interpolate to New Output Levels **** -C ********************************************************************** - - allocate( ak(lmo+1) ) - allocate( bk(lmo+1) ) - call set_eta ( lmo,ks,ptop,pint,ak,bk ) - - ptop = ak(1) - levs(1) = ptop + 0.5 * dpref(1) - do L = 2, lmo - levs(L) = levs(L-1) + 0.5 * ( dpref(L-1) + dpref(L) ) - enddo - - if( flip ) then - levs(1:lmo) = levs(lmo:1:-1) / 100.0 - else - levs(1:lmo) = levs(1:lmo) / 100.0 - endif - - deallocate( ak,bk ) - -C ********************************************************************** -C **** Initialize GFIO File **** -C ********************************************************************** - - allocate ( vnames(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - - timeinc = nhmsf(ninc) - precision = 1 ! 64-bit - precision = 0 ! 32-bit - - title = 'GEOS-5 GCM' - source = 'Goddard Modeling and Assimilation Office, NASA/GSFC' - contact = 'data@gmao.gsfc.nasa.gov' - -c Defined Fields -c -------------- - do m=1,n2d - n = m - vnames(n) = name2d(m) - vtitle(n) = trim(titl2d(m)) - vunits(n) = trim(unit2d(m)) - lmvar(n) = 0 - enddo - - do m=1,n3d - n = n2d+m - vnames(n) = name3d(m) - vtitle(n) = trim(titl3d(m)) - vunits(n) = trim(unit3d(m)) - lmvar(n) = lmo - enddo - -C ********************************************************************** -C **** Value Added Products **** -C ********************************************************************** - - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - vrange(:,:) = undef - prange(:,:) = undef - - allocate( levsout(lmo) ) - if(nativelevs) then - do L=1,lmo - levsout(L) = L ! New Format for Emmision Files (ETA-Indexed) - enddo - else - do L=1,lmo - levsout(L) = levs(L) ! Old Format for Emmision Files (PRS-Indexed) - enddo - endif - - if (create) then - call GFIO_Create ( trim(filename), title, source, contact, undef, - . imo, jmo, lmo, lons, lats, levsout, levunits, - . nymd, nhms, timeinc, - . nvars, vnames, vtitle, vunits, lmvar, - . vrange, prange, precision, - . id, rc ) - endif - -C ********************************************************************** -C **** Write Defined Fields **** -C ********************************************************************** - - do n=1,n2d - dum2d = z2d(:,:,n) - call writit( dum2d, imo,jmo,1 ,id,name2d(n),nymd,nhms,undef ) - enddo - do n=1,n3d - call gmap ( imo,jmo,1, pso, lm, z3d(1,1,1,n), lmo, dum3d, flip ) - - call writit( dum3d,imo,jmo,lmo,id,name3d(n),nymd,nhms,undef ) - enddo - -C ********************************************************************** -C **** De-Allocate Dynamics Arrays **** -C ********************************************************************** - - deallocate ( vnames ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( lmvar ) - deallocate ( vrange ) - deallocate ( prange ) - return - end subroutine convert - - subroutine read_eta_meta ( hdffile,im,jm,lm,n2d,n3d,lat,lon,lev,undef,id, - . nymdb,nhmsb,ndt,ntime,levunits, - . nvars,names,name2d,titl2d,unit2d,name3d,titl3d,unit3d ) - implicit none - - real, pointer :: lat (:) - real, pointer :: lon (:) - real, pointer :: lev (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - character*256, pointer :: unit2d(:), unit3d(:) - - character*256 hdffile - integer id,im,jm,lm,n2d,n3d,nvars,nsecf,timeId,ncvid - integer ntime,ngatts,rc,timinc,nymdb,nhmsb,ndt - real undef - integer i,j,L,m,n - character*256 name - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - integer, allocatable :: loc(:) - -C ********************************************************************** -C **** Read HDF File for Meta Data **** -C ********************************************************************** - - call gfio_open ( trim(hdffile),1,id,rc ) - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( names(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - timinc = 0 - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - - if( timinc .eq. 0 ) then - timeId = ncvid (id, 'time', rc) - call ncagt (id, timeId, 'time_increment', timinc, rc) - if( timinc .eq. 0 ) then - print * - print *, 'Warning, GFIO Inquire states TIMINC = ',timinc - print *, ' This will be reset to 060000 ' - print *, ' Use -ndt NNNNNN (in seconds) to overide this' - timinc = 060000 - endif - endif - - if( ndt.eq.0 ) ndt = nsecf (timinc) - - nymdb = yymmdd(1) - nhmsb = hhmmss(1) - - if( nhmsb.lt.0 ) then - n = nsecf(abs(nhmsb)) - nhmsb = 0 - call tick (nymdb,nhmsb,-n) - endif - - names = vname - - n2d = 0 - n3d = 0 - do n=1,nvars - if( kmvar(n).eq.0 ) then - n2d = n2d + 1 - else - n3d = n3d + 1 - endif - enddo - - allocate( name2d(n2d) ) - allocate( titl2d(n2d) ) - allocate( unit2d(n2d) ) - allocate( name3d(n3d) ) - allocate( titl3d(n3d) ) - allocate( unit3d(n3d) ) - - n2d = 0 - n3d = 0 - do n=1,nvars - if( kmvar(n).eq.0 ) then - n2d = n2d + 1 - name2d(n2d) = vname (n) - titl2d(n2d) = vtitle(n) - unit2d(n2d) = vunits(n) - else - n3d = n3d + 1 - name3d(n3d) = vname (n) - titl3d(n3d) = vtitle(n) - unit3d(n3d) = vunits(n) - endif - enddo - - call gfio_close ( id,rc ) - return - end subroutine read_eta_meta - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*undef - return - end function defined - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end function nsecf - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end function nhmsf - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - end subroutine tick - - function incymd (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - RETURN - end function incymd - - subroutine writit (q,im,jm,lm,id,name,nymd,nhms,undef) - integer im,jm,lm,L - integer id,nymd,nhms,rc,lbeg - character*256 name - real q (im,jm,lm) - real undef - lbeg = 1 - if( lm.eq.1 ) lbeg = 0 - write(6,100) trim(name) - 100 format(1x,' Writing variable: ',a) - call Gfio_putVar ( id,trim(name),nymd,nhms,im,jm,lbeg,lm,q,rc ) - return - end subroutine writit - - subroutine usage() - write(6,100) - 100 format( "Usage: " ,/ - . ,/ - . " convert_eta.x -f fname(s)" ,/ - . " [-im imout]" ,/ - . " [-jm jmout]" ,/ - . " [-lm lmout]" ,/ - . " [-grid conversion]" ,/ - . " [-topo topo_fname]" ,/ - . " [-tag output_tag] " ,/ - . ,/ - . "where:" ,/ - . ,/ - . " -f fname(s): Filename(s) in HDF format" ,/ - . ,/ - . "Optional Args:" ,/ - . ,/ - . " -im imout: Optional Output Resolution in X (default: Input Resolution)" ,/ - . " -jm jmout: Optional Output Resolution in Y (default: Input Resolution)" ,/ - . " -lm lmout: Optional Output Resolution in Z (default: Input Resolution)" ,/ - . " -grid conversion: Optional Grid Conversion (dtoa or atod)" ,/ - . " -topo topo_fname: Optional Filename for Output Topography File" ,/ - . " -tag output_tag: Optional Filename Tag for output: fname(s).tag (default: grid.IMxJM)" ,/ - . ,/ - . ) - error stop 7 - end subroutine usage - - subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef,msgn,norder,check ) - implicit none - integer iin,jin, iout,jout, mlev,msgn,norder - real qin(iin,jin,mlev), qout(iout,jout,mlev) - real undef,pi,dlin,dpin,dlout,dpout - real dlam(iin), lons(iout*jout), lon - real dphi(jin), lats(iout*jout), lat - integer i,j,loc - logical check - - pi = 4.0*atan(1.0) - dlin = 2*pi/iin - dpin = pi/(jin-1) - dlam(:) = dlin - dphi(:) = dpin - - dlout = 2*pi/iout - dpout = pi/(jout-1) - - loc = 0 - do j=1,jout - do i=1,iout - loc = loc + 1 - lon = -pi + (i-1)*dlout - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jout - lat = -pi/2.0 + (j-1)*dpout - do i=1,iout - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call interp_h ( qin,iin,jin,mlev,dlam,dphi, - . qout,iout*jout,lons,lats,undef ) - - return - end - - subroutine interp_h ( q_cmp,im,jm,lm,dlam,dphi, - . q_geo,irun,lon_geo,lat_geo,undef ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - -c Local Variables -c --------------- - integer i,j,l,m,n - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - - integer ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1 - integer ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2 - integer jm2_for_jm2, jp1_for_jp1 - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real ux, ap1, ap0, am1, am2 - real uy, bp1, bp0, bm1, bm2 - - real, allocatable :: lon_cmp(:) - real, allocatable :: lat_cmp(:) - real, allocatable :: q_tmp(:) - - real pi,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp,phi_np,lam_0 - real lam_geo, lam_cmp - real phi_geo, phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - - allocate ( lon_cmp(im) ) - allocate ( lat_cmp(jm) ) - allocate ( q_tmp(irun) ) - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - do i=1,irun - lam_cmp = lon_geo(i) - phi_cmp = lat_geo(i) - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm2 = lat_cmp(jm2(i)) - phi_jm1 = lat_cmp(jm1(i)) - phi_jp0 = lat_cmp(jp0(i)) - phi_jp1 = lat_cmp(jp1(i)) - - if( jm2(i).eq.0 ) phi_jm2 = phi_jm1 - dphi(1) - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - endif - if( jp1(i).eq.jm+1 ) phi_jp1 = phi_jp0 + dphi(jm-1) - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - -c Interpolate Computational-Grid Quantities to Geophysical Grid -c ------------------------------------------------------------- - do L=1,lm - do i=1,irun - - if( lat_geo(i).le.lat_cmp(2) .or. - . lat_geo(i).ge.lat_cmp(jm-1) ) then - -c 1st Order Interpolation at Poles -c -------------------------------- - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - else - -c Cubic Interpolation away from Poles -c ----------------------------------- - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jp1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp1(i),L ).ne.undef .and. - . q_cmp( im2(i),jp1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm2(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm2(i),L ).ne.undef .and. - . q_cmp( im1(i),jm2(i),L ).ne.undef .and. - . q_cmp( im2(i),jm2(i),L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) - . + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) - . + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) - . + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) - . + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) - . + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) - . + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - deallocate ( lon_cmp ) - deallocate ( lat_cmp ) - deallocate ( q_tmp ) - return - end - subroutine atod_winds ( ua,va,ud,vd,im,jm,lm ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded winds **** -C **** to 'D' gridded winds **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C ****************************************************************** - - real ua(im,jm,lm), ud(im,jm,lm) - real va(im,jm,lm), vd(im,jm,lm) - - call atod ( ua,ud,im,jm,lm,2 ) - call atod ( va,vd,im,jm,lm,1 ) - - return - end - - subroutine dtoa_winds ( ud,vd,ua,va,im,jm,lm ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded winds **** -C **** to 'A' gridded winds **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C ****************************************************************** - - real ua(im,jm,lm), ud(im,jm,lm) - real va(im,jm,lm), vd(im,jm,lm) - - real sinx(im/2) - real cosx(im/2) - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - do i=1,imh - sinx(i) = sin( -pi + (i-1)*dx ) - cosx(i) = cos( -pi + (i-1)*dx ) - enddo - -C ********************************************************* -C **** Average D-Grid Winds **** -C ********************************************************* - - call dtoa ( ud,ua,im,jm,lm,2 ) - call dtoa ( vd,va,im,jm,lm,1 ) - -C ********************************************************* -C **** Fix A-Grid Pole Winds **** -C ********************************************************* - - do L=1,lm - - do m=1,2 - n = (-1)**m - jpole = 1 + (m-1)*(jm-1) - jstar = 2 + (m-1)*(jm-3) - - upole = 0.0 - vpole = 0.0 - do i=1,imh - upole = upole + ( ua(i+imh,jstar,L)-ua(i,jstar,L) )*sinx(i) - . + n*( va(i+imh,jstar,L)-va(i,jstar,L) )*cosx(i) - vpole = vpole - n*( ua(i+imh,jstar,L)-ua(i,jstar,L) )*cosx(i) - . + ( va(i+imh,jstar,L)-va(i,jstar,L) )*sinx(i) - enddo - upole = upole / im - vpole = vpole / im - do i=1,imh - ua(i ,jpole,L) = - upole*sinx(i) + n*vpole*cosx(i) - va(i ,jpole,L) = - n*upole*cosx(i) - vpole*sinx(i) - ua(i+imh,jpole,L) = - ua(i,jpole,L) - va(i+imh,jpole,L) = - va(i,jpole,L) - enddo - enddo - - enddo - - return - end - - subroutine atod ( qa,qd,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded data **** -C **** to 'D' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted left (westward), **** -C **** u is shifted down (southward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real,allocatable :: qax(:,:) - real,allocatable :: cx(:,:) - real,allocatable :: qay(:,:) - real,allocatable :: cy(:,:) - - real,allocatable :: sinx(:) - real,allocatable :: cosx(:) - real,allocatable :: siny(:) - real,allocatable :: cosy(:) - real,allocatable :: trigx(:) - real,allocatable :: trigy(:) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - - allocate( qax ( im+2 ,lm) ) - allocate( cx (2*(im+2),lm) ) - allocate( qay ( 2*jm ,lm) ) - allocate( cy (2*(2*jm),lm) ) - - allocate( cosx(im/2) ) - allocate( sinx(im/2) ) - allocate( cosy(jm) ) - allocate( siny(jm) ) - allocate( trigx(3*(im+1)) ) - allocate( trigy(3*(2*jm)) ) - -C ********************************************************* -C **** shift left (-dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qa(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) + qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) - qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qd(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift down (-dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qa(i,j+1,L) - qay(j+jmm1,L) = -qa(i+imh,jm-j,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) + qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) - qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qd(i,j+1,L) = qay(j,L) - qd(i+imh,jm-j+1,L) = -qay(j+jmm1,L) - enddo - enddo - enddo - - endif - - deallocate( qax ) - deallocate( cx ) - deallocate( qay ) - deallocate( cy ) - - deallocate( cosx ) - deallocate( sinx ) - deallocate( cosy ) - deallocate( siny ) - deallocate( trigx ) - deallocate( trigy ) - - return - end - - subroutine dtoa ( qd,qa,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real,allocatable :: qax(:,:) - real,allocatable :: cx(:,:) - real,allocatable :: qay(:,:) - real,allocatable :: cy(:,:) - - real,allocatable :: sinx(:) - real,allocatable :: cosx(:) - real,allocatable :: siny(:) - real,allocatable :: cosy(:) - real,allocatable :: trigx(:) - real,allocatable :: trigy(:) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - - allocate( qax ( im+2 ,lm) ) - allocate( cx (2*(im+2),lm) ) - allocate( qay ( 2*jm ,lm) ) - allocate( cy (2*(2*jm),lm) ) - - allocate( cosx(im/2) ) - allocate( sinx(im/2) ) - allocate( cosy(jm) ) - allocate( siny(jm) ) - allocate( trigx(3*(im+1)) ) - allocate( trigy(3*(2*jm)) ) - -C ********************************************************* -C **** shift right (dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qd(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) - qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) + qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qa(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift up (dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qd(i,j+1,L) - qay(j+jmm1,L) = -qd(i+imh,jm-j+1,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) - qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) + qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qa(i,j+1,L) = qay(j,L) - qa(i+imh,jm-j,L) = -qay(j+jmm1,L) - enddo - enddo - - enddo - - do L=1,lm - do i=1,imh - qa(i+imh,jm,L) = -qa(i,jm,L) - qa(i,1,L) = -qa(i+imh,1,L) - enddo - enddo - endif - - deallocate( qax ) - deallocate( cx ) - deallocate( qay ) - deallocate( cy ) - - deallocate( cosx ) - deallocate( sinx ) - deallocate( cosy ) - deallocate( siny ) - deallocate( trigx ) - deallocate( trigy ) - - return - end - - subroutine rfftmlt (a,work,trigs,ifax,inc,jump,n,lot,isign) - integer INC, JUMP, N, LOT, ISIGN - real(kind=KIND(1.0)) A(N),WORK(N),TRIGS(N) - integer IFAX(*) -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR -! CALL Q8QST4 ( 4HXLIB, 6HFFT99F, 6HFFT991, 10HVERSION 01) -!FPP$ NOVECTOR R - integer NFAX, NH, NX, INK - integer I, J, IBASE, JBASE, L, IGO, IA, LA, K, M, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, - * INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, - * 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 -!DIR$ IVDEP - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END - - subroutine fftfax (n,ifax,trigs) - integer IFAX(13) - integer N - REAL(kind=KIND(1.0)) TRIGS(*) -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - integer I, MODE - DATA MODE /3/ -!FPP$ NOVECTOR R - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) WRITE(6,FMT="(//5X, ' FFTFAX -- INVALID N =', I5,/)") N - IF (IFAX(1) .LE. 0 ) STOP 999 - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END - - subroutine fft99a (a,work,trigs,inc,jump,n,lot) - integer inc, jump, N, lot - real(kind=KIND(1.0)) A(N),WORK(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 -! (SPECTRAL TO GRIDPOINT TRANSFORM) -! -!FPP$ NOVECTOR R - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) C, S - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - IA=1 - IB=N*INC+1 - JA=1 - JB=2 -!DIR$ IVDEP - DO 10 L=1,LOT - WORK(JA)=A(IA)+A(IB) - WORK(JB)=A(IA)-A(IB) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 10 CONTINUE -! -! REMAINING WAVENUMBERS - IABASE=2*INC+1 - IBBASE=(N-2)*INC+1 - JABASE=3 - JBBASE=N-1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - WORK(JA)=(A(IA)+A(IB))- - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JB)=(A(IA)+A(IB))+ - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+ - * (A(IA+INC)-A(IB+INC)) - WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))- - * (A(IA+INC)-A(IB+INC)) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 20 CONTINUE - IABASE=IABASE+INK - IBBASE=IBBASE-INK - JABASE=JABASE+2 - JBBASE=JBBASE-2 - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE -!DIR$ IVDEP - DO 40 L=1,LOT - WORK(JA)=2.0*A(IA) - WORK(JA+1)=-2.0*A(IA+INC) - IA=IA+JUMP - JA=JA+NX - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fft99b (work,a,trigs,inc,jump,n,lot) - integer INC, JUMP, N, LOT - real(kind=KIND(1.0)) WORK(N),A(N) - REAL(kind=KIND(1.0)) TRIGS(N) - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) SCALE - real(kind=KIND(1.0)) C, S -! -! SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 -! (GRIDPOINT TO SPECTRAL TRANSFORM) -! -!FPP$ NOVECTOR R - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - SCALE=1.0/FLOAT(N) - IA=1 - IB=2 - JA=1 - JB=N*INC+1 -!DIR$ IVDEP - DO 10 L=1,LOT - A(JA)=SCALE*(WORK(IA)+WORK(IB)) - A(JB)=SCALE*(WORK(IA)-WORK(IB)) - A(JA+INC)=0.0 - A(JB+INC)=0.0 - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 10 CONTINUE -! -! REMAINING WAVENUMBERS - SCALE=0.5*SCALE - IABASE=3 - IBBASE=N-1 - JABASE=2*INC+1 - JBBASE=(N-2)*INC+1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - A(JA)=SCALE*((WORK(IA)+WORK(IB)) - * +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JB)=SCALE*((WORK(IA)+WORK(IB)) - * -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * +(WORK(IB+1)-WORK(IA+1))) - A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * -(WORK(IB+1)-WORK(IA+1))) - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 20 CONTINUE - IABASE=IABASE+2 - IBBASE=IBBASE-2 - JABASE=JABASE+INK - JBBASE=JBBASE-INK - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - SCALE=2.0*SCALE -!DIR$ IVDEP - DO 40 L=1,LOT - A(JA)=SCALE*WORK(IA) - A(JA+INC)=-SCALE*WORK(IA+1) - IA=IA+NX - JA=JA+JUMP - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fax (ifax,n,mode) - integer IFAX(10) - integer N, MODE -!FPP$ NOVECTOR R - integer NN, K, L, INC, II, ISTOP, ITEM, NFAX, I - NN=N - IF (IABS(MODE).EQ.1) GO TO 10 - IF (IABS(MODE).EQ.8) GO TO 10 - NN=N/2 - IF ((NN+NN).EQ.N) GO TO 10 - IFAX(1)=-99 - RETURN - 10 K=1 -! TEST FOR FACTORS OF 4 - 20 IF (MOD(NN,4).NE.0) GO TO 30 - K=K+1 - IFAX(K)=4 - NN=NN/4 - IF (NN.EQ.1) GO TO 80 - GO TO 20 -! TEST FOR EXTRA FACTOR OF 2 - 30 IF (MOD(NN,2).NE.0) GO TO 40 - K=K+1 - IFAX(K)=2 - NN=NN/2 - IF (NN.EQ.1) GO TO 80 -! TEST FOR FACTORS OF 3 - 40 IF (MOD(NN,3).NE.0) GO TO 50 - K=K+1 - IFAX(K)=3 - NN=NN/3 - IF (NN.EQ.1) GO TO 80 - GO TO 40 -! NOW FIND REMAINING FACTORS - 50 L=5 - INC=2 -! INC ALTERNATELY TAKES ON VALUES 2 AND 4 - 60 IF (MOD(NN,L).NE.0) GO TO 70 - K=K+1 - IFAX(K)=L - NN=NN/L - IF (NN.EQ.1) GO TO 80 - GO TO 60 - 70 L=L+INC - INC=6-INC - GO TO 60 - 80 IFAX(1)=K-1 -! IFAX(1) CONTAINS NUMBER OF FACTORS - NFAX=IFAX(1) -! SORT FACTORS INTO ASCENDING ORDER - IF (NFAX.EQ.1) GO TO 110 - DO 100 II=2,NFAX - ISTOP=NFAX+2-II - DO 90 I=2,ISTOP - IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 - ITEM=IFAX(I) - IFAX(I)=IFAX(I+1) - IFAX(I+1)=ITEM - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN - END - - subroutine fftrig (trigs,n,mode) - REAL(kind=KIND(1.0)) TRIGS(*) - integer N, MODE -!FPP$ NOVECTOR R - real(kind=KIND(1.0)) PI - integer IMODE, NN, L, I, NH, LA - real(kind=KIND(1.0)) DEL, ANGLE - PI=2.0*ASIN(1.0) - IMODE=IABS(MODE) - NN=N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 - DEL=(PI+PI)/FLOAT(NN) - L=NN+NN - DO 10 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(I)=COS(ANGLE) - TRIGS(I+1)=SIN(ANGLE) - 10 CONTINUE - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - DEL=0.5*DEL - NH=(NN+1)/2 - L=NH+NH - LA=NN+NN - DO 20 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(LA+I)=COS(ANGLE) - TRIGS(LA+I+1)=SIN(ANGLE) - 20 CONTINUE - IF (IMODE.LE.3) RETURN - DEL=0.5*DEL - LA=LA+NN - IF (MODE.EQ.5) GO TO 40 - DO 30 I=2,NN - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=2.0*SIN(ANGLE) - 30 CONTINUE - RETURN - 40 CONTINUE - DEL=0.5*DEL - DO 50 I=2,N - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=SIN(ANGLE) - 50 CONTINUE - RETURN - END - - subroutine vpassm (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la) - integer INC1,INC2,INC3,INC4,LOT,N,IFAC,LA - real(kind=KIND(1.0)) A(N),B(N),C(N),D(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA" -! PERFORMS ONE PASS THROUGH DATA -! AS PART OF MULTIPLE COMPLEX FFT ROUTINE -! A IS FIRST REAL INPUT VECTOR -! B IS FIRST IMAGINARY INPUT VECTOR -! C IS FIRST REAL OUTPUT VECTOR -! D IS FIRST IMAGINARY OUTPUT VECTOR -! TRIGS IS PRECALCULATED TABLE OF SINES & COSINES -! INC1 IS ADDRESSING INCREMENT FOR A AND B -! INC2 IS ADDRESSING INCREMENT FOR C AND D -! INC3 IS ADDRESSING INCREMENT BETWEEN As & Bs -! INC4 IS ADDRESSING INCREMENT BETWEEN Cs & Ds -! LOT IS THE NUMBER OF VECTORS -! N IS LENGTH OF VECTORS -! IFAC IS CURRENT FACTOR OF N -! LA IS PRODUCT OF PREVIOUS FACTORS -! - real(kind=KIND(1.0)) SIN36, COS36, SIN72, COS72, SIN60 - DATA SIN36/0.587785252292473/,COS36/0.809016994374947/, - * SIN72/0.951056516295154/,COS72/0.309016994374947/, - * SIN60/0.866025403784437/ - integer M, IINK, JINK, JUMP, IBASE, JBASE, IGO, IA, JA, IB, JB - integer IC, JC, ID, JD, IE, JE - integer I, J, K, L, IJK, LA1, KB, KC, KD, KE - real(kind=KIND(1.0)) C1, S1, C2, S2, C3, S3, C4, S4 -! -!FPP$ NOVECTOR R - M=N/IFAC - IINK=M*INC1 - JINK=LA*INC2 - JUMP=(IFAC-1)*JINK - IBASE=0 - JBASE=0 - IGO=IFAC-1 - IF (IGO.GT.4) RETURN - GO TO (10,50,90,130),IGO -! -! CODING FOR FACTOR 2 -! - 10 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - DO 20 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 15 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=A(IA+I)-A(IB+I) - D(JB+J)=B(IA+I)-B(IB+I) - I=I+INC3 - J=J+INC4 - 15 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 20 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 40 K=LA1,M,LA - KB=K+K-2 - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - DO 30 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 25 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) - D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) - I=I+INC3 - J=J+INC4 - 25 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 30 CONTINUE - JBASE=JBASE+JUMP - 40 CONTINUE - RETURN -! -! CODING FOR FACTOR 3 -! - 50 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - DO 60 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 55 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))) - C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))) - D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))) - D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))) - I=I+INC3 - J=J+INC4 - 55 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 60 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 80 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - DO 70 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 65 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)= - * C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - D(JB+J)= - * S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - C(JC+J)= - * C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - D(JC+J)= - * S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - I=I+INC3 - J=J+INC4 - 65 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 70 CONTINUE - JBASE=JBASE+JUMP - 80 CONTINUE - RETURN -! -! CODING FOR FACTOR 4 -! - 90 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - DO 100 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 95 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) - C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) - C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) - D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) - D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) - I=I+INC3 - J=J+INC4 - 95 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 100 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 120 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - DO 110 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 105 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - C(JC+J)= - * C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - D(JC+J)= - * S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - C(JB+J)= - * C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - D(JB+J)= - * S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - C(JD+J)= - * C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - D(JD+J)= - * S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 105 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 110 CONTINUE - JBASE=JBASE+JUMP - 120 CONTINUE - RETURN -! -! CODING FOR FACTOR 5 -! - 130 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - IE=ID+IINK - JE=JD+JINK - DO 140 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 135 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 135 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 140 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 160 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - KE=KD+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - C4=TRIGS(KE+1) - S4=TRIGS(KE+2) - DO 150 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 145 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)= - * C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JB+J)= - * S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JE+J)= - * C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JE+J)= - * S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JC+J)= - * C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JC+J)= - * S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - C(JD+J)= - * C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JD+J)= - * S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - I=I+INC3 - J=J+INC4 - 145 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 150 CONTINUE - JBASE=JBASE+JUMP - 160 CONTINUE - RETURN - END - -c****6***0*********0*********0*********0*********0*********0**********72 - subroutine gmap ( im,jm,nq, ps, km, q_m, kn, q_n, flip ) -c****6***0*********0*********0*********0*********0*********0**********72 - - use m_set_eta, only: set_eta - implicit none - - integer im, jm - integer km, kn, nq - logical flip - -c Input: original data km-level -c ----------------------------- - real q_m(im,jm,km,nq) - real ps(im,jm) - -c Output: New data (kn-level) -c --------------------------- - real q_n(im,jm,kn,nq) - -c local (private) -c --------------- - integer i, j, k, ic, n, ks - - real ak_m(km+1), bk_m(km+1) - real ak_n(kn+1), bk_n(kn+1) - - real pe1(im,km+1),pe2(im,kn+1) - real dp1(im,km) ,dp2(im,kn) - real q1(im,km) , q2(im,kn) - real dum - - call set_eta ( km,ks,dum,dum,ak_m,bk_m ) - call set_eta ( kn,ks,dum,dum,ak_n,bk_n ) - - do 2000 j=1,jm - -c Copy original data to local 2D arrays. - - do k=1,km+1 - do i=1,im - pe1(i,k) = ak_m(k) + ps(i,j)*bk_m(k) - enddo - enddo - - do k=1,kn+1 - do i=1,im - pe2(i,k) = ak_n(k) + ps(i,j)*bk_n(k) - enddo - enddo - - do k=1,km - do i=1,im - dp1(i,k) = pe1(i,k+1)-pe1(i,k) - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pe2(i,k+1)-pe2(i,k) - enddo - enddo - -c map q -c ------- - do n=1,nq - do k=1,km - do i=1,im - if( flip ) then - q1(i,km-k+1) = q_m(i,j,k,n) - else - q1(i,k) = q_m(i,j,k,n) - endif - enddo - enddo - call mappm ( km, pe1, dp1, q1, kn, pe2, dp2, q2, im, 0, 7 ) - do k=1,kn - do i=1,im - if( flip ) then - q_n(i,j,k,n) = q2(i,kn-k+1) - else - q_n(i,j,k,n) = q2(i,k) - endif - enddo - enddo - enddo - -2000 continue - - return - end - - -C****6***0*********0*********0*********0*********0*********0**********72 - subroutine mappm(km, pe1, dp1, q1, kn, pe2, dp2, q2, im, iv, kord) -C****6***0*********0*********0*********0*********0*********0**********72 -C IV = 0: constituents -C IV = 1: potential temp -C IV =-1: winds -C -C Mass flux preserving mapping: q1(im,km) -> q2(im,kn) -C -C pe1: pressure at layer edges (from model top to bottom surface) -C in the original vertical coordinate -C pe2: pressure at layer edges (from model top to bottom surface) -C in the new vertical coordinate - - parameter (kmax = 200) - parameter (R3 = 1./3., R23 = 2./3.) - - real dp1(im,km), dp2(im,kn), - & q1(im,km), q2(im,kn), - & pe1(im,km+1), pe2(im,kn+1) - integer kord - -C local work arrays - real a4(4,im,km) - - do k=1,km - do i=1,im - a4(1,i,k) = q1(i,k) - enddo - enddo - - call ppm2m(a4, dp1, im, km, iv, kord) - -C Lowest layer: constant distribution - do i=1, im - a4(2,i,km) = q1(i,km) - a4(3,i,km) = q1(i,km) - a4(4,i,km) = 0. - enddo - - do 5555 i=1,im - k0 = 1 - do 555 k=1,kn - - if(pe2(i,k+1) .le. pe1(i,1)) then -! Entire grid above old ptop - q2(i,k) = a4(2,i,1) - elseif(pe2(i,k) .ge. pe1(i,km+1)) then -! Entire grid below old ps - q2(i,k) = a4(3,i,km) - elseif(pe2(i,k ) .lt. pe1(i,1) .and. - & pe2(i,k+1) .gt. pe1(i,1)) then -! Part of the grid above ptop - q2(i,k) = a4(1,i,1) - else - - do 45 L=k0,km -! locate the top edge at pe2(i,k) - if( pe2(i,k) .ge. pe1(i,L) .and. - & pe2(i,k) .le. pe1(i,L+1) ) then - k0 = L - PL = (pe2(i,k)-pe1(i,L)) / dp1(i,L) - if(pe2(i,k+1) .le. pe1(i,L+1)) then - -! entire new grid is within the original grid - PR = (pe2(i,k+1)-pe1(i,L)) / dp1(i,L) - TT = R3*(PR*(PR+PL)+PL**2) - q2(i,k) = a4(2,i,L) + 0.5*(a4(4,i,L)+a4(3,i,L) - & - a4(2,i,L))*(PR+PL) - a4(4,i,L)*TT - goto 555 - else -! Fractional area... - delp = pe1(i,L+1) - pe2(i,k) - TT = R3*(1.+PL*(1.+PL)) - qsum = delp*(a4(2,i,L)+0.5*(a4(4,i,L)+ - & a4(3,i,L)-a4(2,i,L))*(1.+PL)-a4(4,i,L)*TT) - dpsum = delp - k1 = L + 1 - goto 111 - endif - endif -45 continue - -111 continue - do 55 L=k1,km - if( pe2(i,k+1) .gt. pe1(i,L+1) ) then - -! Whole layer.. - - qsum = qsum + dp1(i,L)*q1(i,L) - dpsum = dpsum + dp1(i,L) - else - delp = pe2(i,k+1)-pe1(i,L) - esl = delp / dp1(i,L) - qsum = qsum + delp * (a4(2,i,L)+0.5*esl* - & (a4(3,i,L)-a4(2,i,L)+a4(4,i,L)*(1.-r23*esl)) ) - dpsum = dpsum + delp - k0 = L - goto 123 - endif -55 continue - delp = pe2(i,k+1) - pe1(i,km+1) - if(delp .gt. 0.) then -! Extended below old ps - qsum = qsum + delp * a4(3,i,km) - dpsum = dpsum + delp - endif -123 q2(i,k) = qsum / dpsum - endif -555 continue -5555 continue - - return - end - -c****6***0*********0*********0*********0*********0*********0**********72 - subroutine ppm2m(a4,delp,im,km,iv,kord) -c****6***0*********0*********0*********0*********0*********0**********72 -c iv = 0: positive definite scalars -c iv = 1: others -c iv =-1: winds - - implicit none - - integer im, km, lmt, iv - integer kord - integer i, k, km1 - real a4(4,im,km), delp(im,km) - -c local arrays. - real dc(im,km),delq(im,km) - real h2(im,km) - real a1, a2, a3, b2, c1, c2, c3, d1, d2, f1, f2, f3, f4 - real s1, s2, s3, s4, ss3, s32, s34, s42, sc - real qmax, qmin, cmax, cmin - real dm, qm, dq, tmp - -C Local scalars: - real qmp - real lac - - km1 = km - 1 - - do 500 k=2,km - do 500 i=1,im - delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) -500 a4(4,i,k ) = delp(i,k-1) + delp(i,k) - - do 1220 k=2,km1 - do 1220 i=1,im - c1 = (delp(i,k-1)+0.5*delp(i,k))/a4(4,i,k+1) - c2 = (delp(i,k+1)+0.5*delp(i,k))/a4(4,i,k) - tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / - & (a4(4,i,k)+delp(i,k+1)) - qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k) - qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp) -1220 continue - -c****6***0*********0*********0*********0*********0*********0**********72 -c 4th order interpolation of the provisional cell edge value -c****6***0*********0*********0*********0*********0*********0**********72 - - do 12 k=3,km1 - do 12 i=1,im - c1 = delq(i,k-1)*delp(i,k-1) / a4(4,i,k) - a1 = a4(4,i,k-1) / (a4(4,i,k) + delp(i,k-1)) - a2 = a4(4,i,k+1) / (a4(4,i,k) + delp(i,k)) - a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(a4(4,i,k-1)+a4(4,i,k+1)) * - & ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - - & delp(i,k-1)*a1*dc(i,k ) ) -12 continue - -C Area preserving cubic with 2nd deriv. = 0 at the boundaries -C Top - do i=1,im - d1 = delp(i,1) - d2 = delp(i,2) - qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) - dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) - c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) - c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1) - a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2) - dc(i,1) = a4(1,i,1) - a4(2,i,1) -C No over- and undershoot condition - cmax = max(a4(1,i,1), a4(1,i,2)) - cmin = min(a4(1,i,1), a4(1,i,2)) - a4(2,i,2) = max(cmin,a4(2,i,2)) - a4(2,i,2) = min(cmax,a4(2,i,2)) - enddo - - if(iv == 0) then - do i=1,im - a4(2,i,1) = max(0.,a4(2,i,1)) - a4(2,i,2) = max(0.,a4(2,i,2)) - enddo - elseif(iv == -1) then - do i=1,im - if( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. - enddo - endif - -c****6***0*********0*********0*********0*********0*********0**********72 - -c Bottom -c Area preserving cubic with 2nd deriv. = 0 at the surface - do 15 i=1,im - d1 = delp(i,km) - d2 = delp(i,km1) - qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) - dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) - c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) - c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1) - a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km) - dc(i,km) = a4(3,i,km) - a4(1,i,km) -c****6***0*********0*********0*********0*********0*********0**********72 -c No over- and undershoot condition - cmax = max(a4(1,i,km), a4(1,i,km1)) - cmin = min(a4(1,i,km), a4(1,i,km1)) - a4(2,i,km) = max(cmin,a4(2,i,km)) - a4(2,i,km) = min(cmax,a4(2,i,km)) -c****6***0*********0*********0*********0*********0*********0**********72 -15 continue - - if(iv .eq. 0) then - do i=1,im - a4(2,i,km) = max(0.,a4(2,i,km)) - a4(3,i,km) = max(0.,a4(3,i,km)) - enddo - endif - - do 20 k=1,km1 - do 20 i=1,im - a4(3,i,k) = a4(2,i,k+1) -20 continue -c -c f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) -c - -c Top 2 and bottom 2 layers always use monotonic mapping - - do k=1,2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) - enddo - - if(kord == 7) then -c****6***0*********0*********0*********0*********0*********0**********72 -C Huynhs 2nd constraint -c****6***0*********0*********0*********0*********0*********0**********72 - do k=2, km1 - do i=1,im - h2(i,k) = delq(i,k) - delq(i,k-1) - enddo - enddo - - do 4000 k=3, km-2 - do 3000 i=1, im -C Right edges - qmp = a4(1,i,k) + 2.0*delq(i,k-1) - lac = a4(1,i,k) + 1.5*h2(i,k-1) + 0.5*delq(i,k-1) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax) -C Left edges - qmp = a4(1,i,k) - 2.0*delq(i,k) - lac = a4(1,i,k) + 1.5*h2(i,k+1) - 0.5*delq(i,k) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax) -C Recompute A6 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) -3000 continue -! Additional constraint to prevent negatives - if (iv == 0) then - call kmppm(dc(1,k),a4(1,1,k),im, 2) - endif -4000 continue - - else - - lmt = kord - 3 - lmt = max(0, lmt) - if (iv .eq. 0) lmt = min(2, lmt) - - do k=3, km-2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, lmt) - enddo - endif - - do 5000 k=km1,km - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) -5000 continue - - return - end - -c****6***0*********0*********0*********0*********0*********0**********72 - subroutine kmppm(dm, a4, km, lmt) -c****6***0*********0*********0*********0*********0*********0**********72 - implicit none - - real r12 - parameter (r12 = 1./12.) - - integer km, lmt - integer i - real a4(4,km),dm(km) - real da1, da2, a6da - real fmin - real qmp - - if (lmt .eq. 3) return -! Full constraint - - if(lmt .eq. 0) then - do 100 i=1,km - if(dm(i) .eq. 0.) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da .lt. -da2) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da .gt. da2) then - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif -100 continue - elseif (lmt .eq. 2) then -c Positive definite - -c Positive definite constraint - do 250 i=1,km - if(abs(a4(3,i)-a4(2,i)) .ge. -a4(4,i)) go to 250 - fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 - if(fmin.ge.0.) go to 250 - if(a4(1,i).lt.a4(3,i) .and. a4(1,i).lt.a4(2,i)) then - a4(3,i) = a4(1,i) - a4(2,i) = a4(1,i) - a4(4,i) = 0. - elseif(a4(3,i) .gt. a4(2,i)) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - else - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif -250 continue - - elseif (lmt == 1) then - -! Improved full monotonicity constraint (Lin) -! Note: no need to provide first guess of A6 <-- a4(4,i) - - do i=1, km - qmp = 2.*dm(i) - a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) - a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) - a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) ) - enddo - endif - - return - end - - subroutine lonshift ( q,im,jm,lm ) - implicit none - integer im,jm,lm,i,j,L - real q(im,jm,lm),dum(im) - do L=1,lm - do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j,L) - dum(i+im/2) = q(i,j,L) - enddo - q(:,j,L) = dum(:) - enddo - enddo - return - end - - subroutine latshift ( q,im,jm,lm ) - implicit none - integer im,jm,lm,i,j,L - real q(im,jm,lm),dum(jm) - do L=1,lm - do i=1,im - do j=1,jm - dum(j) = q(i,jm-j+1,L) - enddo - q(i,:,L) = dum(:) - enddo - enddo - return - end - diff --git a/GEOS_Util/post/convert_eta.F b/GEOS_Util/post/convert_eta.F deleted file mode 100644 index c5a1f6a1..00000000 --- a/GEOS_Util/post/convert_eta.F +++ /dev/null @@ -1,3527 +0,0 @@ - program convert_eta - - use iso_fortran_env - - implicit none - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to convert ETA File (Resolution or Staggering) **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm,nt - - integer nymd ,nhms - integer nymdr ,nhmsr - integer nymdb ,nhmsb - -c Generic Model Variables -c ----------------------- - real, allocatable :: q2d(:,:,:) - real, allocatable :: q3d(:,:,:,:) - -c HDF and other Local Variables -c ----------------------------- - real, pointer :: lon (:) - real, pointer :: lat (:) - real, pointer :: lev (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - character*256, pointer :: unit2d(:), unit3d(:) - character*256 levunits - - integer id,rc,fid,n2d,n3d - integer nvars,ntime,ntimes,gfrc - - character*256, allocatable :: arg(:) - character*256, allocatable :: fname(:) - character*256 topo - character*256 name - character*256 hdfile, tag - character*256 ext - character*256 grid - character*256 psname - character*256 dpname - character*256 ozname - character*256 uname, uname2 - character*256 vname, vname2 - character*256 tname, tname2 - character*256 qname - character*256 phisname - character*4 xdim,ydim,zdim - - character*8 date0 - character*4 time0 - character*2 hour0,mins0 - character*1 char - - integer n,m,nargs,nfiles - - real undef - integer ndt - integer imout,jmout,lmout - logical hdfcreate - logical Ldtoa - - - interface - subroutine read_eta_meta ( hdffile,im,jm,lm,n2d,n3d,lat,lon,lev,undef,id, - . nymdb,nhmsb,ndt,ntimes,levunits, - . nvars,names,name2d,titl2d,unit2d,name3d,titl3d,unit3d ) - real, pointer :: lat (:) - real, pointer :: lon (:) - real, pointer :: lev (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - character*256, pointer :: unit2d(:), unit3d(:) - character*256 hdffile - character*256 levunits - integer id,im,jm,lm,n2d,n3d,nvars - integer nymdb,nhmsb,ndt,ntimes - real undef - end subroutine read_eta_meta - end interface - -C ********************************************************************** -C **** Initialization **** -C ********************************************************************** - - nt = 1 - ndt = 0 - tag = 'NULL' - grid = 'NULL' - uname = 'NULL' - vname = 'NULL' - tname = 'NULL' - qname = 'NULL' - ozname = 'NULL' - psname = 'NULL' - dpname = 'NULL' - topo = 'NULL' - imout = -999 - jmout = -999 - lmout = -999 - - phisname = 'NULL' - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - - if( trim(arg(n)).eq.'-im' ) read(arg(n+1),*) imout - if( trim(arg(n)).eq.'-jm' ) read(arg(n+1),*) jmout - if( trim(arg(n)).eq.'-lm' ) read(arg(n+1),*) lmout - if( trim(arg(n)).eq.'-grid' ) grid = trim(arg(n+1)) - if( trim(arg(n)).eq.'-uname' ) uname = trim(arg(n+1)) - if( trim(arg(n)).eq.'-vname' ) vname = trim(arg(n+1)) - if( trim(arg(n)).eq.'-tname' ) tname = trim(arg(n+1)) - if( trim(arg(n)).eq.'-qname' ) qname = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ozname' ) ozname = trim(arg(n+1)) - if( trim(arg(n)).eq.'-psname' ) psname = trim(arg(n+1)) - if( trim(arg(n)).eq.'-dpname' ) dpname = trim(arg(n+1)) - if( trim(arg(n)).eq.'-topo' ) topo = trim(arg(n+1)) - if( trim(arg(n)).eq.'-tag' ) tag = trim(arg(n+1)) - - if( trim(arg(n)).eq.'-f' ) then - nfiles = 1 - read(arg(n+nfiles),fmt='(a1)') char - do while (char.ne.'-' .and. n+nfiles.ne.nargs ) - nfiles = nfiles+1 - read(arg(n+nfiles),fmt='(a1)') char - enddo - if( char.eq.'-' ) nfiles = nfiles-1 - allocate ( fname(nfiles) ) - do m=1,nfiles - fname(m) = arg(n+m) - enddo - endif - - enddo - endif - -c Set Default NAMES -c ----------------- - if( trim(grid).ne.'NULL' ) then - if( trim(grid).eq.'dtoa' ) then - if( trim( uname).eq.'NULL' ) uname = 'uwnd' - if( trim( vname).eq.'NULL' ) vname = 'vwnd' - if( trim( tname).eq.'NULL' ) tname = 'theta' - endif - if( trim(grid).eq.'atod' ) then - if( trim( uname).eq.'NULL' ) uname = 'u' - if( trim( vname).eq.'NULL' ) vname = 'v' - if( trim( tname).eq.'NULL' ) tname = 'tv' - endif - endif - if( trim( uname).eq.'NULL' ) uname = 'uwnd' - if( trim( vname).eq.'NULL' ) vname = 'vwnd' - if( trim( tname).eq.'NULL' ) tname = 'theta' - if( trim( qname).eq.'NULL' ) qname = 'sphu' - if( trim( ozname).eq.'NULL' ) ozname = 'ozone' - if( trim( psname).eq.'NULL' ) psname = 'ps' - if( trim( dpname).eq.'NULL' ) dpname = 'delp' - if( trim(phisname).eq.'NULL' ) phisname = 'phis' - -C ********************************************************************** -C **** Summarize Input Variables **** -C ********************************************************************** - - print * - print *, 'Eta Files: ' - do n=1,nfiles - print *, n,trim(fname(n)) - enddo - print * - name = fname(1) - n = index(trim(name),'.',back=.true.) - ext = trim(name(n+1:)) - -C ********************************************************************** -C **** Read and Interpolate Eta File **** -C ********************************************************************** - - do n=1,nfiles - print *, 'Opening: ',trim(fname(n)) - call read_eta_meta ( fname(n),im,jm,lm,n2d,n3d,lat,lon,lev,undef,id, - . nymdb,nhmsb,ndt,ntimes,levunits, - . nvars,names,name2d,titl2d,unit2d,name3d,titl3d,unit3d ) - - if( (imout.ne.-999 .or. jmout.ne.-999 .or. lmout.ne.-999) ) then - endif - - if( imout.eq.-999 ) imout = im - if( jmout.eq.-999 ) jmout = jm - if( lmout.eq.-999 ) lmout = lm - - if( imout.ne.im .or. jmout.ne.jm ) then - if( trim(topo).eq.'NULL' ) then - print * - print *, 'You must supply Output resolution TOPOGRAPHY file!' - print * - stop - endif - endif - - allocate ( q2d(im,jm, n2d) ) - allocate ( q3d(im,jm,lm,n3d) ) - - print * - print *, 'Input Resolution IM: ',im - print *, 'Input Resolution JM: ',jm - print *, 'Input Resolution LM: ',lm - print * - print *, '2-D Fields:' - print *, '-----------' - do m=1,n2d - print *, trim(name2d(m)),' ',trim(unit2d(m)),' ',trim(titl2d(m)) - enddo - print * - print *, '3-D Fields:' - print *, '-----------' - do m=1,n3d - print *, trim(name3d(m)),' ',trim(unit3d(m)),' ',trim(titl3d(m)) - enddo - - nymd = nymdb - nhms = nhmsb - - print * - print *, 'Beginning Date to Read: ',nymdb - print *, 'Beginning Time to Read: ',nhmsb - print *, 'Number of Time Periods: ',ntimes,' (ndt: ',ndt,' seconds)' - print * - - write(date0,1000) nymdb - write(hour0,2000) nhmsb/10000 - write(mins0,2000) (nhmsb-(nhmsb/10000)*10000)/100 - 1000 format(i8.8) - 2000 format(i2.2) - time0 = trim(hour0)//trim(mins0) - - hdfile = trim(fname(n)) - if( trim(tag).ne.'NULL' ) then - hdfile = trim(hdfile) // "." // trim(tag) - else - if( trim(grid).ne.'NULL' ) hdfile = trim(hdfile) // "." // trim(grid) - if( imout.ne.im .or. jmout.ne.jm .or. lmout.ne.lm ) then - write(xdim,103) imout - write(ydim,103) jmout - write(zdim,103) lmout - 103 format(i4.4) - hdfile = trim(hdfile) // "." // xdim // "x" // ydim // "x" // zdim - endif - endif - - call gfio_open ( trim(fname(n)),1,id,rc ) - rc = 0 - ntime = 0 - hdfcreate = .true. - dowhile (rc.eq.0) - ntime = ntime + 1 - - nymdr = nymd - nhmsr = nhms - print * - - Ldtoa = .false. - call read_eta_data ( id,q2d,q3d,n2d,n3d,name2d,name3d,undef, - . im,jm,lm,nymdr,nhmsr,rc,ntime,ntimes,grid, - . uname,vname,tname,Ldtoa,uname2,vname2,tname2) - - if( rc.eq.0 ) then - call convert ( q2d,q3d,name2d,titl2d,unit2d,name3d,titl3d,unit3d,n2d,n3d,undef, - . levunits,im,jm,lm,lat,lon,lev,nymd,nhms,ndt, - . fid,hdfcreate,hdfile,imout,jmout,lmout,grid, - . psname,dpname,uname2,vname2,tname2,qname,ozname,phisname,topo,Ldtoa) - - call tick (nymd,nhms,ndt) - hdfcreate = .false. - else - call gfio_close ( fid,gfrc ) - print *, 'Created: ',trim(hdfile) - print * - print * - deallocate ( q2d ) - deallocate ( q3d ) - endif - enddo - call gfio_close ( id,gfrc ) - enddo - - deallocate ( arg ) - - stop - end - - subroutine read_eta_data ( id,q2d,q3d,n2d,n3d,name2d,name3d,undef, - . im,jm,lm,nymd,nhms,rc,ntime,ntimes,grid, - . uname,vname,tname,Ldtoa,uname2,vname2,tname2) - implicit none - - integer im,jm,lm,nymd,nhms,id,rc - integer n2d,n3d,ntime,ntimes - integer nundef,nvndef - real q2d(im,jm ,n2d) - real q3d(im,jm,lm,n3d) - real u(im,jm,lm) - real v(im,jm,lm) - real undef,qmin,qmax - character*256 name2d(n2d) - character*256 name3d(n3d) - character*256 grid - character*256 uname, uname2 - character*256 vname, vname2 - character*256 tname, tname2 - integer i,j,L,n,nu,nv,nt - logical Ldtoa - - nu = 0 - nv = 0 - rc = 0 - if( ntime <= ntimes ) then - -c Collect Eta Data -c ---------------- - print *, 'Reading nymd: ',nymd,' nhms: ',nhms - print * - do n=1,n2d - call gfio_getvar ( id,trim(name2d(n)),nymd,nhms,im,jm,0,1,q2d(1,1,n),rc ) - if( rc.ne.0 ) then - rc = 1 ! No more time periods in file - return - endif - call minmax (q2d(1,1,n),im,jm,1,qmin,qmax,undef) - print *, trim(name2d(n)),' Min: ',qmin,' Max: ',qmax - enddo - - nundef = 0 - nvndef = 0 - do n=1,n3d - call gfio_getvar ( id,trim(name3d(n)),nymd,nhms,im,jm,1,lm,q3d(1,1,1,n),rc ) - call minmax (q3d(1,1,1,n),im,jm,lm,qmin,qmax,undef) - print *, trim(name3d(n)),' Min: ',qmin,' Max: ',qmax - - if( trim(name3d(n)).eq.trim(uname) ) then - nu = n - u = q3d(:,:,:,n) - do L=1,lm - do j=1,jm - do i=1,im - if( u(i,j,L).eq.undef ) nundef = nundef + 1 - enddo - enddo - enddo - endif - if( trim(name3d(n)).eq.trim(vname) ) then - nv = n - v = q3d(:,:,:,n) - do L=1,lm - do j=1,jm - do i=1,im - if( v(i,j,L).eq.undef ) nvndef = nvndef + 1 - enddo - enddo - enddo - endif - if( trim(name3d(n)).eq.trim(tname) ) nt = n - enddo - -c Convert D-Grid Winds to A-Grid Winds -c (Assume D-Grid UWind is UNDEF at South Pole j=1) -c ------------------------------------------------ - if( trim(grid).eq.'dtoa' .or. - . (nundef.eq.im*lm .and. nvndef.eq.0) ) then - print * - print *, 'Converting D-Grid Winds to A-Grid ...' - if( nu.eq.0 .or. nv.eq.0 ) then - print * - print *, 'D-Grid Winds Not Found!' - print *, 'UNAME: ',trim(uname),' nu: ',nu - print *, 'VNAME: ',trim(vname),' nv: ',nv - print * - stop - else - call dtoa_winds ( u,v,q3d(1,1,1,nu),q3d(1,1,1,nv),im,jm,lm ) - name3d(nu) = 'u' - name3d(nv) = 'v' - name3d(nt) = 'thetav' - uname2 = 'u' - vname2 = 'v' - tname2 = 'thetav' - Ldtoa = .true. - endif - else - uname2 = uname - vname2 = vname - tname2 = tname - endif - - else - rc = 1 ! No more time periods in file - endif - - return - end subroutine read_eta_data - - subroutine convert ( q2d,q3d,name2d,titl2d,unit2d,name3d,titl3d,unit3d,n2d,n3d,undef, - . levunits,im,jm,lm,lat,lon,lev,nymd,nhms,ninc, - . id,create,filename,imo,jmo,lmo,grid, - . psname,dpname,uname,vname,tname,qname,ozname,phisname,topo,Ldtoa) - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - use iso_fortran_env - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,nymd,nhms,ninc,n2d,n3d - - real q2d(im,jm, n2d) - real q3d(im,jm,lm,n3d) - - integer imo,jmo,lmo - real phis(imo,jmo) - real ps(imo,jmo) - real dp(imo,jmo,lm) - real u(imo,jmo,lm) - real v(imo,jmo,lm) - real t(imo,jmo,lm) - real q(imo,jmo,lm,2) - - real z2d(imo,jmo, n2d) - real z3d(imo,jmo,lm,n3d) - - real phiso(imo,jmo) - real pso(imo,jmo) - real dpo(imo,jmo,lmo) - real uo(imo,jmo,lmo) - real vo(imo,jmo,lmo) - real to(imo,jmo,lmo) - real qo(imo,jmo,lmo,2) - real dum3d(imo,jmo,lmo) - real dum2d(imo,jmo) - - character*256 name2d(n2d), titl2d(n2d), unit2d(n2d) - character*256 name3d(n3d), titl3d(n3d), unit3d(n3d) - character*256 filename - character*256 topo - character*256 levunits - character*256 grid - character*256 psname - character*256 dpname - character*256 uname - character*256 vname - character*256 tname - character*256 qname - character*256 ozname - character*256 phisname - - real lat(jm) ,lon (im) ,lev (lm) - real lats(jmo),lons(imo),levs(lmo) - logical create - logical Ldtoa - -c Local Variables -c --------------- - integer i,j,L,n,m - integer nu,nv,kdum - - real undef, pi,dx,dy, qmin, qmax - real(kind=REAL64) ptop, rdum - integer precision,id,timeinc,rc,nhmsf - - character*256 title - character*256 source - character*256 contact - - integer nvars - - character*256, allocatable :: vnames(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - integer, allocatable :: lmvar(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - - real, allocatable :: ple(:,:,:) - real, allocatable :: logpl(:,:,:) - real, allocatable :: logplo(:,:,:) - real(kind=REAL64), allocatable :: ak(:) - real(kind=REAL64), allocatable :: bk(:) - - real dpref - dpref(L) = ( ak(L+1)-ak(L) ) + ( bk(L+1)-bk(L) ) * 98400.0 - -C ********************************************************************** -C **** Initialize Constants And Local Arrays **** -C ********************************************************************** - - pi = 4.*atan(1.) - dx = 360./ imo - dy = 180./(jmo-1) - if( im.ne.imo .or. jm.ne.jmo ) then - do j=1,jmo - lats(j) = lat(1) + (j-1)*dy - enddo - do i=1,imo - lons(i) = lon(1) + (i-1)*dx - enddo - else - lats = lat - lons = lon - endif - - nvars = n2d + n3d - -C ********************************************************************** -C **** Interpolate A-Grid Horizontal Fields **** -C ********************************************************************** - - if( im.ne.imo .or. jm.ne.jmo ) then - write(6,100) imo,jmo - 100 format(1x,'Interpolating to Horizontal Resolution (',i4,' x ',i4,') ...') - do n=1,n2d - call hinterp ( q2d(1,1,n),im,jm,z2d(1,1,n),imo,jmo,1,undef) - enddo - do n=1,n3d - call hinterp ( q3d(1,1,1,n),im,jm,z3d(1,1,1,n),imo,jmo,lm,undef) - enddo - else - z2d=q2d - z3d=q3d - endif - -C ********************************************************************** -C **** Create D-Grid Winds if Desired **** -C ********************************************************************** - - if( trim(grid).eq.'atod' .or. - . (trim(grid).eq.'NULL' .and. Ldtoa) ) then - print *, 'Converting A-Grid Winds to D-Grid ...' - nu = 0 - nv = 0 - do n=1,n3d - if( trim(name3d(n)).eq.trim(uname) ) then - nu = n - u = z3d(:,:,:,n) - endif - if( trim(name3d(n)).eq.trim(vname) ) then - nv = n - v = z3d(:,:,:,n) - endif - enddo - - if( nu.eq.0 .or. nv.eq.0 ) then - print * - print *, 'A-Grid Winds Not Found!' - print *, 'UNAME: ',trim(uname),' nu: ',nu - print *, 'VNAME: ',trim(vname),' nv: ',nv - print * - stop - else - name3d(nu) = 'uwnd' ; uname = 'uwnd' - name3d(nv) = 'vwnd' ; vname = 'vwnd' - call atod_winds ( u,v,z3d(1,1,1,nu),z3d(1,1,1,nv),imo,jmo,lm ) - endif - endif - print * - -C ********************************************************************** -C **** Interpolate to New Output Levels **** -C ********************************************************************** - - do n=1,n2d - if( trim(name2d(n)).eq.trim( psname) ) ps = z2d(:,:,n) - if( trim(name2d(n)).eq.trim(phisname) ) phis = z2d(:,:,n) - enddo - do n=1,n3d - if( trim(name3d(n)).eq.trim( uname) ) u = z3d(:,:,:,n) - if( trim(name3d(n)).eq.trim( vname) ) v = z3d(:,:,:,n) - if( trim(name3d(n)).eq.trim( tname) ) t = z3d(:,:,:,n) - if( trim(name3d(n)).eq.trim( dpname) ) dp = z3d(:,:,:,n) - if( trim(name3d(n)).eq.trim( qname) ) q(:,:,:,1) = z3d(:,:,:,n) - if( trim(name3d(n)).eq.trim( ozname) ) q(:,:,:,2) = z3d(:,:,:,n) - enddo - - if( imo.ne.im .or. jmo.ne.jm .or. lmo.ne.lm ) then - - if( imo.ne.im .or. jmo.ne.jm .or. trim(topo).ne.'NULL' ) then - close(55) - open (55,file=trim(topo),form='unformatted',access='sequential') - read (55) phiso - phiso = phiso*MAPL_GRAV - close(55) - if( lon(1).eq.0.0 ) call hflip ( phiso,imo,jmo,1 ) - else - phiso = phis - endif - - - allocate( ak (lm+1) ) - allocate( bk (lm+1) ) - allocate( ple(imo,jmo,lm+1) ) - allocate( logpl(imo,jmo,lm) ) - call set_eta ( lm,kdum,ptop,rdum,ak,bk ) - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - do L=1,lm - logpl(:,:,L) = log( 0.5*(ple(:,:,L+1)+ple(:,:,L)) ) - enddo - deallocate( ak,bk,ple ) - - - allocate( ak(lmo+1) ) - allocate( bk(lmo+1) ) - allocate( ple(imo,jmo,lmo+1) ) - allocate( logplo(imo,jmo,lmo) ) - call set_eta ( lmo,kdum,ptop,rdum,ak,bk ) - pso = ps - do L=1,lmo+1 - ple(:,:,L) = ak(L) + pso(:,:)*bk(L) - enddo - do L=1,lmo - dpo(:,:,L) = ple(:,:,L+1)-ple(:,:,L) - logplo(:,:,L) = log( 0.5*(ple(:,:,L+1)+ple(:,:,L)) ) - enddo - - - print *, 'Calling REMAP ...' - call remap ( pso,dpo,uo,vo,to,qo,phiso,lmo, - . ps ,u ,v ,t ,q ,phis ,lm , - . imo,jmo,2 ) - print *, ' REMAP Finished' - - - ptop = ak(1) - levs(1) = ptop + 0.5 * dpref(1) - do L = 2, lmo - levs(L) = levs(L-1) + 0.5 * ( dpref(L-1) + dpref(L) ) - enddo - levs(1:lmo) = levs(1:lmo) / 100.0 - - deallocate( ak,bk,ple ) - else - levs(1:lmo) = lev(1:lmo) - phiso = phis - pso = ps - uo = u - vo = v - to = t - dpo = dp - qo(:,:,:,1) = q(:,:,:,1) - qo(:,:,:,2) = q(:,:,:,2) - endif - -C ********************************************************************** -C **** Initialize GFIO File **** -C ********************************************************************** - - allocate ( vnames(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - - timeinc = nhmsf(ninc) - precision = 1 ! 64-bit - precision = 0 ! 32-bit - - title = 'GEOS-5 GCM (DTOA Conversion)' - source = 'Goddard Modeling and Assimilation Office, NASA/GSFC' - contact = 'data@gmao.gsfc.nasa.gov' - -c Defined Fields -c -------------- - do m=1,n2d - n = m - vnames(n) = name2d(m) - vtitle(n) = trim(titl2d(m)) - vunits(n) = trim(unit2d(m)) - lmvar(n) = 0 - enddo - - do m=1,n3d - n = n2d+m - vnames(n) = name3d(m) - vtitle(n) = trim(titl3d(m)) - vunits(n) = trim(unit3d(m)) - lmvar(n) = lmo - enddo - -C ********************************************************************** -C **** Value Added Products **** -C ********************************************************************** - - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - vrange(:,:) = undef - prange(:,:) = undef - - if (create) then - call GFIO_Create ( trim(filename), title, source, contact, undef, - . imo, jmo, lmo, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vnames, vtitle, vunits, lmvar, - . vrange, prange, precision, - . id, rc ) - endif - -C ********************************************************************** -C **** Write Defined Fields **** -C ********************************************************************** - - do n=1,n2d - if( trim(name2d(n)).eq.trim( psname) ) then - dum2d = pso - else if( trim(name2d(n)).eq.trim(phisname) ) then - dum2d = phiso - else - dum2d = z2d(:,:,n) - endif - call writit( dum2d, imo,jmo,1 ,id,name2d(n),nymd,nhms ) - enddo - do n=1,n3d - if( trim(name3d(n)).eq.trim( uname) ) then - dum3d = uo - else if( trim(name3d(n)).eq.trim( vname) ) then - dum3d = vo - else if( trim(name3d(n)).eq.trim( tname) ) then - dum3d = to - else if( trim(name3d(n)).eq.trim( qname) ) then - dum3d = qo(:,:,:,1) - else if( trim(name3d(n)).eq.trim( ozname) ) then - dum3d = qo(:,:,:,2) - else if( trim(name3d(n)).eq.trim( dpname) ) then - dum3d = dpo - else - if( lm.ne.lmo ) then - print *, 'Calling sigtopl for: ',trim(name3d(n)) - do L=1,lmo - do j=1,jmo - do i=1,imo - call sigtopl( dum3d(i,j,L),z3d(i,j,:,n),logpl(i,j,:),logplo(i,j,L),1,1,lm,undef ) - enddo - enddo - enddo - else - dum3d = z3d(:,:,:,n) - endif - endif - call writit( dum3d,imo,jmo,lmo,id,name3d(n),nymd,nhms ) - enddo - -C ********************************************************************** -C **** De-Allocate Dynamics Arrays **** -C ********************************************************************** - - deallocate ( vnames ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( lmvar ) - deallocate ( vrange ) - deallocate ( prange ) - return - end subroutine convert - - subroutine read_eta_meta ( hdffile,im,jm,lm,n2d,n3d,lat,lon,lev,undef,id, - . nymdb,nhmsb,ndt,ntime,levunits, - . nvars,names,name2d,titl2d,unit2d,name3d,titl3d,unit3d ) - implicit none - - real, pointer :: lat (:) - real, pointer :: lon (:) - real, pointer :: lev (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - character*256, pointer :: unit2d(:), unit3d(:) - - character*256 hdffile - integer id,im,jm,lm,n2d,n3d,nvars,nsecf,timeId,ncvid - integer ntime,ngatts,rc,timinc,nymdb,nhmsb,ndt - real undef - integer n - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - -C ********************************************************************** -C **** Read HDF File for Meta Data **** -C ********************************************************************** - - call gfio_open ( trim(hdffile),1,id,rc ) - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( names(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - timinc = 0 - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - - if( timinc .eq. 0 ) then - timeId = ncvid (id, 'time', rc) - call ncagt (id, timeId, 'time_increment', timinc, rc) - if( timinc .eq. 0 ) then - print * - print *, 'Warning, GFIO Inquire states TIMINC = ',timinc - print *, ' This will be reset to 060000 ' - print *, ' Use -ndt NNNNNN (in seconds) to overide this' - timinc = 060000 - endif - endif - - if( ndt.eq.0 ) ndt = nsecf (timinc) - - nymdb = yymmdd(1) - nhmsb = hhmmss(1) - - if( nhmsb.lt.0 ) then - n = nsecf(abs(nhmsb)) - nhmsb = 0 - call tick (nymdb,nhmsb,-n) - endif - - names = vname - - n2d = 0 - n3d = 0 - do n=1,nvars - if( kmvar(n) .eq. 0 .or. - . trim(vname(n)).eq.'LON' .or. - . trim(vname(n)).eq.'LAT') then - n2d = n2d + 1 - kmvar(n) = 0 - else - n3d = n3d + 1 - endif - enddo - - allocate( name2d(n2d) ) - allocate( titl2d(n2d) ) - allocate( unit2d(n2d) ) - allocate( name3d(n3d) ) - allocate( titl3d(n3d) ) - allocate( unit3d(n3d) ) - - n2d = 0 - n3d = 0 - do n=1,nvars - if( kmvar(n).eq.0 ) then - n2d = n2d + 1 - name2d(n2d) = vname (n) - titl2d(n2d) = vtitle(n) - unit2d(n2d) = vunits(n) - else - n3d = n3d + 1 - name3d(n3d) = vname (n) - titl3d(n3d) = vtitle(n) - unit3d(n3d) = vunits(n) - endif - enddo - - call gfio_close ( id,rc ) - return - end subroutine read_eta_meta - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*undef - return - end function defined - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end function nsecf - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end function nhmsf - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - end subroutine tick - - function incymd (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - RETURN - end function incymd - - subroutine writit (q,im,jm,lm,id,name,nymd,nhms) - integer im,jm,lm - integer id,nymd,nhms,rc,lbeg - character*256 name - real q (im,jm,lm) - real undef,qmin,qmax - lbeg = 1 - if( lm.eq.1 ) lbeg = 0 - call minmax (q,im,jm,lm,qmin,qmax,undef) - write(6,100) trim(name),qmin,qmax - 100 format(1x,' Writing variable: ',a,' Min: ',g12.6,' Max: ',g12.6) - call Gfio_putVar ( id,trim(name),nymd,nhms,im,jm,lbeg,lm,q,rc ) - return - end subroutine writit - - subroutine usage() - write(6,100) - 100 format( "Usage: " ,/ - . ,/ - . " convert_eta.x -f fname(s)" ,/ - . " [-im imout]" ,/ - . " [-jm jmout]" ,/ - . " [-lm lmout]" ,/ - . " [-grid conversion]" ,/ - . " [-topo topo_fname]" ,/ - . " [-tag output_tag] " ,/ - . ,/ - . "where:" ,/ - . ,/ - . " -f fname(s): Filename(s) in HDF format" ,/ - . ,/ - . "Optional Args:" ,/ - . ,/ - . " -im imout: Optional Output Resolution in X (default: Input Resolution)" ,/ - . " -jm jmout: Optional Output Resolution in Y (default: Input Resolution)" ,/ - . " -lm lmout: Optional Output Resolution in Z (default: Input Resolution)" ,/ - . " -grid conversion: Optional Grid Conversion (dtoa or atod)" ,/ - . " -topo topo_fname: Optional Filename for Output Topography File" ,/ - . " -tag output_tag: Optional Filename Tag for output: fname(s).tag (default: grid.IMxJM)" ,/ - . ,/ - . ) - error stop 7 - end subroutine usage - - subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef ) - implicit none - integer iin,jin, iout,jout, mlev - real qin(iin,jin,mlev), qout(iout,jout,mlev) - real undef,pi,dlin,dpin,dlout,dpout - real dlam(iin), lons(iout*jout), lon - real dphi(jin), lats(iout*jout), lat - integer i,j,loc - - - pi = 4.0*atan(1.0) - dlin = 2*pi/iin - dpin = pi/(jin-1) - dlam(:) = dlin - dphi(:) = dpin - - dlout = 2*pi/iout - dpout = pi/(jout-1) - - loc = 0 - do j=1,jout - do i=1,iout - loc = loc + 1 - lon = -pi + (i-1)*dlout - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jout - lat = -pi/2.0 + (j-1)*dpout - do i=1,iout - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call interp_h ( qin,iin,jin,mlev,dlam,dphi, - . qout,iout*jout,lons,lats,undef ) - - return - end - - subroutine interp_h ( q_cmp,im,jm,lm,dlam,dphi, - . q_geo,irun,lon_geo,lat_geo,undef ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - -c Local Variables -c --------------- - integer i,j,l - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real ap1, ap0, am1, am2 - real bp1, bp0, bm1, bm2 - - real, allocatable :: lon_cmp(:) - real, allocatable :: lat_cmp(:) - real, allocatable :: q_tmp(:) - - real pi,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp - real lam_cmp - real phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - - allocate ( lon_cmp(im) ) - allocate ( lat_cmp(jm) ) - allocate ( q_tmp(irun) ) - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - do i=1,irun - lam_cmp = lon_geo(i) - phi_cmp = lat_geo(i) - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm2 = lat_cmp(jm2(i)) - phi_jm1 = lat_cmp(jm1(i)) - phi_jp0 = lat_cmp(jp0(i)) - phi_jp1 = lat_cmp(jp1(i)) - - if( jm2(i).eq.0 ) phi_jm2 = phi_jm1 - dphi(1) - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - endif - if( jp1(i).eq.jm+1 ) phi_jp1 = phi_jp0 + dphi(jm-1) - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - -c Interpolate Computational-Grid Quantities to Geophysical Grid -c ------------------------------------------------------------- - do L=1,lm - do i=1,irun - - if( lat_geo(i).le.lat_cmp(2) .or. - . lat_geo(i).ge.lat_cmp(jm-1) ) then - -c 1st Order Interpolation at Poles -c -------------------------------- - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - else - -c Cubic Interpolation away from Poles -c ----------------------------------- - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jp1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp1(i),L ).ne.undef .and. - . q_cmp( im2(i),jp1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm2(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm2(i),L ).ne.undef .and. - . q_cmp( im1(i),jm2(i),L ).ne.undef .and. - . q_cmp( im2(i),jm2(i),L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) - . + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) - . + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) - . + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) - . + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) - . + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) - . + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - deallocate ( lon_cmp ) - deallocate ( lat_cmp ) - deallocate ( q_tmp ) - return - end - subroutine atod_winds ( ua,va,ud,vd,im,jm,lm ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded winds **** -C **** to 'D' gridded winds **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C ****************************************************************** - - real ua(im,jm,lm), ud(im,jm,lm) - real va(im,jm,lm), vd(im,jm,lm) - - call atod ( ua,ud,im,jm,lm,2 ) - call atod ( va,vd,im,jm,lm,1 ) - - return - end - - subroutine dtoa_winds ( ud,vd,ua,va,im,jm,lm ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded winds **** -C **** to 'A' gridded winds **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C ****************************************************************** - - real ua(im,jm,lm), ud(im,jm,lm) - real va(im,jm,lm), vd(im,jm,lm) - - real sinx(im/2) - real cosx(im/2) - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - do i=1,imh - sinx(i) = sin( -pi + (i-1)*dx ) - cosx(i) = cos( -pi + (i-1)*dx ) - enddo - -C ********************************************************* -C **** Average D-Grid Winds **** -C ********************************************************* - - call dtoa ( ud,ua,im,jm,lm,2 ) - call dtoa ( vd,va,im,jm,lm,1 ) - -C ********************************************************* -C **** Fix A-Grid Pole Winds **** -C ********************************************************* - - do L=1,lm - - do m=1,2 - n = (-1)**m - jpole = 1 + (m-1)*(jm-1) - jstar = 2 + (m-1)*(jm-3) - - upole = 0.0 - vpole = 0.0 - do i=1,imh - upole = upole + ( ua(i+imh,jstar,L)-ua(i,jstar,L) )*sinx(i) - . + n*( va(i+imh,jstar,L)-va(i,jstar,L) )*cosx(i) - vpole = vpole - n*( ua(i+imh,jstar,L)-ua(i,jstar,L) )*cosx(i) - . + ( va(i+imh,jstar,L)-va(i,jstar,L) )*sinx(i) - enddo - upole = upole / im - vpole = vpole / im - do i=1,imh - ua(i ,jpole,L) = - upole*sinx(i) + n*vpole*cosx(i) - va(i ,jpole,L) = - n*upole*cosx(i) - vpole*sinx(i) - ua(i+imh,jpole,L) = - ua(i,jpole,L) - va(i+imh,jpole,L) = - va(i,jpole,L) - enddo - enddo - - enddo - - return - end - - subroutine atod ( qa,qd,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded data **** -C **** to 'D' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted left (westward), **** -C **** u is shifted down (southward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real,allocatable :: qax(:,:) - real,allocatable :: cx(:,:) - real,allocatable :: qay(:,:) - real,allocatable :: cy(:,:) - - real,allocatable :: sinx(:) - real,allocatable :: cosx(:) - real,allocatable :: siny(:) - real,allocatable :: cosy(:) - real,allocatable :: trigx(:) - real,allocatable :: trigy(:) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - - allocate( qax ( im+2 ,lm) ) - allocate( cx (2*(im+2),lm) ) - allocate( qay ( 2*jm ,lm) ) - allocate( cy (2*(2*jm),lm) ) - - allocate( cosx(im/2) ) - allocate( sinx(im/2) ) - allocate( cosy(jm) ) - allocate( siny(jm) ) - allocate( trigx(3*(im+1)) ) - allocate( trigy(3*(2*jm)) ) - -C ********************************************************* -C **** shift left (-dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qa(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) + qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) - qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qd(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift down (-dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qa(i,j+1,L) - qay(j+jmm1,L) = -qa(i+imh,jm-j,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) + qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) - qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qd(i,j+1,L) = qay(j,L) - qd(i+imh,jm-j+1,L) = -qay(j+jmm1,L) - enddo - enddo - enddo - - endif - - deallocate( qax ) - deallocate( cx ) - deallocate( qay ) - deallocate( cy ) - - deallocate( cosx ) - deallocate( sinx ) - deallocate( cosy ) - deallocate( siny ) - deallocate( trigx ) - deallocate( trigy ) - - return - end - - subroutine dtoa ( qd,qa,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real,allocatable :: qax(:,:) - real,allocatable :: cx(:,:) - real,allocatable :: qay(:,:) - real,allocatable :: cy(:,:) - - real,allocatable :: sinx(:) - real,allocatable :: cosx(:) - real,allocatable :: siny(:) - real,allocatable :: cosy(:) - real,allocatable :: trigx(:) - real,allocatable :: trigy(:) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - - allocate( qax ( im+2 ,lm) ) - allocate( cx (2*(im+2),lm) ) - allocate( qay ( 2*jm ,lm) ) - allocate( cy (2*(2*jm),lm) ) - - allocate( cosx(im/2) ) - allocate( sinx(im/2) ) - allocate( cosy(jm) ) - allocate( siny(jm) ) - allocate( trigx(3*(im+1)) ) - allocate( trigy(3*(2*jm)) ) - -C ********************************************************* -C **** shift right (dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qd(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) - qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) + qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qa(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift up (dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qd(i,j+1,L) - qay(j+jmm1,L) = -qd(i+imh,jm-j+1,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) - qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) + qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qa(i,j+1,L) = qay(j,L) - qa(i+imh,jm-j,L) = -qay(j+jmm1,L) - enddo - enddo - - enddo - - do L=1,lm - do i=1,imh - qa(i+imh,jm,L) = -qa(i,jm,L) - qa(i,1,L) = -qa(i+imh,1,L) - enddo - enddo - endif - - deallocate( qax ) - deallocate( cx ) - deallocate( qay ) - deallocate( cy ) - - deallocate( cosx ) - deallocate( sinx ) - deallocate( cosy ) - deallocate( siny ) - deallocate( trigx ) - deallocate( trigy ) - - return - end - - subroutine rfftmlt (a,work,trigs,ifax,inc,jump,n,lot,isign) - integer INC, JUMP, N, LOT, ISIGN - real(kind=KIND(1.0)) A(N),WORK(N),TRIGS(N) - integer IFAX(*) -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR -! CALL Q8QST4 ( 4HXLIB, 6HFFT99F, 6HFFT991, 10HVERSION 01) -!FPP$ NOVECTOR R - integer NFAX, NH, NX, INK - integer I, J, IBASE, JBASE, L, IGO, IA, LA, K, M, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, - * INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, - * 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 -!DIR$ IVDEP - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END - - subroutine fftfax (n,ifax,trigs) - integer IFAX(13) - integer N - REAL(kind=KIND(1.0)) TRIGS(*) -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - integer I, MODE - DATA MODE /3/ -!FPP$ NOVECTOR R - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) WRITE(6,FMT="(//5X, ' FFTFAX -- INVALID N =', I5,/)") N - IF (IFAX(1) .LE. 0 ) STOP 999 - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END - - subroutine fft99a (a,work,trigs,inc,jump,n,lot) - integer inc, jump, N, lot - real(kind=KIND(1.0)) A(N),WORK(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 -! (SPECTRAL TO GRIDPOINT TRANSFORM) -! -!FPP$ NOVECTOR R - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) C, S - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - IA=1 - IB=N*INC+1 - JA=1 - JB=2 -!DIR$ IVDEP - DO 10 L=1,LOT - WORK(JA)=A(IA)+A(IB) - WORK(JB)=A(IA)-A(IB) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 10 CONTINUE -! -! REMAINING WAVENUMBERS - IABASE=2*INC+1 - IBBASE=(N-2)*INC+1 - JABASE=3 - JBBASE=N-1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - WORK(JA)=(A(IA)+A(IB))- - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JB)=(A(IA)+A(IB))+ - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+ - * (A(IA+INC)-A(IB+INC)) - WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))- - * (A(IA+INC)-A(IB+INC)) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 20 CONTINUE - IABASE=IABASE+INK - IBBASE=IBBASE-INK - JABASE=JABASE+2 - JBBASE=JBBASE-2 - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE -!DIR$ IVDEP - DO 40 L=1,LOT - WORK(JA)=2.0*A(IA) - WORK(JA+1)=-2.0*A(IA+INC) - IA=IA+JUMP - JA=JA+NX - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fft99b (work,a,trigs,inc,jump,n,lot) - integer INC, JUMP, N, LOT - real(kind=KIND(1.0)) WORK(N),A(N) - REAL(kind=KIND(1.0)) TRIGS(N) - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) SCALE - real(kind=KIND(1.0)) C, S -! -! SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 -! (GRIDPOINT TO SPECTRAL TRANSFORM) -! -!FPP$ NOVECTOR R - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - SCALE=1.0/FLOAT(N) - IA=1 - IB=2 - JA=1 - JB=N*INC+1 -!DIR$ IVDEP - DO 10 L=1,LOT - A(JA)=SCALE*(WORK(IA)+WORK(IB)) - A(JB)=SCALE*(WORK(IA)-WORK(IB)) - A(JA+INC)=0.0 - A(JB+INC)=0.0 - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 10 CONTINUE -! -! REMAINING WAVENUMBERS - SCALE=0.5*SCALE - IABASE=3 - IBBASE=N-1 - JABASE=2*INC+1 - JBBASE=(N-2)*INC+1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - A(JA)=SCALE*((WORK(IA)+WORK(IB)) - * +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JB)=SCALE*((WORK(IA)+WORK(IB)) - * -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * +(WORK(IB+1)-WORK(IA+1))) - A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * -(WORK(IB+1)-WORK(IA+1))) - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 20 CONTINUE - IABASE=IABASE+2 - IBBASE=IBBASE-2 - JABASE=JABASE+INK - JBBASE=JBBASE-INK - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - SCALE=2.0*SCALE -!DIR$ IVDEP - DO 40 L=1,LOT - A(JA)=SCALE*WORK(IA) - A(JA+INC)=-SCALE*WORK(IA+1) - IA=IA+NX - JA=JA+JUMP - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fax (ifax,n,mode) - integer IFAX(10) - integer N, MODE -!FPP$ NOVECTOR R - integer NN, K, L, INC, II, ISTOP, ITEM, NFAX, I - NN=N - IF (IABS(MODE).EQ.1) GO TO 10 - IF (IABS(MODE).EQ.8) GO TO 10 - NN=N/2 - IF ((NN+NN).EQ.N) GO TO 10 - IFAX(1)=-99 - RETURN - 10 K=1 -! TEST FOR FACTORS OF 4 - 20 IF (MOD(NN,4).NE.0) GO TO 30 - K=K+1 - IFAX(K)=4 - NN=NN/4 - IF (NN.EQ.1) GO TO 80 - GO TO 20 -! TEST FOR EXTRA FACTOR OF 2 - 30 IF (MOD(NN,2).NE.0) GO TO 40 - K=K+1 - IFAX(K)=2 - NN=NN/2 - IF (NN.EQ.1) GO TO 80 -! TEST FOR FACTORS OF 3 - 40 IF (MOD(NN,3).NE.0) GO TO 50 - K=K+1 - IFAX(K)=3 - NN=NN/3 - IF (NN.EQ.1) GO TO 80 - GO TO 40 -! NOW FIND REMAINING FACTORS - 50 L=5 - INC=2 -! INC ALTERNATELY TAKES ON VALUES 2 AND 4 - 60 IF (MOD(NN,L).NE.0) GO TO 70 - K=K+1 - IFAX(K)=L - NN=NN/L - IF (NN.EQ.1) GO TO 80 - GO TO 60 - 70 L=L+INC - INC=6-INC - GO TO 60 - 80 IFAX(1)=K-1 -! IFAX(1) CONTAINS NUMBER OF FACTORS - NFAX=IFAX(1) -! SORT FACTORS INTO ASCENDING ORDER - IF (NFAX.EQ.1) GO TO 110 - DO 100 II=2,NFAX - ISTOP=NFAX+2-II - DO 90 I=2,ISTOP - IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 - ITEM=IFAX(I) - IFAX(I)=IFAX(I+1) - IFAX(I+1)=ITEM - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN - END - - subroutine fftrig (trigs,n,mode) - REAL(kind=KIND(1.0)) TRIGS(*) - integer N, MODE -!FPP$ NOVECTOR R - real(kind=KIND(1.0)) PI - integer IMODE, NN, L, I, NH, LA - real(kind=KIND(1.0)) DEL, ANGLE - PI=2.0*ASIN(1.0) - IMODE=IABS(MODE) - NN=N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 - DEL=(PI+PI)/FLOAT(NN) - L=NN+NN - DO 10 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(I)=COS(ANGLE) - TRIGS(I+1)=SIN(ANGLE) - 10 CONTINUE - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - DEL=0.5*DEL - NH=(NN+1)/2 - L=NH+NH - LA=NN+NN - DO 20 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(LA+I)=COS(ANGLE) - TRIGS(LA+I+1)=SIN(ANGLE) - 20 CONTINUE - IF (IMODE.LE.3) RETURN - DEL=0.5*DEL - LA=LA+NN - IF (MODE.EQ.5) GO TO 40 - DO 30 I=2,NN - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=2.0*SIN(ANGLE) - 30 CONTINUE - RETURN - 40 CONTINUE - DEL=0.5*DEL - DO 50 I=2,N - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=SIN(ANGLE) - 50 CONTINUE - RETURN - END - - subroutine vpassm (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la) - integer INC1,INC2,INC3,INC4,LOT,N,IFAC,LA - real(kind=KIND(1.0)) A(N),B(N),C(N),D(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA" -! PERFORMS ONE PASS THROUGH DATA -! AS PART OF MULTIPLE COMPLEX FFT ROUTINE -! A IS FIRST REAL INPUT VECTOR -! B IS FIRST IMAGINARY INPUT VECTOR -! C IS FIRST REAL OUTPUT VECTOR -! D IS FIRST IMAGINARY OUTPUT VECTOR -! TRIGS IS PRECALCULATED TABLE OF SINES & COSINES -! INC1 IS ADDRESSING INCREMENT FOR A AND B -! INC2 IS ADDRESSING INCREMENT FOR C AND D -! INC3 IS ADDRESSING INCREMENT BETWEEN As & Bs -! INC4 IS ADDRESSING INCREMENT BETWEEN Cs & Ds -! LOT IS THE NUMBER OF VECTORS -! N IS LENGTH OF VECTORS -! IFAC IS CURRENT FACTOR OF N -! LA IS PRODUCT OF PREVIOUS FACTORS -! - real(kind=KIND(1.0)) SIN36, COS36, SIN72, COS72, SIN60 - DATA SIN36/0.587785252292473/,COS36/0.809016994374947/, - * SIN72/0.951056516295154/,COS72/0.309016994374947/, - * SIN60/0.866025403784437/ - integer M, IINK, JINK, JUMP, IBASE, JBASE, IGO, IA, JA, IB, JB - integer IC, JC, ID, JD, IE, JE - integer I, J, K, L, IJK, LA1, KB, KC, KD, KE - real(kind=KIND(1.0)) C1, S1, C2, S2, C3, S3, C4, S4 -! -!FPP$ NOVECTOR R - M=N/IFAC - IINK=M*INC1 - JINK=LA*INC2 - JUMP=(IFAC-1)*JINK - IBASE=0 - JBASE=0 - IGO=IFAC-1 - IF (IGO.GT.4) RETURN - GO TO (10,50,90,130),IGO -! -! CODING FOR FACTOR 2 -! - 10 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - DO 20 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 15 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=A(IA+I)-A(IB+I) - D(JB+J)=B(IA+I)-B(IB+I) - I=I+INC3 - J=J+INC4 - 15 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 20 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 40 K=LA1,M,LA - KB=K+K-2 - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - DO 30 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 25 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) - D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) - I=I+INC3 - J=J+INC4 - 25 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 30 CONTINUE - JBASE=JBASE+JUMP - 40 CONTINUE - RETURN -! -! CODING FOR FACTOR 3 -! - 50 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - DO 60 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 55 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))) - C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))) - D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))) - D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))) - I=I+INC3 - J=J+INC4 - 55 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 60 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 80 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - DO 70 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 65 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)= - * C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - D(JB+J)= - * S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - C(JC+J)= - * C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - D(JC+J)= - * S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - I=I+INC3 - J=J+INC4 - 65 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 70 CONTINUE - JBASE=JBASE+JUMP - 80 CONTINUE - RETURN -! -! CODING FOR FACTOR 4 -! - 90 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - DO 100 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 95 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) - C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) - C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) - D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) - D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) - I=I+INC3 - J=J+INC4 - 95 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 100 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 120 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - DO 110 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 105 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - C(JC+J)= - * C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - D(JC+J)= - * S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - C(JB+J)= - * C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - D(JB+J)= - * S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - C(JD+J)= - * C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - D(JD+J)= - * S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 105 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 110 CONTINUE - JBASE=JBASE+JUMP - 120 CONTINUE - RETURN -! -! CODING FOR FACTOR 5 -! - 130 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - IE=ID+IINK - JE=JD+JINK - DO 140 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 135 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 135 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 140 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 160 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - KE=KD+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - C4=TRIGS(KE+1) - S4=TRIGS(KE+2) - DO 150 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 145 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)= - * C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JB+J)= - * S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JE+J)= - * C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JE+J)= - * S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JC+J)= - * C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JC+J)= - * S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - C(JD+J)= - * C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JD+J)= - * S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - I=I+INC3 - J=J+INC4 - 145 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 150 CONTINUE - JBASE=JBASE+JUMP - 160 CONTINUE - RETURN - END - - subroutine sigtopl ( qprs,q,logpl,logp,im,jm,lm,undef ) -C*********************************************************************** -C -C PURPOSE -C To interpolate an arbitrary quantity from Model Vertical Grid to Pressure -C -C INPUT -C Q ..... Q (im,jm,lm) Arbitrary Quantity on Model Grid -C PKZ ... PKZ (im,jm,lm) Pressure to the Kappa at Model Levels (From Phillips) -C PKSRF . PKSRF(im,jm) Surface Pressure to the Kappa -C PTOP .. Pressure at Model Top -C P ..... Output Pressure Level (mb) -C IM .... Longitude Dimension of Input -C JM .... Latitude Dimension of Input -C LM .... Vertical Dimension of Input -C -C OUTPUT -C QPRS .. QPRS (im,jm) Arbitrary Quantity at Pressure p -C -C NOTE -C Quantity is interpolated Linear in P**Kappa. -C Between PTOP**Kappa and PKZ(1), quantity is extrapolated. -C Between PKSRF**Kappa and PKZ(LM), quantity is extrapolated. -C Undefined Model-Level quantities are not used. -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** -C - implicit none - integer i,j,l,im,jm,lm - - real qprs(im,jm) - real q (im,jm,lm) - real logpl(im,jm,lm) - - real undef - real logp,temp - -c Initialize to UNDEFINED -c ----------------------- - do i=1,im*jm - qprs(i,1) = undef - enddo - -c Interpolate to Pressure Between Model Levels -c -------------------------------------------- - do L=1,lm-1 - if( all( logpl(:,:,L )>logp ) ) exit - if( all( logpl(:,:,L+1) q2(im,kn) -C -C pe1: pressure at layer edges (from model top to bottom surface) -C in the original vertical coordinate -C pe2: pressure at layer edges (from model top to bottom surface) -C in the new vertical coordinate - - parameter (kmax = 200) - parameter (R3 = 1./3., R23 = 2./3.) - - real dp1(im,km), - & q1(im,km), q2(im,kn), - & pe1(im,km+1), pe2(im,kn+1) - integer kord - -C local work arrays - real a4(4,im,km) - - do k=1,km - do i=1,im - a4(1,i,k) = q1(i,k) - enddo - enddo - - call ppm2m(a4, dp1, im, km, iv, kord) - -C Lowest layer: constant distribution - do i=1, im - a4(2,i,km) = q1(i,km) - a4(3,i,km) = q1(i,km) - a4(4,i,km) = 0. - enddo - - do 5555 i=1,im - k0 = 1 - do 555 k=1,kn - - if(pe2(i,k+1) .le. pe1(i,1)) then -! Entire grid above old ptop - q2(i,k) = a4(2,i,1) - elseif(pe2(i,k) .ge. pe1(i,km+1)) then -! Entire grid below old ps - q2(i,k) = a4(3,i,km) - elseif(pe2(i,k ) .lt. pe1(i,1) .and. - & pe2(i,k+1) .gt. pe1(i,1)) then -! Part of the grid above ptop - q2(i,k) = a4(1,i,1) - else - - do 45 L=k0,km -! locate the top edge at pe2(i,k) - if( pe2(i,k) .ge. pe1(i,L) .and. - & pe2(i,k) .le. pe1(i,L+1) ) then - k0 = L - PL = (pe2(i,k)-pe1(i,L)) / dp1(i,L) - if(pe2(i,k+1) .le. pe1(i,L+1)) then - -! entire new grid is within the original grid - PR = (pe2(i,k+1)-pe1(i,L)) / dp1(i,L) - TT = R3*(PR*(PR+PL)+PL**2) - q2(i,k) = a4(2,i,L) + 0.5*(a4(4,i,L)+a4(3,i,L) - & - a4(2,i,L))*(PR+PL) - a4(4,i,L)*TT - goto 555 - else -! Fractional area... - delp = pe1(i,L+1) - pe2(i,k) - TT = R3*(1.+PL*(1.+PL)) - qsum = delp*(a4(2,i,L)+0.5*(a4(4,i,L)+ - & a4(3,i,L)-a4(2,i,L))*(1.+PL)-a4(4,i,L)*TT) - dpsum = delp - k1 = L + 1 - goto 111 - endif - endif -45 continue - -111 continue - do 55 L=k1,km - if( pe2(i,k+1) .gt. pe1(i,L+1) ) then - -! Whole layer.. - - qsum = qsum + dp1(i,L)*q1(i,L) - dpsum = dpsum + dp1(i,L) - else - delp = pe2(i,k+1)-pe1(i,L) - esl = delp / dp1(i,L) - qsum = qsum + delp * (a4(2,i,L)+0.5*esl* - & (a4(3,i,L)-a4(2,i,L)+a4(4,i,L)*(1.-r23*esl)) ) - dpsum = dpsum + delp - k0 = L - goto 123 - endif -55 continue - delp = pe2(i,k+1) - pe1(i,km+1) - if(delp .gt. 0.) then -! Extended below old ps - qsum = qsum + delp * a4(3,i,km) - dpsum = dpsum + delp - endif -123 q2(i,k) = qsum / dpsum - endif -555 continue -5555 continue - - return - end - -c****6***0*********0*********0*********0*********0*********0**********72 - subroutine ppm2m(a4,delp,im,km,iv,kord) -c****6***0*********0*********0*********0*********0*********0**********72 -c iv = 0: positive definite scalars -c iv = 1: others -c iv =-1: winds - - implicit none - - integer im, km, lmt, iv - integer kord - integer i, k, km1 - real a4(4,im,km), delp(im,km) - -c local arrays. - real dc(im,km),delq(im,km) - real h2(im,km) - real a1, a2, c1, c2, c3, d1, d2 - real qmax, qmin, cmax, cmin - real qm, dq, tmp - -C Local scalars: - real qmp - real lac - - km1 = km - 1 - - do 500 k=2,km - do 500 i=1,im - delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) -500 a4(4,i,k ) = delp(i,k-1) + delp(i,k) - - do 1220 k=2,km1 - do 1220 i=1,im - c1 = (delp(i,k-1)+0.5*delp(i,k))/a4(4,i,k+1) - c2 = (delp(i,k+1)+0.5*delp(i,k))/a4(4,i,k) - tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / - & (a4(4,i,k)+delp(i,k+1)) - qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k) - qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp) -1220 continue - -c****6***0*********0*********0*********0*********0*********0**********72 -c 4th order interpolation of the provisional cell edge value -c****6***0*********0*********0*********0*********0*********0**********72 - - do 12 k=3,km1 - do 12 i=1,im - c1 = delq(i,k-1)*delp(i,k-1) / a4(4,i,k) - a1 = a4(4,i,k-1) / (a4(4,i,k) + delp(i,k-1)) - a2 = a4(4,i,k+1) / (a4(4,i,k) + delp(i,k)) - a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(a4(4,i,k-1)+a4(4,i,k+1)) * - & ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - - & delp(i,k-1)*a1*dc(i,k ) ) -12 continue - -C Area preserving cubic with 2nd deriv. = 0 at the boundaries -C Top - do i=1,im - d1 = delp(i,1) - d2 = delp(i,2) - qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) - dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) - c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) - c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1) - a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2) - dc(i,1) = a4(1,i,1) - a4(2,i,1) -C No over- and undershoot condition - cmax = max(a4(1,i,1), a4(1,i,2)) - cmin = min(a4(1,i,1), a4(1,i,2)) - a4(2,i,2) = max(cmin,a4(2,i,2)) - a4(2,i,2) = min(cmax,a4(2,i,2)) - enddo - - if(iv == 0) then - do i=1,im - a4(2,i,1) = max(0.,a4(2,i,1)) - a4(2,i,2) = max(0.,a4(2,i,2)) - enddo - elseif(iv == -1) then - do i=1,im - if( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. - enddo - endif - -c****6***0*********0*********0*********0*********0*********0**********72 - -c Bottom -c Area preserving cubic with 2nd deriv. = 0 at the surface - do 15 i=1,im - d1 = delp(i,km) - d2 = delp(i,km1) - qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) - dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) - c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) - c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1) - a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km) - dc(i,km) = a4(3,i,km) - a4(1,i,km) -c****6***0*********0*********0*********0*********0*********0**********72 -c No over- and undershoot condition - cmax = max(a4(1,i,km), a4(1,i,km1)) - cmin = min(a4(1,i,km), a4(1,i,km1)) - a4(2,i,km) = max(cmin,a4(2,i,km)) - a4(2,i,km) = min(cmax,a4(2,i,km)) -c****6***0*********0*********0*********0*********0*********0**********72 -15 continue - - if(iv .eq. 0) then - do i=1,im - a4(2,i,km) = max(0.,a4(2,i,km)) - a4(3,i,km) = max(0.,a4(3,i,km)) - enddo - endif - - do 20 k=1,km1 - do 20 i=1,im - a4(3,i,k) = a4(2,i,k+1) -20 continue -c -c f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) -c - -c Top 2 and bottom 2 layers always use monotonic mapping - - do k=1,2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) - enddo - - if(kord == 7) then -c****6***0*********0*********0*********0*********0*********0**********72 -C Huynh's 2nd constraint -c****6***0*********0*********0*********0*********0*********0**********72 - do k=2, km1 - do i=1,im - h2(i,k) = delq(i,k) - delq(i,k-1) - enddo - enddo - - do 4000 k=3, km-2 - do 3000 i=1, im -C Right edges - qmp = a4(1,i,k) + 2.0*delq(i,k-1) - lac = a4(1,i,k) + 1.5*h2(i,k-1) + 0.5*delq(i,k-1) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax) -C Left edges - qmp = a4(1,i,k) - 2.0*delq(i,k) - lac = a4(1,i,k) + 1.5*h2(i,k+1) - 0.5*delq(i,k) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax) -C Recompute A6 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) -3000 continue -! Additional constraint to prevent negatives - if (iv == 0) then - call kmppm(dc(1,k),a4(1,1,k),im, 2) - endif -4000 continue - - else - - lmt = kord - 3 - lmt = max(0, lmt) - if (iv .eq. 0) lmt = min(2, lmt) - - do k=3, km-2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, lmt) - enddo - endif - - do 5000 k=km1,km - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) -5000 continue - - return - end - -c****6***0*********0*********0*********0*********0*********0**********72 - subroutine kmppm(dm, a4, km, lmt) -c****6***0*********0*********0*********0*********0*********0**********72 - implicit none - - real r12 - parameter (r12 = 1./12.) - - integer km, lmt - integer i - real a4(4,km),dm(km) - real da1, da2, a6da - real fmin - real qmp - - if (lmt .eq. 3) return -! Full constraint - - if(lmt .eq. 0) then - do 100 i=1,km - if(dm(i) .eq. 0.) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da .lt. -da2) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da .gt. da2) then - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif -100 continue - elseif (lmt .eq. 2) then -c Positive definite - -c Positive definite constraint - do 250 i=1,km - if(abs(a4(3,i)-a4(2,i)) .ge. -a4(4,i)) go to 250 - fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 - if(fmin.ge.0.) go to 250 - if(a4(1,i).lt.a4(3,i) .and. a4(1,i).lt.a4(2,i)) then - a4(3,i) = a4(1,i) - a4(2,i) = a4(1,i) - a4(4,i) = 0. - elseif(a4(3,i) .gt. a4(2,i)) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - else - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif -250 continue - - elseif (lmt == 1) then - -! Improved full monotonicity constraint (Lin) -! Note: no need to provide first guess of A6 <-- a4(4,i) - - do i=1, km - qmp = 2.*dm(i) - a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) - a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) - a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) ) - enddo - endif - - return - end - - subroutine hflip ( q,im,jm,lm ) - implicit none - integer im,jm,lm,i,j,L - real q(im,jm,lm),dum(im) - do L=1,lm - do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j,L) - dum(i+im/2) = q(i,j,L) - enddo - q(:,j,L) = dum(:) - enddo - enddo - return - end - - subroutine minmax (q,im,jm,lm,qmin,qmax,undef) - real q(im,jm,lm) - - qmin = undef - qmax = undef - do L=1,lm - do j=1,jm - do i=1,im - if( q(i,j,L).ne.undef ) then - qmin = q(i,j,L) - qmax = q(i,j,L) - exit - endif - enddo - enddo - enddo - - do L=1,lm - do j=1,jm - do i=1,im - if( q(i,j,L).ne.undef ) qmin = min( qmin,q(i,j,L) ) - if( q(i,j,L).ne.undef ) qmax = max( qmax,q(i,j,L) ) - enddo - enddo - enddo -! print *, 'L: ',L,' qmin: ',qmin,' qmax: ',qmax - return - end - diff --git a/GEOS_Util/post/ec_eta2fv.F b/GEOS_Util/post/ec_eta2fv.F deleted file mode 100644 index b5be3ac8..00000000 --- a/GEOS_Util/post/ec_eta2fv.F +++ /dev/null @@ -1,2887 +0,0 @@ - program main - use m_set_eta, only: set_eta - implicit none - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to create fv restarts from ECMWF ETA Files **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm,nq - real pbelow,pabove,ptop,pint - -c Set analysis, fvdas, date and time -c ---------------------------------- - character*1 hres - character*1 string(256), blank(256) - character*2 clm,cnhms - character*8 cnymd - - character*256 ana_data, fv_data, topog, fv_rst, tag, ext - data fv_rst /'gg2fv.rst.lcv.yyyymmdd_hhz.bin'/ - data blank /256*' '/ - - equivalence ( blank (01),tag ) - equivalence ( string(01),fv_rst) - equivalence ( string(15),cnymd ) - equivalence ( string(24),cnhms ) - - real :: kappa = 2.0/7.0 - logical :: add_ozone = .false. - - integer nymd,nhms - -c fv restart variables and topography -c ----------------------------------- - real, allocatable :: dp(:,:,:) - real, allocatable :: pl(:,:,:) - real, allocatable :: ple(:,:,:) - real, allocatable :: u(:,:,:) - real, allocatable :: v(:,:,:) - real, allocatable :: tv(:,:,:) - real, allocatable :: thv(:,:,:) - real, allocatable :: pke(:,:,:) - real, allocatable :: pk (:,:,:) - real, allocatable :: q(:,:,:,:) - real, allocatable :: phis(:,:) - real, allocatable :: ps(:,:) - - real, allocatable :: ak(:) - real, allocatable :: bk(:) - - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - integer timinc - real undef - -c Analysis variables -c ------------------ - real, allocatable :: phis_ana(:,:) - real, allocatable :: slp_ana(:,:) - real, allocatable :: ps_ana(:,:) - real, allocatable :: u_ana(:,:,:) - real, allocatable :: v_ana(:,:,:) - real, allocatable :: h_ana(:,:,:) - real, allocatable :: q_ana(:,:,:,:) - real, allocatable :: p_ana(:,:,:) - real, allocatable :: dp_ana(:,:,:) - real, allocatable :: t_ana(:,:,:) - integer ID,mlev,rc - integer imax,jmax,ntime,nvars,ngatts - integer ianal,imethod,igrid,irst - integer ks - - character*120, allocatable :: arg(:) - character*120 eta_fname - character*120 rs_fname - - logical :: agrid = .false. - logical :: dgrid = .false. - logical :: u_agrid = .false. - logical :: v_agrid = .false. - logical :: u_dgrid = .false. - logical :: v_dgrid = .false. - logical :: tvflag = .false. - logical :: thvflag = .false. - - logical ihavetv,agridw - integer precision - integer L,n,nargs,lrec - - character*256 ctlfile,format - integer imncep,jmncep,lmncep,nvncep - real uncep - - character*256, pointer :: names (:) - character*256, pointer :: descs (:) - integer, pointer :: lmvars(:) - real, pointer :: levs(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - -C ********************************************************************** -C **** Initialize Filenames, Methods, etc. **** -C ********************************************************************** - - nq = 2 ! 1:qv, 2:oz - mlev = -999 - pabove = 10.00 ! 10 mb - pbelow = 30.00 ! 30 mb - precision = 0 ! 32-bit - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-rslv' ) read(arg(n+1),600) hres,lm - if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1), * ) nymd - if( trim(arg(n)).eq.'-nhms' ) read(arg(n+1), * ) nhms - if( trim(arg(n)).eq.'-date' ) read(arg(n+1), * ) nymd - if( trim(arg(n)).eq.'-time' ) read(arg(n+1), * ) nhms - if( trim(arg(n)).eq.'-mlev' ) read(arg(n+1), * ) mlev - if( trim(arg(n)).eq.'-tag' ) tag = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ecmwf') ana_data = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ana' ) fv_data = trim(arg(n+1)) - if( trim(arg(n)).eq.'-eta' ) fv_data = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ozone') add_ozone = .true. - if( trim(arg(n)).eq.'-plow ') read(arg(n+1), * ) pbelow - if( trim(arg(n)).eq.'-phigh') read(arg(n+1), * ) pabove - enddo - - print * - print *, ' ECMWF filename: ',trim(ana_data) - print *, 'Background filename: ',trim( fv_data) - print *, ' Output Tag: ',trim( tag ) - print *, ' nymd: ',nymd - print *, ' nhms: ',nhms - if( mlev.ne.-999 ) print *, ' mlev: ',mlev - print * - print *, 'Blending between ',pbelow,' and ',pabove,' mb' - print * - - endif - pabove = pabove*100 - pbelow = pbelow*100 - - if( trim(tag).ne.'' ) tag = trim(tag) // '.' - n = index(trim(fv_data),'.',back=.true.) - ext = trim(fv_data(n+1:)) - -C ********************************************************************** -C **** Read Background/Analysis ETA File **** -C ********************************************************************** - - call gfio_open ( trim(fv_data),1,ID,rc ) - call gfio_diminquire ( ID,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - -c Check FVETA Variable Names -c -------------------------- - do n=1,nvars - if( trim(vname(n)).eq.'u' ) u_agrid = .true. - if( trim(vname(n)).eq.'v' ) v_agrid = .true. - if( trim(vname(n)).eq.'uwnd' ) u_dgrid = .true. - if( trim(vname(n)).eq.'vwnd' ) v_dgrid = .true. - if( trim(vname(n)).eq.'tv' ) tvflag = .true. - if( trim(vname(n)).eq.'theta' ) thvflag = .true. - enddo - agrid = u_agrid .and. v_agrid - dgrid = u_dgrid .and. v_dgrid - -c Allocate Space -c -------------- - allocate ( phis(im,jm) ) - - allocate ( ps(im,jm) ) - allocate ( dp(im,jm,lm) ) - allocate ( u(im,jm,lm) ) - allocate ( v(im,jm,lm) ) - allocate ( tv(im,jm,lm) ) - allocate ( thv(im,jm,lm) ) - allocate ( q(im,jm,lm,nq) ) - -c Read Variables -c -------------- - call gfio_getvar ( id,'phis' ,nymd,nhms,im,jm,0,1 ,phis,rc ) - call gfio_getvar ( id,'ps' ,nymd,nhms,im,jm,0,1 ,ps ,rc ) - call gfio_getvar ( id,'delp' ,nymd,nhms,im,jm,1,lm,dp ,rc ) - - if( agrid ) then - call gfio_getvar ( id,'u',nymd,nhms,im,jm,1,lm,u,rc ) - call gfio_getvar ( id,'v',nymd,nhms,im,jm,1,lm,v,rc ) - endif - - if( dgrid ) then - call gfio_getvar ( id,'uwnd',nymd,nhms,im,jm,1,lm,u,rc ) - call gfio_getvar ( id,'vwnd',nymd,nhms,im,jm,1,lm,v,rc ) - call dtoa ( u,u,im,jm,lm,2 ) - call dtoa ( v,v,im,jm,lm,1 ) - endif - - if( tvflag ) then - call gfio_getvar ( id,'tv',nymd,nhms,im,jm,1,lm,tv,rc ) - endif - - if( thvflag ) then - call gfio_getvar ( id,'theta',nymd,nhms,im,jm,1,lm,thv,rc ) - endif - - call gfio_getvar ( id,'sphu' ,nymd,nhms,im,jm,1,lm,q(1,1,1,1),rc ) - call gfio_getvar ( id,'ozone' ,nymd,nhms,im,jm,1,lm,q(1,1,1,2),rc ) -c call gfio_getvar ( id,'qltot' ,nymd,nhms,im,jm,1,lm,q(1,1,1,3),rc ) -c call gfio_getvar ( id,'qitot' ,nymd,nhms,im,jm,1,lm,q(1,1,1,4),rc ) - - call gfio_close ( id,rc ) - -! Construct Pressure Variables -! ---------------------------- - allocate ( ak(lm+1) ) - allocate ( bk(lm+1) ) - allocate ( ple(im,jm,lm+1) ) - - call set_eta ( lm,ks,ptop,pint,ak,bk ) - - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - -! Construct THV (if necessary) for REMAPPING -! ------------------------------------------ - if( tvflag .and. .not.thvflag ) then - allocate ( pk(im,jm,lm ) ) - allocate ( pke(im,jm,lm+1) ) - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - thv = tv/pk - endif - - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - 200 format(i8.8) - 300 format(i2.2) - 400 format('dset ^',a) - 600 format(a1,i2.2) - -C ********************************************************************** -C **** Add Climatological Ozone **** -C ********************************************************************** - -c Construct 3-D Ozone on FV Levels -c -------------------------------- - if( add_ozone ) then - allocate ( pl(im,jm,lm) ) - do L=lm,1,-1 - pl(:,:,L) = (ple(:,:,L+1)+ple(:,:,L))*0.5 - enddo - call get_ozone ( q(1,1,1,2),pl,im,jm,lm,nymd,nhms ) - deallocate ( pl ) - endif - -C ********************************************************************** -C **** Get ECMWF Data **** -C ********************************************************************** - - print *, 'Reading ECMWF Model Data for Date: ',nymd,' Time: ',nhms - - mlev = 91 -c call gfio_open ( trim(ana_data),1,ID,rc ) -c call gfio_diminquire ( ID,im,jm,mlev,ntime,nvars,ngatts,rc ) - - deallocate ( ak ) - deallocate ( bk ) - deallocate ( ple) - allocate ( ak(mlev+1) ) - allocate ( bk(mlev+1) ) - allocate ( ple(im,jm,mlev+1) ) - - allocate ( dp_ana(im,jm,mlev) ) - allocate ( u_ana(im,jm,mlev) ) - allocate ( v_ana(im,jm,mlev) ) - allocate ( t_ana(im,jm,mlev) ) - allocate ( q_ana(im,jm,mlev,nq) ) - allocate ( ps_ana(im,jm) ) - allocate (phis_ana(im,jm) ) - -#if 1 -c -c For some reason (?), we have to use the grads utility: writegrads.gs -c on the nc4 data generated by Dan (from GRIB) to remap the ECMWF YOTC data properly -c ---------------------------------------------------------------------------------- - open (55,file=trim(ana_data),form='unformatted',access='direct',recl=im*jm*4) - lrec = 1 - read (55,rec=lrec) phis_ana ; lrec = lrec+1 - read (55,rec=lrec) ps_ana ; lrec = lrec+1 - do L=1,mlev ; read (55,rec=lrec) q_ana(:,:,L,2) ; lrec = lrec+1 ; enddo - do L=1,mlev ; read (55,rec=lrec) q_ana(:,:,L,1) ; lrec = lrec+1 ; enddo - do L=1,mlev ; read (55,rec=lrec) t_ana(:,:,L) ; lrec = lrec+1 ; enddo - do L=1,mlev ; read (55,rec=lrec) u_ana(:,:,L) ; lrec = lrec+1 ; enddo - do L=1,mlev ; read (55,rec=lrec) v_ana(:,:,L) ; lrec = lrec+1 ; enddo - - call set_eta ( mlev,ks,ptop,pint,ak,bk ) - -c call gfio_getvar ( id,'phis',nymd,nhms,im,jm,0,1 ,phis_ana,rc ) -c call gfio_getvar ( id,'lnps',nymd,nhms,im,jm,0,1 , ps_ana,rc ) -c call gfio_getvar ( id,'u' ,nymd,nhms,im,jm,1,mlev, u_ana,rc ) -c call gfio_getvar ( id,'v' ,nymd,nhms,im,jm,1,mlev, v_ana,rc ) -c call gfio_getvar ( id,'t' ,nymd,nhms,im,jm,1,mlev, t_ana,rc ) -c call gfio_getvar ( id,'q' ,nymd,nhms,im,jm,1,mlev, q_ana(1,1,1,1),rc ) -c call gfio_getvar ( id,'oz' ,nymd,nhms,im,jm,1,mlev, q_ana(1,1,1,2),rc ) - -#else - -c Reading this data directly does not seem to work -c ------------------------------------------------ - call gfio_getvar ( id,'Geopotential' ,nymd,nhms,im,jm,0,1 ,phis_ana,rc ) - call gfio_getvar ( id,'Logarithm_of_surface_pressure',nymd,nhms,im,jm,0,1 , ps_ana,rc ) - call gfio_getvar ( id,'U_velocity' ,nymd,nhms,im,jm,1,mlev, u_ana,rc ) - call gfio_getvar ( id,'V_velocity' ,nymd,nhms,im,jm,1,mlev, v_ana,rc ) - call gfio_getvar ( id,'Temperature' ,nymd,nhms,im,jm,1,mlev, t_ana,rc ) - call gfio_getvar ( id,'Specific_humidity' ,nymd,nhms,im,jm,1,mlev, q_ana(1,1,1,1),rc ) - call gfio_getvar ( id,'Ozone_mass_mixing_ratio' ,nymd,nhms,im,jm,1,mlev, q_ana(1,1,1,2),rc ) - - call gfio_getrealatt ( id,'ak',mlev+1,ak,rc ) - call gfio_getrealatt ( id,'bk',mlev+1,bk,rc ) -#endif - - call hflip ( phis_ana,im,jm,1 ) - call hflip ( ps_ana,im,jm,1 ) - call hflip ( u_ana,im,jm,mlev ) - call hflip ( v_ana,im,jm,mlev ) - call hflip ( t_ana,im,jm,mlev ) - call hflip ( q_ana(1,1,1,1),im,jm,mlev ) - call hflip ( q_ana(1,1,1,2),im,jm,mlev ) - - ps_ana = exp( ps_ana ) - do L=1,mlev+1 - ple(:,:,L) = ak(L) + ps_ana(:,:)*bk(L) - enddo - do L=1,mlev - dp_ana(:,:,L) = ple(:,:,L+1)-ple(:,:,L) - enddo - -C ********************************************************************** -C **** Adjust fv Restart **** -C ********************************************************************** - - print *, 'Calling Remap' - call remap ( ps,dp,u,v,thv,q,phis,lm, - . ps_ana,dp_ana,u_ana,v_ana,t_ana,q_ana,phis_ana,mlev,im,jm,nq,pbelow,pabove ) - -C ********************************************************************** -C **** Write HDF Eta File **** -C ********************************************************************** - - call put_fvrst ( ps,dp,u,v,thv,q,phis, - . im,jm,lm,nq,nymd,nhms,tag,ext,lon(1), - . timinc,precision,dgrid,tvflag ) - - stop - end - - subroutine put_fvrst ( ps,dp,u,v,thv,q,phis, - . im,jm,lm,nq,nymd,nhms,tag,ext,lonbeg, - . timeinc,precision,dgrid,tvflag ) - use MAPL_BaseMod, only: MAPL_UNDEF - use m_set_eta, only: set_eta - implicit none - - integer im,jm,lm,nq,nymd,nhms - real phis(im,jm) - real ps(im,jm) - real dp(im,jm,lm) - real u(im,jm,lm) - real v(im,jm,lm) - real thv(im,jm,lm) - real q(im,jm,lm,nq) - logical dgrid,tvflag - integer timeinc - - real ple(im,jm,lm+1) - real pke(im,jm,lm+1) - real pk(im,jm,lm) - real tv(im,jm,lm) - real t(im,jm,lm) - real slp(im,jm) - - real lats(jm) - real lons(im) - real levs(lm) - real ak(lm+1) - real bk(lm+1) - - real rgas,rvap,eps,kappa,grav - real ptop,pint,dlon,dlat,pref,dpref(lm),undef,lonbeg - integer i,j,L,n,ks,rc - character*256 tag,ext,filename, fname - integer nvars,fid,precision,nstep,id - - character*256 levunits - character*256 title - character*256 source - character*256 contact - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - integer, allocatable :: lmvar(:) - real, allocatable :: v_range(:,:) - real, allocatable :: p_range(:,:) - - character*1 string(256) - character*2 cnhms - character*8 cnymd - equivalence ( string(01),filename ) - data filename /'gg2fv.eta.yyyymmdd_hhz'/ - equivalence ( string(11),cnymd ) - equivalence ( string(20),cnhms ) - - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - kappa = 2.0/7.0 - grav = 9.81 - nstep = 100 - - undef = MAPL_UNDEF - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - 200 format(i8.8) - 300 format(i2.2) - fname = trim(tag) // trim(filename) // '.' // trim(ext) - print *, 'Creating 32-bit eta file: ',trim(fname) - - call set_eta ( lm,ks,ptop,pint,ak,bk ) - -! Construct D-Grid Winds (if necessary) -! ------------------------------------- - if (dgrid) then - call atod ( u,u,im,jm,lm,2 ) - call atod ( v,v,im,jm,lm,1 ) - endif - -! Construct T, TV, and SLP -! ------------------------ - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - tv = thv*pk - - call get_slp ( ps,phis,slp,ple,pk,tv,rgas,grav,im,jm,lm ) - - t(:,:,:) = tv(:,:,:)/(1+eps*q(:,:,:,1)) - -c String and vars settings -c ------------------------ - title = 'FVGCM Dynamics State Vector (Hybrid Coordinates)' - source = 'Data Assimilation Office, NASA/GSFC' - contact = 'data@dao.gsfc.nasa.gov' - levunits = 'hPa' - - nvars = 10 - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - allocate ( v_range(2,nvars) ) - allocate ( p_range(2,nvars) ) - - id = 1 - vname(id) = 'phis' - vtitle(id) = 'Topography geopotential' - vunits(id) = 'meter2/sec2' - lmvar(id) = 0 - - id = id+1 - vname(id) = 'ps' - vtitle(id) = 'Surface Pressure' - vunits(id) = 'Pa' - lmvar(id) = 0 - - id = id+1 - vname(id) = 'slp' - vtitle(id) = 'Sea Level Pressure' - vunits(id) = 'Pa' - lmvar(id) = 0 - - id = id+1 - vname(id) = 'delp' - vtitle(id) = 'Pressure Thickness' - vunits(id) = 'Pa' - lmvar(id) = lm - - id = id+1 - if(dgrid)then - vname(id) = 'uwnd' - vtitle(id) = 'eastward_wind_on_native_D-Grid' - else - vname(id) = 'u' - vtitle(id) = 'eastward_wind' - endif - vunits(id) = 'm/s' - lmvar(id) = lm - - id = id+1 - if(dgrid)then - vname(id) = 'vwnd' - vtitle(id) = 'northward_wind_on_native_D-Grid' - else - vname(id) = 'v' - vtitle(id) = 'northward_wind' - endif - vunits(id) = 'm/s' - lmvar(id) = lm - - id = id+1 - vname(id) = 'tmpu' - vtitle(id) = 'Temperature' - vunits(id) = 'K' - lmvar(id) = lm - - id = id+1 - if (tvflag) then - vname(id) = 'tv' - vtitle(id) = 'air_virtual_temperature' - vunits(id) = 'K' - lmvar(id) = lm - else - vname(id) = 'theta' - vtitle(id) = 'Scaled Virtual Potential Temperature' - vunits(id) = 'K/Pa^kappa' - lmvar(id) = lm - endif - - id = id+1 - vname(id) = 'sphu' - vtitle(id) = 'Specific Humidity' - vunits(id) = 'kg/kg' - lmvar(id) = lm - - id = id+1 - vname(id) = 'ozone' - vtitle(id) = 'Ozone' - vunits(id) = 'ppmv' - lmvar(id) = lm - - v_range(:,:) = undef - p_range(:,:) = undef - -c Compute grid -c ------------ - dlon = 360.0/ im - dlat = 180.0/(jm-1) - - do j=1,jm - lats(j) = -90.0 + (j-1)*dlat - enddo - do i=1,im - lons(i) = lonbeg + (i-1)*dlon - enddo - do L=1,lm - dpref(L) = (ak(L+1)-ak(L)) + (bk(L+1)-bk(L))*98400.0 - enddo - pref = ptop + 0.5*dpref(1) - levs(1) = pref - do L=2,lm - pref = pref + 0.5*( dpref(L)+dpref(L-1) ) - levs(L) = pref - enddo - levs(:) = levs(:)/100 - -c Create GFIO file -c ---------------- - call GFIO_Create ( fname, title, source, contact, undef, - . im, jm, lm, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vname, vtitle, vunits, lmvar, - . v_range, p_range, precision, - . fid, rc ) -c Write GFIO data -c --------------- - call Gfio_putVar ( fid,vname(01),nymd,nhms,im,jm,0, 1,phis ,rc ) - call Gfio_putVar ( fid,vname(02),nymd,nhms,im,jm,0, 1,ps ,rc ) - call Gfio_putVar ( fid,vname(03),nymd,nhms,im,jm,0, 1,slp ,rc ) - call Gfio_putVar ( fid,vname(04),nymd,nhms,im,jm,1,lm,dp ,rc ) - call Gfio_putVar ( fid,vname(05),nymd,nhms,im,jm,1,lm,u ,rc ) - call Gfio_putVar ( fid,vname(06),nymd,nhms,im,jm,1,lm,v ,rc ) - call Gfio_putVar ( fid,vname(07),nymd,nhms,im,jm,1,lm,t ,rc ) - - if( tvflag ) then - call Gfio_putVar ( fid,vname(08),nymd,nhms,im,jm,1,lm,tv ,rc ) - else - call Gfio_putVar ( fid,vname(08),nymd,nhms,im,jm,1,lm,thv ,rc ) - endif - - do n=1,nq - call Gfio_putVar ( fid,vname(08+n),nymd,nhms,im,jm,1,lm,q(1,1,1,n),rc ) - enddo - -c Write GFIO global attributes -c ---------------------------- - call GFIO_PutRealAtt ( fid,'ptop', 1,ptop ,precision,rc ) - call GFIO_PutRealAtt ( fid,'pint', 1,pint ,precision,rc ) - call GFIO_PutIntAtt ( fid,'ks', 1,ks ,0 ,rc ) - call GFIO_PutRealAtt ( fid,'ak', lm+1,ak ,precision,rc ) - call GFIO_PutRealAtt ( fid,'bk', lm+1,bk ,precision,rc ) - call GFIO_PutIntAtt ( fid,'nstep', 1,nstep,0 ,rc ) - - call gfio_close ( fid,rc ) - return - end - - subroutine getfile ( ku,filename,irec ) - implicit none - character(len=*) filename - integer ku,irec - - if ( irec>0 ) then - - open (ku,file=trim(filename),form='unformatted',access='direct',recl=irec) - return - - else - - open (ku,file=trim(filename),form='unformatted',access='sequential',convert='big_endian') - read (ku, err=1001) ! Check for BIG_ENDIAN - - 5000 backspace(ku) - return - - 1001 close(ku) - print *, 'File: ',trim(filename) - print *, 'Failed to OPEN using BIG_ENDIAN, will try LITTLE_ENDIAN' - open (ku,file=trim(filename),form='unformatted',access='sequential',convert='little_endian') - read (ku, err=1002) ! Check for LITTLE_ENDIAN - goto 5000 - - 1002 continue - print *, 'ERROR!! File: ',trim(filename) - print *, 'ERROR!! is neither BIG nor LITTLE ENDIAN' - error stop 7 - - endif - end - - subroutine hflip ( q,im,jm,lm ) - implicit none - integer im,jm,lm,i,j,L - real*4 q(im,jm,lm),dum(im) - do L=1,lm - do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j,L) - dum(i+im/2) = q(i,j,L) - enddo - q(:,j,L) = dum(:) - enddo - enddo - return - end - - subroutine writit (q,im,jm,lm,ku) - real q (im,jm,lm) - real*4 q2(im,jm) - do L=lm,1,-1 - q2(:,:) = q(:,:,L) - write(ku) q2 - enddo - return - end - - subroutine qsat (tt,p,q,dqdt,ldqdt) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute Saturation Specific Humidity -C -C INPUT: -C ====== -C TT ......... Temperature (Kelvin) -C P .......... Pressure (mb) -C LDQDT ...... Logical Flag to compute QSAT Derivative -C -C OUTPUT: -C ======= -C Q .......... Saturation Specific Humidity -C DQDT ....... Saturation Specific Humidity Derivative wrt Temperature -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IMPLICIT NONE - REAL TT, P, Q, DQDT - LOGICAL LDQDT - REAL AIRMW, H2OMW - - PARAMETER ( AIRMW = 28.97 ) - PARAMETER ( H2OMW = 18.01 ) - - REAL ESFAC, ERFAC - PARAMETER ( ESFAC = H2OMW/AIRMW ) - PARAMETER ( ERFAC = (1.0-ESFAC)/ESFAC ) - - real aw0, aw1, aw2, aw3, aw4, aw5, aw6 - real bw0, bw1, bw2, bw3, bw4, bw5, bw6 - real ai0, ai1, ai2, ai3, ai4, ai5, ai6 - real bi0, bi1, bi2, bi3, bi4, bi5, bi6 - - real d0, d1, d2, d3, d4, d5, d6 - real e0, e1, e2, e3, e4, e5, e6 - real f0, f1, f2, f3, f4, f5, f6 - real g0, g1, g2, g3, g4, g5, g6 - -c ******************************************************** -c *** Polynomial Coefficients WRT Water (Lowe, 1977) **** -c *** (Valid +50 C to -50 C) **** -c ******************************************************** - - parameter ( aw0 = 6.107799961e+00 * esfac ) - parameter ( aw1 = 4.436518521e-01 * esfac ) - parameter ( aw2 = 1.428945805e-02 * esfac ) - parameter ( aw3 = 2.650648471e-04 * esfac ) - parameter ( aw4 = 3.031240396e-06 * esfac ) - parameter ( aw5 = 2.034080948e-08 * esfac ) - parameter ( aw6 = 6.136820929e-11 * esfac ) - - parameter ( bw0 = +4.438099984e-01 * esfac ) - parameter ( bw1 = +2.857002636e-02 * esfac ) - parameter ( bw2 = +7.938054040e-04 * esfac ) - parameter ( bw3 = +1.215215065e-05 * esfac ) - parameter ( bw4 = +1.036561403e-07 * esfac ) - parameter ( bw5 = +3.532421810e-10 * esfac ) - parameter ( bw6 = -7.090244804e-13 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice (Lowe, 1977) **** -c *** (Valid +0 C to -50 C) **** -c ******************************************************** - - parameter ( ai0 = +6.109177956e+00 * esfac ) - parameter ( ai1 = +5.034698970e-01 * esfac ) - parameter ( ai2 = +1.886013408e-02 * esfac ) - parameter ( ai3 = +4.176223716e-04 * esfac ) - parameter ( ai4 = +5.824720280e-06 * esfac ) - parameter ( ai5 = +4.838803174e-08 * esfac ) - parameter ( ai6 = +1.838826904e-10 * esfac ) - - parameter ( bi0 = +5.030305237e-01 * esfac ) - parameter ( bi1 = +3.773255020e-02 * esfac ) - parameter ( bi2 = +1.267995369e-03 * esfac ) - parameter ( bi3 = +2.477563108e-05 * esfac ) - parameter ( bi4 = +3.005693132e-07 * esfac ) - parameter ( bi5 = +2.158542548e-09 * esfac ) - parameter ( bi6 = +7.131097725e-12 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -40 C to -70 C) **** -c ******************************************************** - - - parameter ( d0 = 0.535098336e+01 * esfac ) - parameter ( d1 = 0.401390832e+00 * esfac ) - parameter ( d2 = 0.129690326e-01 * esfac ) - parameter ( d3 = 0.230325039e-03 * esfac ) - parameter ( d4 = 0.236279781e-05 * esfac ) - parameter ( d5 = 0.132243858e-07 * esfac ) - parameter ( d6 = 0.314296723e-10 * esfac ) - - parameter ( e0 = 0.469290530e+00 * esfac ) - parameter ( e1 = 0.333092511e-01 * esfac ) - parameter ( e2 = 0.102164528e-02 * esfac ) - parameter ( e3 = 0.172979242e-04 * esfac ) - parameter ( e4 = 0.170017544e-06 * esfac ) - parameter ( e5 = 0.916466531e-09 * esfac ) - parameter ( e6 = 0.210844486e-11 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -65 C to -95 C) **** -c ******************************************************** - - parameter ( f0 = 0.298152339e+01 * esfac ) - parameter ( f1 = 0.191372282e+00 * esfac ) - parameter ( f2 = 0.517609116e-02 * esfac ) - parameter ( f3 = 0.754129933e-04 * esfac ) - parameter ( f4 = 0.623439266e-06 * esfac ) - parameter ( f5 = 0.276961083e-08 * esfac ) - parameter ( f6 = 0.516000335e-11 * esfac ) - - parameter ( g0 = 0.312654072e+00 * esfac ) - parameter ( g1 = 0.195789002e-01 * esfac ) - parameter ( g2 = 0.517837908e-03 * esfac ) - parameter ( g3 = 0.739410547e-05 * esfac ) - parameter ( g4 = 0.600331350e-07 * esfac ) - parameter ( g5 = 0.262430726e-09 * esfac ) - parameter ( g6 = 0.481960676e-12 * esfac ) - - REAL TMAX, TICE - PARAMETER ( TMAX=323.15, TICE=273.16) - - REAL T, D, W, QX, DQX - T = MIN(TT,TMAX) - TICE - DQX = 0. - QX = 0. - -c Fitting for temperatures above 0 degrees centigrade -c --------------------------------------------------- - if(t.gt.0.) then - qx = aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6))))) - if (ldqdt) then - dqx = bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6))))) - endif - endif - -c Fitting for temperatures between 0 and -40 -c ------------------------------------------ - if( t.le.0. .and. t.gt.-40.0 ) then - w = (40.0 + t)/40.0 - qx = w *(aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6)))))) - . + (1.-w)*(ai0+T*(ai1+T*(ai2+T*(ai3+T*(ai4+T*(ai5+T*ai6)))))) - if (ldqdt) then - dqx = w *(bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6)))))) - . + (1.-w)*(bi0+T*(bi1+T*(bi2+T*(bi3+T*(bi4+T*(bi5+T*bi6)))))) - endif - endif - -c Fitting for temperatures between -40 and -70 -c -------------------------------------------- - if( t.le.-40.0 .and. t.ge.-70.0 ) then - qx = d0+T*(d1+T*(d2+T*(d3+T*(d4+T*(d5+T*d6))))) - if (ldqdt) then - dqx = e0+T*(e1+T*(e2+T*(e3+T*(e4+T*(e5+T*e6))))) - endif - endif - -c Fitting for temperatures less than -70 -c -------------------------------------- - if(t.lt.-70.0) then - qx = f0+t*(f1+t*(f2+t*(f3+t*(f4+t*(f5+t*f6))))) - if (ldqdt) then - dqx = g0+t*(g1+t*(g2+t*(g3+t*(g4+t*(g5+t*g6))))) - endif - endif - -c Compute Saturation Specific Humidity -c ------------------------------------ - D = (P-ERFAC*QX) - IF(D.LT.0.) THEN - Q = 1.0 - IF (LDQDT) DQDT = 0. - ELSE - D = 1.0 / D - Q = MIN(QX * D,1.0) - IF (LDQDT) DQDT = (1.0 + ERFAC*Q) * D * DQX - ENDIF - RETURN - END - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*undef - return - end - - subroutine getchar (name,num) - character*2 num2 - character*3 num3 - integer num - character*1 junk(256) - character*1 name(256) - data junk /256*' '/ - equivalence ( num2,junk ) - equivalence ( num3,junk ) - - num2 = ' ' - num3 = ' ' - - if( num.lt.100 ) then - write(num2,102) num - else if( num.lt.1000 ) then - write(num3,103) num - endif - - name = junk - - 102 format(i2.2) - 103 format(i3.3) - - return - end - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end - - function nsecf2 (nhhmmss,nmmdd,nymd) -C*********************************************************************** -C Purpose -C Computes the Total Number of seconds from NYMD using NHHMMSS & NMMDD -C -C Arguments Description -C NHHMMSS IntervaL Frequency (HHMMSS) -C NMMDD Interval Frequency (MMDD) -C NYMD Current Date (YYMMDD) -C -C NOTE: -C IF (NMMDD.ne.0), THEN HOUR FREQUENCY HH MUST BE < 24 -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - PARAMETER ( NSDAY = 86400 ) - PARAMETER ( NCYCLE = 1461*24*3600 ) - - INTEGER YEAR, DAY, SEC, YEAR0, DAY0, SEC0 - - DIMENSION MNDY(12,4) - DATA MNDY /0,31,60,91,121,152,182,213,244,274,305,335,366, - . 397,34*0 / - -C*********************************************************************** -C* COMPUTE # OF SECONDS FROM NHHMMSS * -C*********************************************************************** - - nsecf2 = nsecf( nhhmmss ) - - if( nmmdd.eq.0 ) return - -C*********************************************************************** -C* COMPUTE # OF DAYS IN A 4-YEAR CYCLE * -C*********************************************************************** - - DO 100 I=15,48 - MNDY(I,1) = MNDY(I-12,1) + 365 -100 CONTINUE - -C*********************************************************************** -C* COMPUTE # OF SECONDS FROM NMMDD * -C*********************************************************************** - - nsegm = nmmdd/100 - nsegd = mod(nmmdd,100) - - YEAR = NYMD / 10000 - MONTH = MOD(NYMD,10000) / 100 - DAY = MOD(NYMD,100) - SEC = NSECF(NHMS) - - IDAY = MNDY( MONTH ,MOD(YEAR ,4)+1 ) - month = month + nsegm - If( month.gt.12 ) then - month = month - 12 - year = year + 1 - endif - IDAY2 = MNDY( MONTH ,MOD(YEAR ,4)+1 ) - - nday = iday2-iday - if(nday.lt.0) nday = nday + 1461 - nday = nday + nsegd - - nsecf2 = nsecf2 + nday*nsday - - return - end - - subroutine remap ( ps1,dp1,u1,v1,thv1,q1,phis1,lm1, - . ps2,dp2,u2,v2,t2 ,q2,phis2,lm2,im,jm,nq,pbelow,pabove ) - -C*********************************************************************** -C -C Purpose -C Driver for remapping of target analysis to fv model levels -C -C Argument Description -C ps1 ...... model surface pressure -C dp1 ...... model pressure thickness -C u1 ....... model zonal wind -C v1 ....... model meridional wind -C thv1 ..... model virtual potential temperature -C q1 ....... model specific humidity -C oz1 ...... model ozone -C phis1 .... model surface geopotential -C lm1 ...... model vertical dimension -C -C ps2 ...... analysis surface pressure -C dp2 ...... analysis pressure thickness -C u2 ....... analysis zonal wind -C v2 ....... analysis meridional wind -C t2 . ..... analysis dry-bulb temperature -C q2 ....... analysis specific humidity -C oz2 ...... analysis ozone -C phis2 .... analysis surface geopotential -C lm2 ...... analysis vertical dimension -C -C im ....... zonal dimension -C jm ....... meridional dimension -C nq ....... number of trancers -C pbelow ... pressure below which analysis is used completely -C pabove ... pressure above which model is used completely -C Note: a blend is used in-between pbelow and pabove -C If pbelow=pabove, blending code is disabled -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - integer im,jm,nq,lm1,lm2 - -c fv-DAS variables -c ---------------- - real dp1(im,jm,lm1), dp0(im,jm,lm1) - real u1(im,jm,lm1), u0(im,jm,lm1) - real v1(im,jm,lm1), v0(im,jm,lm1) - real thv1(im,jm,lm1), thv0(im,jm,lm1) - real q1(im,jm,lm1,nq), q0(im,jm,lm1,nq) - real ps1(im,jm), ps0(im,jm) - - real phis1(im,jm) - real ak(lm1+1) - real bk(lm1+1) - -c Target analysis variables -c ------------------------- - real dp2(im,jm,lm2) - real u2(im,jm,lm2) - real v2(im,jm,lm2) - real t2(im,jm,lm2) - real thv2(im,jm,lm2) - real q2(im,jm,lm2,nq) - real ps2(im,jm) - real phis2(im,jm) - -c Local variables -c --------------- - real pe0(im,jm,lm1+1) - real pe1(im,jm,lm1+1) - real pe2(im,jm,lm2+1) - real pk (im,jm,lm2 ) - real pke0(im,jm,lm1+1) - real pke1(im,jm,lm1+1) - real pke2(im,jm,lm2+1) - real phi2(im,jm,lm2+1) - - real kappa,cp,ptop,pbelow,pabove,pl,alf,pint - real rgas,pref,tref,pkref,tstar,eps,rvap,grav - integer i,j,L,n,ks - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - - call set_eta ( lm1,ks,ptop,pint,ak,bk ) - -c Compute edge-level pressures -c ---------------------------- - pe1(:,:,lm1+1) = ps1(:,:) - do L=lm1,1,-1 - pe1(:,:,L) = pe1(:,:,L+1)-dp1(:,:,L) - enddo - -c Copy input fv state into local variables -c ---------------------------------------- - ps0(:,:) = ps1(:,:) - dp0(:,:,:) = dp1(:,:,:) - u0(:,:,:) = u1(:,:,:) - v0(:,:,:) = v1(:,:,:) - thv0(:,:,:) = thv1(:,:,:) - q0(:,:,:,:) = q1(:,:,:,:) - pe0(:,:,:) = pe1(:,:,:) - pke0(:,:,:) = pe0(:,:,:)**kappa - -c Construct target analysis pressure variables -c -------------------------------------------- - do j=1,jm - do i=1,im - pe2(i,j,lm2+1) = ps2(i,j) - enddo - enddo - - do L=lm2,1,-1 - do j=1,jm - do i=1,im - pe2(i,j,L) = pe2(i,j,L+1) - dp2(i,j,L) - enddo - enddo - enddo - - do j=1,jm - do i=1,im - pe2(i,j,1) = 1.0 ! Set ptop = 0.01 mb (rather than 0.0 mb) - enddo - enddo - - do L=1,lm2+1 - do j=1,jm - do i=1,im - pke2(i,j,L) = pe2(i,j,L)**kappa - enddo - enddo - enddo - -c Construct target virtual potential temperature -c ---------------------------------------------- - do L=1,lm2 - do j=1,jm - do i=1,im - pk (i,j,L) = ( pke2(i,j,L+1)-pke2(i,j,L) )/( kappa*log(pe2(i,j,L+1)/pe2(i,j,L)) ) - thv2(i,j,L) = t2(i,j,L)*( 1.0+eps*max(0.0,q2(i,j,L,1)) )/pk(i,j,L) - enddo - enddo - enddo - -c Construct target analysis heights -c --------------------------------- - phi2(:,:,lm2+1) = phis2(:,:) - do L=lm2,1,-1 - phi2(:,:,L) = phi2(:,:,L+1) + cp*thv2(:,:,L)*( pke2(:,:,L+1)-pke2(:,:,L) ) - enddo - -c Compute new surface pressure consistent with fv topography -c ---------------------------------------------------------- - do j=1,jm - do i=1,im - L = lm2 - do while ( phi2(i,j,L).lt.phis1(i,j) ) - L = L-1 - enddo - ps1(i,j) = pe2(i,j,L+1)*( 1+(phi2(i,j,L+1)-phis1(i,j))/(cp*thv2(i,j,L)*pke2(i,j,L+1)) )**(1.0/kappa) - enddo - enddo - -c Construct fv pressure variables using new surface pressure -c ---------------------------------------------------------- - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1(i,j,L) = ak(L) + bk(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -c Map original fv state onto new eta grid -c --------------------------------------- - print *, ' ReMapping Original FV-State onto New Eta Grid' - call gmap ( im,jm,nq, kappa, - . lm1, pke0, pe0, u1, v1, thv1, q1, - . lm1, pke1, pe1, u0, v0, thv0, q0) - -c Map target analysis onto fv grid -c -------------------------------- - print *, ' Mapping ECMWF-State onto New Eta Grid' - call gmap ( im,jm,nq, kappa, - . lm2, pke2, pe2, u2, v2, thv2, q2, - . lm1, pke1, pe1, u1, v1, thv1, q1) - -c Blend result with original fv state -c ----------------------------------- - if( pbelow.ne.pabove ) then - print *, ' Blending FV and ECMWF States' - do L=1,lm1 - do j=1,jm - do i=1,im - pl=0.5*(pe1(i,j,L+1)+pe1(i,j,L)) - alf=(pl-pabove)/(pbelow-pabove) - if( pl.lt.pabove ) then - u1(i,j,L) = u0(i,j,L) - v1(i,j,L) = v0(i,j,L) - thv1(i,j,L) = thv0(i,j,L) - else if( pl.lt.pbelow ) then - u1(i,j,L) = u1(i,j,L)*alf + u0(i,j,L)*(1-alf) - v1(i,j,L) = v1(i,j,L)*alf + v0(i,j,L)*(1-alf) - thv1(i,j,L) = thv1(i,j,L)*alf + thv0(i,j,L)*(1-alf) - endif - enddo - enddo - enddo - do n=1,nq - do L=1,lm1 - do j=1,jm - do i=1,im - pl=0.5*(pe1(i,j,L+1)+pe1(i,j,L)) - alf=(pl-pabove)/(pbelow-pabove) - if( pl.lt.pabove ) then - q1(i,j,L,n) = q0(i,j,L,n) - else if( pl.lt.pbelow ) then - q1(i,j,L,n) = q1(i,j,L,n)*alf + q0(i,j,L,n)*(1-alf) - endif - enddo - enddo - enddo - enddo - endif - - return - end - - subroutine gauss_lat_nmc(gaul,k) - implicit double precision (a-h,o-z) - dimension a(500) - real gaul(1) - save - esp=1.d-14 - c=(1.d0-(2.d0/3.14159265358979d0)**2)*0.25d0 - fk=k - kk=k/2 - call bsslz1(a,kk) - do 30 is=1,kk - xz=cos(a(is)/sqrt((fk+0.5d0)**2+c)) - iter=0 - 10 pkm2=1.d0 - pkm1=xz - iter=iter+1 - if(iter.gt.10) go to 70 - do 20 n=2,k - fn=n - pk=((2.d0*fn-1.d0)*xz*pkm1-(fn-1.d0)*pkm2)/fn - pkm2=pkm1 - 20 pkm1=pk - pkm1=pkm2 - pkmrk=(fk*(pkm1-xz*pk))/(1.d0-xz**2) - sp=pk/pkmrk - xz=xz-sp - avsp=abs(sp) - if(avsp.gt.esp) go to 10 - a(is)=xz - 30 continue - if(k.eq.kk*2) go to 50 - a(kk+1)=0.d0 - pk=2.d0/fk**2 - do 40 n=2,k,2 - fn=n - 40 pk=pk*fn**2/(fn-1.d0)**2 - 50 continue - do 60 n=1,kk - l=k+1-n - a(l)=-a(n) - 60 continue - radi=180./(4.*atan(1.)) - do 211 n=1,k - gaul(n)=acos(a(n))*radi-90.0 - 211 continue - return - 70 write(6,6000) - 6000 format(//5x,14herror in gauaw//) - stop - end - - subroutine bsslz1(bes,n) - implicit double precision (a-h,o-z) - dimension bes(n) - dimension bz(50) - data pi/3.14159265358979d0/ - data bz / 2.4048255577d0, 5.5200781103d0, - $ 8.6537279129d0,11.7915344391d0,14.9309177086d0,18.0710639679d0, - $ 21.2116366299d0,24.3524715308d0,27.4934791320d0,30.6346064684d0, - $ 33.7758202136d0,36.9170983537d0,40.0584257646d0,43.1997917132d0, - $ 46.3411883717d0,49.4826098974d0,52.6240518411d0,55.7655107550d0, - $ 58.9069839261d0,62.0484691902d0,65.1899648002d0,68.3314693299d0, - $ 71.4729816036d0,74.6145006437d0,77.7560256304d0,80.8975558711d0, - $ 84.0390907769d0,87.1806298436d0,90.3221726372d0,93.4637187819d0, - $ 96.6052679510d0,99.7468198587d0,102.888374254d0,106.029930916d0, - $ 109.171489649d0,112.313050280d0,115.454612653d0,118.596176630d0, - $ 121.737742088d0,124.879308913d0,128.020877005d0,131.162446275d0, - $ 134.304016638d0,137.445588020d0,140.587160352d0,143.728733573d0, - $ 146.870307625d0,150.011882457d0,153.153458019d0,156.295034268d0/ - nn=n - if(n.le.50) go to 12 - bes(50)=bz(50) - do 5 j=51,n - 5 bes(j)=bes(j-1)+pi - nn=49 - 12 do 15 j=1,nn - 15 bes(j)=bz(j) - return - end - - - subroutine get_ozone ( ozone,pl,im,jm,lm,nymd,nhms ) - implicit none - - integer nlats - integer nlevs - parameter ( nlats = 37 ) ! 37 Latitudes - parameter ( nlevs = 34 ) ! 34 Pressure Levels - - real o3(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - -c Input Variables -c --------------- - integer im,jm,lm,nymd,nhms - real ozone(im,jm,lm) - real pl(im,jm,lm) - -c Local Variables -c --------------- - real xlat(im,jm) - integer i,j,L,koz - - real voltomas - PARAMETER ( VOLTOMAS = 1.655E-6 ) - - koz = 40 - - do j=1,jm - do i=1,im - xlat(i,j) = -90. + (j-1)*180./(jm-1) - enddo - enddo - - call chemistry (koz,nymd,nhms,o3,lats,levs,nlats,nlevs) - call interp_oz (o3,lats,levs,nlats,nlevs,im*jm,xlat,lm,pl,ozone) - - ozone(:,:,:) = ozone(:,:,:) * VOLTOMAS - - return - end - - subroutine chemistry (koz,nymd,nhms,ozone,lats,levs,nlats,nlevs) -C*********************************************************************** -C PURPOSE -C Chemistry Model -C -C ARGUMENTS DESCRIPTION -C koz Unit to read Stratospheric Ozone -C kqz Unit to read Stratospheric Moisture -C nymd Current Date -C nhms Current Time -C -C chemistry .. Chemistry State Data Structure -C grid ....... Dynamics Grid Data Structure -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer koz - integer nymd,nhms - - integer nlats - integer nlevs - real ozone(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - real o3(nlats,nlevs,12) - -c Local Variables -c --------------- - integer j,L - integer nymd1,nhms1,nymd2,nhms2,ipls,imns - real facm,facp - -C ********************************************************************** -C **** Read Ozone and Moisture Data (12 Monthly Means) **** -C ********************************************************************** - - call read_oz (koz,o3,lats,levs,nlats,nlevs,12) - -C ********************************************************************** -C **** Update Chemistry State to Current Time **** -C ********************************************************************** - - call time_bound ( nymd,nhms, nymd1,nhms1, nymd2,nhms2, imns,ipls ) - call interp_time ( nymd,nhms, nymd1,nhms1, nymd2,nhms2, facm,facp ) - - do L = 1,nlevs - do j = 1,nlats - ozone(j,L) = o3(j,L,imns)*facm + o3(j,L,ipls)*facp - enddo - enddo - - return - end - - subroutine read_oz (ku,oz,lats,levs,nlat,nlev,ntime) -C*********************************************************************** -C PURPOSE -C To Read Ozone Value -C -C ARGUMENTS DESCRIPTION -C ku ...... Unit to Read Ozone Data -C oz ...... Ozone Data -C lats .... Ozone Data Latitudes (degrees) -C levs .... Ozone Data Levels (mb) -C nlat .... Number of ozone latitudes -C nlev .... Number of ozone levels -C ntime ... Number of ozone time values -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer ku,nlat,nlev,ntime - - real oz(nlat,nlev,ntime) - real*4 o3(nlat) - real lats(nlat) - real levs(nlev) - - integer time - integer lat - integer lev - integer nrec - - real plevs(34) - data plevs/ 0.003, 0.005, 0.007, 0.01, 0.015, 0.02, 0.03, 0.05, - . 0.07, 0.1, 0.15, 0.2, 0.3, 0.5, 0.7, 1.0, 1.5, 2.0, - . 3.0, 5.0, 7.0, 10.0, 15.0, 20.0, 30.0, 50.0, 70.0, - . 100.0, 150.0, 200.0, 300.0, 500.0, 700.0, 1000.0 / - - rewind ku - -c Set Ozone Data Latitudes -c ------------------------ - do lat = 1,nlat - lats(lat) = -90. + (lat-1)*5. - enddo - -c Set Ozone Data Levels -c ------------------------ - do lev = 1,nlev - levs(lev) = plevs(lev)*100 - enddo - -c Read Ozone Amounts by Month and Level -c ------------------------------------- - close (ku) - open (ku, file="/home/ltakacs/data/bcs/TSMo3.v02.gra", - . form='unformatted', access='direct', recl=nlat*4) - - do time=1,ntime - do lev=1,nlev - nrec = lev+(time-1)*nlev*2 ! Note: 2 quantities in Ozone Dataset - read(ku,rec=nrec) o3 - do lat=1,nlat - oz(lat,nlev-lev+1,time) = o3(lat) - enddo - enddo - enddo - - close (ku) - return - end - - subroutine interp_oz (ozone,lats,levs,nlats,nlevs,irun ,xlat,km,plevs,ozrad) - -c Declare Modules and Data Structures -c ----------------------------------- - implicit none - integer nlats,nlevs - real ozone(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - - integer irun,km - real xlat (irun) - real plevs (irun,km) - real ozrad (irun,km) - -c Local Variables -c --------------- - real zero,one,o3min - PARAMETER ( ZERO = 0.0 ) - PARAMETER ( ONE = 1.0 ) - PARAMETER ( O3MIN = 1.0E-10 ) - - integer i,k,L1,L2,LM,LP - integer jlat,jlatm,jlatp - real O3INT1(IRUN,nlevs) - real QPR1(IRUN), QPR2(IRUN), SLOPE(IRUN) - real PR1(IRUN), PR2(IRUN) - -C ********************************************************************** -C **** INTERPOLATE ozone data to model latitudes *** -C ********************************************************************** - - DO 32 K=1,nlevs - DO 34 I=1,IRUN - - DO 36 jlat = 1,nlats - IF( lats(jlat).gt.xlat(i) ) THEN - IF( jlat.EQ.1 ) THEN - jlatm = 1 - jlatp = 1 - slope(i) = zero - ELSE - jlatm = jlat-1 - jlatp = jlat - slope(i) = ( XLAT(I) -lats(jlat-1) ) - . / ( lats(jlat)-lats(jlat-1) ) - ENDIF - GOTO 37 - ENDIF - 36 CONTINUE - jlatm = nlats - jlatp = nlats - slope(i) = one - 37 CONTINUE - QPR1(I) = ozone(jlatm,k) - QPR2(I) = ozone(jlatp,k) - 34 CONTINUE - - DO 38 I=1,IRUN - o3int1(i,k) = qpr1(i) + slope(i)*( qpr2(i)-qpr1(i) ) - 38 CONTINUE - - 32 CONTINUE - -C ********************************************************************** -C **** INTERPOLATE latitude ozone data to model pressures *** -C ********************************************************************** - - DO 40 L2 = 1,km - - DO 44 I = 1,IRUN - DO 46 L1 = 1,nlevs - IF( levs(L1).GT.PLEVS(I,L2) ) THEN - IF( L1.EQ.1 ) THEN - LM = 1 - LP = 2 - ELSE - LM = L1-1 - LP = L1 - ENDIF - GOTO 47 - ENDIF - 46 CONTINUE - LM = nlevs-1 - LP = nlevs - 47 CONTINUE - PR1(I) = levs (LM) - PR2(I) = levs (LP) - QPR1(I) = O3INT1(I,LM) - QPR2(I) = O3INT1(I,LP) - 44 CONTINUE - - DO 48 I=1,IRUN - SLOPE(I) = ( QPR1(I)-QPR2(I) ) - . / ( PR1(I)- PR2(I) ) - ozrad(I,L2) = QPR2(I) + ( PLEVS(I,L2)-PR2(I) )*SLOPE(I) - - if( ozrad(i,l2).lt.o3min ) then - ozrad(i,l2) = o3min - endif - - 48 CONTINUE - 40 CONTINUE - - RETURN - END - - subroutine interp_time ( nymd ,nhms , - . nymd1,nhms1, nymd2,nhms2, fac1,fac2 ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute interpolation factors, fac1 & fac2, to be used in the -C calculation of the instantanious boundary conditions, ie: -C -C q(i,j) = fac1*q1(i,j) + fac2*q2(i,j) -C where: -C q(i,j) => Boundary Data valid at (nymd , nhms ) -C q1(i,j) => Boundary Data centered at (nymd1 , nhms1) -C q2(i,j) => Boundary Data centered at (nymd2 , nhms2) -C -C INPUT: -C ====== -C nymd : Date (yymmdd) of Current Timestep -C nhms : Time (hhmmss) of Current Timestep -C nymd1 : Date (yymmdd) of Boundary Data 1 -C nhms1 : Time (hhmmss) of Boundary Data 1 -C nymd2 : Date (yymmdd) of Boundary Data 2 -C nhms2 : Time (hhmmss) of Boundary Data 2 -C -C OUTPUT: -C ======= -C fac1 : Interpolation factor for Boundary Data 1 -C fac2 : Interpolation factor for Boundary Data 2 -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER YEAR , MONTH , DAY , SEC - INTEGER YEAR1, MONTH1, DAY1, SEC1 - INTEGER YEAR2, MONTH2, DAY2, SEC2 - - real fac1, fac2 - real time, time1, time2 - - INTEGER DAYSCY - PARAMETER (DAYSCY = 365*4+1) - - REAL MNDY(12,4) - - LOGICAL FIRST - DATA FIRST/.TRUE./ - - DATA MNDY /0,31,60,91,121,152,182,213,244,274,305,335,366, - . 397,34*0 / - -C*********************************************************************** -C* SET TIME BOUNDARIES * -C*********************************************************************** - - YEAR = NYMD / 10000 - MONTH = MOD(NYMD,10000) / 100 - DAY = MOD(NYMD,100) - SEC = NSECF(NHMS) - - YEAR1 = NYMD1 / 10000 - MONTH1 = MOD(NYMD1,10000) / 100 - DAY1 = MOD(NYMD1,100) - SEC1 = NSECF(NHMS1) - - YEAR2 = NYMD2 / 10000 - MONTH2 = MOD(NYMD2,10000) / 100 - DAY2 = MOD(NYMD2,100) - SEC2 = NSECF(NHMS2) - -C*********************************************************************** -C* COMPUTE DAYS IN 4-YEAR CYCLE * -C*********************************************************************** - - IF(FIRST) THEN - DO I=15,48 - MNDY(I,1) = MNDY(I-12,1) + 365 - ENDDO - FIRST=.FALSE. - ENDIF - -C*********************************************************************** -C* COMPUTE INTERPOLATION FACTORS * -C*********************************************************************** - - time = DAY + MNDY(MONTH ,MOD(YEAR ,4)+1) + float(sec )/86400. - time1 = DAY1 + MNDY(MONTH1,MOD(YEAR1,4)+1) + float(sec1)/86400. - time2 = DAY2 + MNDY(MONTH2,MOD(YEAR2,4)+1) + float(sec2)/86400. - - if( time .lt.time1 ) time = time + dayscy - if( time2.lt.time1 ) time2 = time2 + dayscy - - fac1 = (time2-time)/(time2-time1) - fac2 = (time-time1)/(time2-time1) - - RETURN - END - - subroutine time_bound ( nymd,nhms,nymd1,nhms1,nymd2,nhms2, imnm,imnp ) -C*********************************************************************** -C PURPOSE -C Compute Date and Time boundaries. -C -C ARGUMENTS DESCRIPTION -C nymd .... Current Date -C nhms .... Current Time -C nymd1 ... Previous Date Boundary -C nhms1 ... Previous Time Boundary -C nymd2 ... Subsequent Date Boundary -C nhms2 ... Subsequent Time Boundary -C -C imnm .... Previous Time Index for Interpolation -C imnp .... Subsequent Time Index for Interpolation -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer nymd,nhms, nymd1,nhms1, nymd2,nhms2 - -c Local Variables -c --------------- - integer month,day,nyear,midmon1,midmon,midmon2 - integer imnm,imnp - INTEGER DAYS(14), daysm, days0, daysp - DATA DAYS /31,31,28,31,30,31,30,31,31,30,31,30,31,31/ - - integer nmonf,ndayf,n - NMONF(N) = MOD(N,10000)/100 - NDAYF(N) = MOD(N,100) - -C********************************************************************* -C**** Find Proper Month and Time Boundaries for Climatological Data ** -C********************************************************************* - - MONTH = NMONF(NYMD) - DAY = NDAYF(NYMD) - - daysm = days(month ) - days0 = days(month+1) - daysp = days(month+2) - -c Check for Leap Year -c ------------------- - nyear = nymd/10000 - if( 4*(nyear/4).eq.nyear ) then - if( month.eq.3 ) daysm = daysm+1 - if( month.eq.2 ) days0 = days0+1 - if( month.eq.1 ) daysp = daysp+1 - endif - - MIDMON1 = daysm/2 + 1 - MIDMON = days0/2 + 1 - MIDMON2 = daysp/2 + 1 - - - IF(DAY.LT.MIDMON) THEN - imnm = month - imnp = month + 1 - nymd2 = (nymd/10000)*10000 + month*100 + midmon - nhms2 = 000000 - nymd1 = nymd2 - nhms1 = nhms2 - call tick ( nymd1,nhms1, -midmon *86400 ) - call tick ( nymd1,nhms1,-(daysm-midmon1)*86400 ) - ELSE - IMNM = MONTH + 1 - IMNP = MONTH + 2 - nymd1 = (nymd/10000)*10000 + month*100 + midmon - nhms1 = 000000 - nymd2 = nymd1 - nhms2 = nhms1 - call tick ( nymd2,nhms2,(days0-midmon)*86400 ) - call tick ( nymd2,nhms2, midmon2*86400 ) - ENDIF - -c ------------------------------------------------------------- -c Note: At this point, imnm & imnp range between 01-14, where -c 01 -> Previous years December -c 02-13 -> Current years January-December -c 14 -> Next years January -c ------------------------------------------------------------- - - imnm = imnm-1 - imnp = imnp-1 - - if( imnm.eq.0 ) imnm = 12 - if( imnp.eq.0 ) imnp = 12 - if( imnm.eq.13 ) imnm = 1 - if( imnp.eq.13 ) imnp = 1 - - return - end - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - END - - FUNCTION INCYMD (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - - RETURN - END - - subroutine usage() - print *, "Usage: " - print * - print *, " ec_eta2fv.x [-ecmwf ecmwf.data.nc4]" - print *, " [-ana fv.data.nc4]" - print *, " [-nymd nymd]" - print *, " [-nhms nhms]" - print *, " [-plow plow]" - print *, " [-phigh phigh]" - print *, " [-tag tag]" - print *, " [-ozone]" - print * - print *, "where:" - print * - print *, " -ecmwf ecmwf.data: Filename of ECMWF Model-level data" - print *, " -ana fv.data: Filename of GMAO Background Data (ana.eta format)" - print * - print *, " -plow plow: Pressure Level to begin blending" - print *, " -phigh phigh: Pressure Level to end blending" - print * - print *, " -nymd nymd: Desired date in yyyymmdd format" - print *, " -nhms nhms: Desired time in hhmmss format" - print * - print *, " -tag tag: Optional Prefix tag for output files" - print *, " -ozone Optional Flag to add ozone" - print * - error stop 7 - end - - subroutine interp_h ( q_cmp,im,jm,lm, - . dlam,dphi,rotation,tilt,precession, - . q_geo,irun,lon_geo,lat_geo, - . msgn,norder,check,undef ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C rotation ... Rotation parameter lam_np (Degrees) -C tilt ....... Rotation parameter phi_np (Degrees) -C precession . Rotation parameter lam_0 (Degrees) -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C msgn ....... Flag for scalar field ( msgn = 1 ) -C or vector component ( msgn = -1 ) -C norder ..... Order of Interpolation: Bi-Linear => abs(norder) = 1 -C Bi-Cubic => abs(norder) = 3 -C Note: If norder < 0, then check for positive definite -C check ...... Logical Flag to check for Undefined values -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun,norder,msgn - logical check - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - -c Local Variables -c --------------- - integer i,j,l,m,n - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - - integer ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1 - integer ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2 - integer jm2_for_jm2, jp1_for_jp1 - - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real, allocatable :: old_lon (:) - real, allocatable :: old_lat (:) - real, allocatable :: old_dlam(:) - real, allocatable :: old_dphi(:) - - real ux, ap1, ap0, am1, am2 - real uy, bp1, bp0, bm1, bm2 - - real lon_cmp(im) - real lat_cmp(jm) - real q_tmp(irun) - - real pi,cosnp,sinnp,p1,p2,p3,eps,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp,lam_np,phi_np,lam_0,eps_np - real rotation , tilt , precession - real lam_geo, lam_cmp - real phi_geo, phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - - logical compute_weights - real old_rotation - real old_tilt - real old_precession - data old_rotation /-999.9/ - data old_tilt /-999.9/ - data old_precession /-999.9/ - - parameter ( eps = 1.e-10 ) - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - if(.not.allocated(old_lon)) then - - allocate ( old_dlam(im) , old_dphi(jm) ) - allocate ( old_lon(irun) , old_lat(irun) ) - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - do i=1,irun - old_lon(i) = -999.9 - old_lat(i) = -999.9 - enddo - do i=1,im - old_dlam(i) = 0.0 - enddo - do j=1,jm - old_dphi(j) = 0.0 - enddo - - else - i = size (old_dlam) - j = size (old_dphi) - m = size (old_lon) - if(i.ne.im .or. j.ne.jm .or. m.ne.irun) then - deallocate ( old_dlam , old_dphi ) - deallocate ( old_lon , old_lat ) - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - allocate ( old_dlam(im) , old_dphi(jm) ) - allocate ( old_lon(irun) , old_lat(irun) ) - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - do i=1,irun - old_lon(i) = -999.9 - old_lat(i) = -999.9 - enddo - do i=1,im - old_dlam(i) = 0.0 - enddo - do j=1,jm - old_dphi(j) = 0.0 - enddo - endif - endif - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Check for Co-incident Grid-Point Latitude and Pole Locations -c ------------------------------------------------------------ - eps_np = 0.0 - do j=1,jm - phi_cmp = lat_cmp(j)*180./pi - if( abs( phi_cmp-tilt ).lt.1.e-3 ) eps_np = 1.e-3 - if( tilt+eps_np .gt. 90. ) eps_np = -1.e-3 - enddo - - lam_np = pi/180.*rotation - phi_np = pi/180.*(tilt+eps_np) - lam_0 = pi/180.*precession - - if( tilt.eq.90. ) then - cosnp = 0.0 - sinnp = 1.0 - else if(tilt.eq.-90.0) then - cosnp = 0.0 - sinnp =-1.0 - else - cosnp = cos(phi_np) - sinnp = sin(phi_np) - endif - -c Determine if Weights Need to be Updated -c --------------------------------------- - compute_weights = rotation.ne.old_rotation .or. - . tilt.ne.old_tilt .or. - . precession.ne.old_precession - - m = 1 - do while ( .not.compute_weights .and. m.le.irun ) - compute_weights = (lon_geo(m).ne.old_lon(m)) .or. - . (lat_geo(m).ne.old_lat(m)) - m = m+1 - enddo - i = 1 - do while ( .not.compute_weights .and. i.le.im ) - compute_weights = dlam(i).ne.old_dlam(i) - i = i+1 - enddo - j = 1 - do while ( .not.compute_weights .and. j.le.jm-1 ) - compute_weights = dphi(j).ne.old_dphi(j) - j = j+1 - enddo - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - if( compute_weights ) then - - old_rotation = rotation - old_tilt = tilt - old_precession = precession - -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (i,lam_geo,phi_geo,lam_cmp,phi_cmp,lam,phi) -!$omp& private (p1,p2,p3,d,icmp,jcmp,im1_cmp,jm1_cmp) -!$omp& private (lam_im2, lam_im1, lam_ip0, lam_ip1) -!$omp& private (phi_jm2, phi_jm1, phi_jp0, phi_jp1) -!$omp& private (ap1, ap0, am1, am2) -!$omp& private (bp1, bp0, bm1, bm2) -#endif - do i=1,irun - old_lon(i) = lon_geo(i) - old_lat(i) = lat_geo(i) - lam_geo = lon_geo(i) - phi_geo = lat_geo(i) - - p1 = cosnp*cos(phi_geo)*cos(lam_geo+lam_0-pi) - . + sin(phi_geo)*sinnp - p1 = min(p1, 1.0) - p1 = max(p1,-1.0) - phi_cmp = asin( p1 ) - - if( tilt.eq.90.0 .or. tilt.eq.-90.0 ) then - p2 = sinnp*cos(lam_geo+lam_0-pi) - else - p2 = sinnp*cos(phi_geo)*cos(lam_geo+lam_0-pi) - . - sin(phi_geo)*cosnp - p2 = p2 / max( cos(phi_cmp),eps ) - p2 = min(p2, 1.0) - p2 = max(p2,-1.0) - endif - p2 = acos( p2 ) - - p3 = cos(phi_geo)*sin(lam_geo+lam_0-pi) - if( p3.lt.0.0 ) p2 = -p2 - p2 = p2 + lam_np - pi - lam_cmp = mod( p2+3.0*pi,2.0*pi ) - pi - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm2 = lat_cmp(jm2(i)) - phi_jm1 = lat_cmp(jm1(i)) - phi_jp0 = lat_cmp(jp0(i)) - phi_jp1 = lat_cmp(jp1(i)) - - if( jm2(i).eq.0 ) phi_jm2 = phi_jm1 - dphi(1) - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - endif - if( jp1(i).eq.jm+1 ) phi_jp1 = phi_jp0 + dphi(jm-1) - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - endif - -c Interpolate Computational-Grid Quantities to Geophysical Grid Using Bi-Linear -c ----------------------------------------------------------------------------- - if( abs(norder).eq.1 ) then - - if( check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,q_tmp) -#endif - do L=1,lm - do i=1,irun - - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - if( .not.check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,q_tmp) -#endif - do L=1,lm - do i=1,irun - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - endif ! End Check for Bi-Linear Interpolation - - -c Interpolate Computational-Grid Quantities to Geophysical Grid Using Bi-Cubic -c ---------------------------------------------------------------------------- - if( abs(norder).eq.3 ) then - - if( check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,m,n,q_tmp) -!$omp& private (ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1) -!$omp& private (ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2) -!$omp& private (jp1_for_jp1, jm2_for_jm2) -#endif - do L=1,lm - do i=1,irun - - ip1_for_jp1 = ip1(i) - ip0_for_jp1 = ip0(i) - im1_for_jp1 = im1(i) - im2_for_jp1 = im2(i) - jp1_for_jp1 = jp1(i) - m = 1 - - if( jp0(i).eq.jm ) then - ip1_for_jp1 = 1 + mod( ip1_for_jp1 + im/2 -1, im ) - ip0_for_jp1 = 1 + mod( ip0_for_jp1 + im/2 -1, im ) - im1_for_jp1 = 1 + mod( im1_for_jp1 + im/2 -1, im ) - im2_for_jp1 = 1 + mod( im2_for_jp1 + im/2 -1, im ) - jp1_for_jp1 = jm-1 - if(msgn.eq.-1) m=-1 - endif - - ip1_for_jm2 = ip1(i) - ip0_for_jm2 = ip0(i) - im1_for_jm2 = im1(i) - im2_for_jm2 = im2(i) - jm2_for_jm2 = jm2(i) - n = 1 - - if( jm1(i).eq.1 ) then - ip1_for_jm2 = 1 + mod( ip1_for_jm2 + im/2 -1, im ) - ip0_for_jm2 = 1 + mod( ip0_for_jm2 + im/2 -1, im ) - im1_for_jm2 = 1 + mod( im1_for_jm2 + im/2 -1, im ) - im2_for_jm2 = 1 + mod( im2_for_jm2 + im/2 -1, im ) - jm2_for_jm2 = 2 - if(msgn.eq.-1) n=-1 - endif - - - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1_for_jm2,jm2_for_jm2,L ).ne.undef .and. - . q_cmp( ip0_for_jm2,jm2_for_jm2,L ).ne.undef .and. - . q_cmp( im1_for_jm2,jm2_for_jm2,L ).ne.undef .and. - . q_cmp( im2_for_jm2,jm2_for_jm2,L ).ne.undef .and. - - . q_cmp( ip1_for_jp1,jp1_for_jp1,L ).ne.undef .and. - . q_cmp( ip0_for_jp1,jp1_for_jp1,L ).ne.undef .and. - . q_cmp( im1_for_jp1,jp1_for_jp1,L ).ne.undef .and. - . q_cmp( im2_for_jp1,jp1_for_jp1,L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1_for_jp1,jp1_for_jp1,L )*m - . + wc_ip0jp1(i) * q_cmp( ip0_for_jp1,jp1_for_jp1,L )*m - . + wc_im1jp1(i) * q_cmp( im1_for_jp1,jp1_for_jp1,L )*m - . + wc_im2jp1(i) * q_cmp( im2_for_jp1,jp1_for_jp1,L )*m - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1_for_jm2,jm2_for_jm2,L )*n - . + wc_ip0jm2(i) * q_cmp( ip0_for_jm2,jm2_for_jm2,L )*n - . + wc_im1jm2(i) * q_cmp( im1_for_jm2,jm2_for_jm2,L )*n - . + wc_im2jm2(i) * q_cmp( im2_for_jm2,jm2_for_jm2,L )*n - - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - enddo - -c Check for Positive Definite -c --------------------------- - if( norder.lt.0 ) then - do i=1,irun - if( q_tmp(i).ne.undef .and. - . q_tmp(i).lt.0.0 ) then - q_tmp(i) = 0.0 - endif - enddo - endif - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - if( .not.check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,m,n,q_tmp) -!$omp& private (ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1) -!$omp& private (ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2) -!$omp& private (jp1_for_jp1, jm2_for_jm2) -#endif - do L=1,lm - do i=1,irun - - ip1_for_jp1 = ip1(i) - ip0_for_jp1 = ip0(i) - im1_for_jp1 = im1(i) - im2_for_jp1 = im2(i) - jp1_for_jp1 = jp1(i) - m = 1 - - if( jp0(i).eq.jm ) then - ip1_for_jp1 = 1 + mod( ip1_for_jp1 + im/2 -1, im ) - ip0_for_jp1 = 1 + mod( ip0_for_jp1 + im/2 -1, im ) - im1_for_jp1 = 1 + mod( im1_for_jp1 + im/2 -1, im ) - im2_for_jp1 = 1 + mod( im2_for_jp1 + im/2 -1, im ) - jp1_for_jp1 = jm-1 - if(msgn.eq.-1) m=-1 - endif - - ip1_for_jm2 = ip1(i) - ip0_for_jm2 = ip0(i) - im1_for_jm2 = im1(i) - im2_for_jm2 = im2(i) - jm2_for_jm2 = jm2(i) - n = 1 - - if( jm1(i).eq.1 ) then - ip1_for_jm2 = 1 + mod( ip1_for_jm2 + im/2 -1, im ) - ip0_for_jm2 = 1 + mod( ip0_for_jm2 + im/2 -1, im ) - im1_for_jm2 = 1 + mod( im1_for_jm2 + im/2 -1, im ) - im2_for_jm2 = 1 + mod( im2_for_jm2 + im/2 -1, im ) - jm2_for_jm2 = 2 - if(msgn.eq.-1) n=-1 - endif - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1_for_jp1,jp1_for_jp1,L )*m - . + wc_ip0jp1(i) * q_cmp( ip0_for_jp1,jp1_for_jp1,L )*m - . + wc_im1jp1(i) * q_cmp( im1_for_jp1,jp1_for_jp1,L )*m - . + wc_im2jp1(i) * q_cmp( im2_for_jp1,jp1_for_jp1,L )*m - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1_for_jm2,jm2_for_jm2,L )*n - . + wc_ip0jm2(i) * q_cmp( ip0_for_jm2,jm2_for_jm2,L )*n - . + wc_im1jm2(i) * q_cmp( im1_for_jm2,jm2_for_jm2,L )*n - . + wc_im2jm2(i) * q_cmp( im2_for_jm2,jm2_for_jm2,L )*n - - enddo - -c Check for Positive Definite -c --------------------------- - if( norder.lt.0 ) then - do i=1,irun - if( q_tmp(i).ne.undef .and. - . q_tmp(i).lt.0.0 ) then - q_tmp(i) = 0.0 - endif - enddo - endif - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - endif ! End Check for Bi-Cubic Interpolation - - deallocate ( old_dlam , old_dphi ) - deallocate ( old_lon , old_lat ) - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - return - end - - subroutine get_slp ( ps,phis,slp,pe,pk,tv,rgas,grav,im,jm,km ) - implicit none - integer im,jm,km - real grav - real rgas - real pk(im,jm,km) ! layer-mean P**kappa - real tv(im,jm,km) ! layer-mean virtual Temperature - real pe(im,jm,km+1) ! press at layer edges (Pa) - real ps(im,jm) ! surface pressure (Pa) - real phis(im,jm) ! surface geopotential - real slp(im,jm) ! sea-level pressure (hPa) - - real p_offset - real p_bot - real tstar ! extrapolated temperature (K) - real tref ! Reference virtual temperature (K) - real pref ! Reference pressure level (Pa) - real pkref ! Reference pressure level (Pa) ** kappa - real dp1, dp2 - real factor, yfactor - real gg - real gamma - integer k_bot, k, k1, k2, i,j - - gamma = 6.5e-3 - gg = gamma / grav - factor = grav / ( Rgas * gamma ) - yfactor = Rgas * gg - p_offset = 15000. ! 150 hPa above surface - - do j=1,jm - do i=1,im - p_bot = ps(i,j) - p_offset - k_bot = -1 - do k = km, 2, -1 - if ( pe(i,j,k+1) .lt. p_bot ) then - k_bot = k - go to 123 - endif - enddo -123 continue - k1 = k_bot - 1 - k2 = k_bot - dp1 = pe(i,j,k_bot) - pe(i,j,k_bot-1) - dp2 = pe(i,j,k_bot+1) - pe(i,j,k_bot) - pkref = ( pk(i,j,k1)*dp1 + pk(i,j,k2)*dp2 ) / (dp1+dp2) - tref = ( tv(i,j,k1)*dp1 + tv(i,j,k2)*dp2 ) / (dp1+dp2) - pref = 0.5 * ( pe(i,j,k_bot+1) + pe(i,j,k_bot-1) ) - tstar = tref*( ps(i,j)/pref )**yfactor - slp(i,j) = ps(i,j)*( 1.0+gg*phis(i,j)/tstar )**factor - enddo - enddo - - return - end - -C ********************************************************************** -C **** Read Grads CTL File for Meta Data **** -C ********************************************************************** - - subroutine read_ctl ( ctlfile,im,jm,lm,undef,format, - . nvars,names,descs,lmvars, - . lats,lons,levs ) - implicit none - - character*256, pointer :: names(:) - character*256, pointer :: descs(:) - integer, pointer :: lmvars(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - real, pointer :: levs(:) - - character*256 ctlfile, format - integer im,jm,lm,nvars - real undef,dx,dy,dz - integer i,j,L,m,n,ndum - character*256 dummy,name - character*256, allocatable :: dum(:) - - open (10,file=trim(ctlfile),form='formatted') - format = 'direct' - do - read(10,*,end=500) dummy - -c OPTIONS -c ------- - if( trim(dummy).eq.'options' ) then - ndum = 1 - do - backspace(10) - allocate ( dum(ndum) ) - read(10,*,err=101) dummy - if( trim(dummy).eq.'options' ) then - backspace(10) - read(10,*,end=101) dummy,( dum(n),n=1,ndum ) - else - goto 101 - endif - if( trim(dum(ndum)).eq.'sequential' ) format = 'sequential' - deallocate ( dum ) - ndum = ndum + 1 - enddo - 100 format(a5) - 101 continue - deallocate ( dum ) - endif - -c XDEF -c ---- - if( trim(dummy).eq.'xdef' ) then - backspace(10) - read(10,*) dummy,im - allocate( lons(im) ) - backspace(10) - read(10,*) dummy,im,dummy,lons(1),dx - if( trim(dummy).eq.'linear' ) then - do i=2,im - lons(i) = lons(i-1) + dx - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lons(i),i=1,im) - endif - endif - -c YDEF -c ---- - if( trim(dummy).eq.'ydef' ) then - backspace(10) - read(10,*) dummy,jm - allocate( lats(jm) ) - backspace(10) - read(10,*) dummy,jm,dummy,lats(1),dy - if( trim(dummy).eq.'linear' ) then - do j=2,jm - lats(j) = lats(j-1) + dy - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lats(j),j=1,jm) - endif - endif - -c ZDEF -c ---- - if( trim(dummy).eq.'zdef' ) then - backspace(10) - read(10,*) dummy,lm -#if 0 - allocate( levs(lm) ) - backspace(10) - if( lm.eq.1 ) then - read(10,*) dummy,lm,dummy,levs(1) - else - read(10,*) dummy,lm,dummy,levs(1),dz - endif - if( trim(dummy).eq.'linear' ) then - do L=2,lm - levs(L) = levs(L-1) + dz - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(levs(L),L=1,lm) - endif -#endif - endif - -c UNDEF -c ----- - if( trim(dummy).eq.'undef' ) then - backspace(10) - read(10,*) dummy,undef - endif - - if( trim(dummy).eq.'vars' ) then - backspace(10) - read(10,*) dummy,nvars - allocate( names(nvars) ) - allocate( descs(nvars) ) - allocate( lmvars(nvars) ) - - do n=1,nvars - read(10,*) names(n),lmvars(n),m,descs(n) - if( lmvars(n).eq.0 ) lmvars(n) = 1 - enddo - - endif - enddo - 500 continue - rewind(10) - - if( nvars.eq.0 ) then - print *, 'Warning, nvars = 0!' - stop - endif - - return - end subroutine read_ctl diff --git a/GEOS_Util/post/ec_prs2eta.F b/GEOS_Util/post/ec_prs2eta.F deleted file mode 100644 index 849277c0..00000000 --- a/GEOS_Util/post/ec_prs2eta.F +++ /dev/null @@ -1,2126 +0,0 @@ - program main - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Create ECMWF ANA.ETA File from Pressure Level Data **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm,nq - real ptop,pint - real rgas,eps,rvap - real kappa - real grav - - integer niter,i0,j0 - parameter ( niter = 5 ) - -! GEOS Restart Variables -! ---------------------- - real, allocatable :: ak(:) - real, allocatable :: bk(:) - real, allocatable :: phis(:,:) - -c Set analysis, fvdas, date and time -c ---------------------------------- - character*2 cnhms - character*8 cnymd - - character*256 prsdata, tag, ext - - real :: phibg, phifg, thbr1, thbr2, delth, cp - - integer nymd,nhms - integer Lbeg,Lend - -c fv restart variables and topography -c ----------------------------------- - real, allocatable :: ps(:,:) - real, allocatable :: dp(:,:,:) - real, allocatable :: ple(:,:,:) - real, allocatable :: u(:,:,:) - real, allocatable :: v(:,:,:) - real, allocatable :: thv(:,:,:) - real, allocatable :: pke(:,:,:) - real, allocatable :: pk (:,:,:) - real, allocatable :: q(:,:,:) - - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - integer timinc - real undef - -c Analysis variables -c ------------------ - real, allocatable :: phis_ana(:,:) - real, allocatable :: ps_ana(:,:) - real, allocatable :: u_ana(:,:,:) - real, allocatable :: v_ana(:,:,:) - real, allocatable :: z_ana(:,:,:) - real, allocatable :: er_ana(:,:,:) - real, allocatable :: q_ana(:,:,:) - real, allocatable :: p_ana(:,:,:) - real, allocatable :: dp_ana(:,:,:) - real, allocatable :: pl_ana(:,:,:) - real, allocatable :: t_ana(:,:,:) - real, allocatable :: t_ec(:,:,:) - real, allocatable :: h_ana(:,:,:) - real, allocatable :: ple_ana(:,:,:) - real, allocatable :: logp (:,:,:) - real, allocatable :: logpl(:,:,:) - real, allocatable :: qdum (:,:,:) - integer id,rc - integer nvars, ngatts, ntime - - character*256, allocatable :: arg(:) - - integer precision - integer i,j,k,L,n,nargs,ks - logical gmaoprs - logical norecon - -c Analysis Grads CTL File Variables -c --------------------------------- - character*256 ctlfile - integer imana,jmana,lmana - - character*256, pointer :: names (:) - integer, pointer :: lmvars(:) - real, pointer :: plevs(:) - -C ********************************************************************** -C **** Initialize Filenames, Methods, etc. **** -C ********************************************************************** - - i0 = 0 - i0 = 0 - lm = 72 - im = -999 - jm = -999 - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - - precision = 0 ! 32-bit - ctlfile = 'xxx' - nymd = -999 - nhms = -999 - tag = '' - gmaoprs =.false. - norecon =.false. - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-ecmwf' ) prsdata = trim(arg(n+1)) - if( trim(arg(n)).eq.'-tag' ) tag = trim(arg(n+1)) - if( trim(arg(n)).eq.'-im' ) read(arg(n+1), * ) im - if( trim(arg(n)).eq.'-jm' ) read(arg(n+1), * ) jm - if( trim(arg(n)).eq.'-lm' ) read(arg(n+1), * ) lm - if( trim(arg(n)).eq.'-i0' ) read(arg(n+1), * ) i0 - if( trim(arg(n)).eq.'-j0' ) read(arg(n+1), * ) j0 - if( trim(arg(n)).eq.'-gmaoprs') gmaoprs =.true. - if( trim(arg(n)).eq.'-norecon') norecon =.true. - enddo - endif - - if( trim(tag).ne.'' ) tag = trim(tag) // '.' - ext = 'nc4' - - -C ********************************************************************** -C **** Read ANA MetaData **** -C ********************************************************************** - - call gfio_open ( trim(prsdata),1,id,rc ) - call gfio_diminquire ( id,imana,jmana,lmana,ntime,nvars,ngatts,rc ) - - if( im.eq.-999 ) im = imana - if( jm.eq.-999 ) jm = jmana - - allocate ( lon(imana) ) - allocate ( lat(jmana) ) - allocate ( lev(lmana) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,imana,jmana,lmana,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - - allocate ( plevs(lmana) ) - do L=1,lmana - plevs(L) = lev(lmana-L+1) - enddo - - print * - print *, ' ANA File: ',trim(prsdata) - print *, ' rslv: ',imana,jmana,lmana - print *, ' lon(1): ',lon(1)*180.0/3.14159 - print * - print *, ' Number of Variables: ',nvars - print * - do n=1,nvars - write(6,1001) n,trim(vname(n)),trim(vtitle(n)),kmvar(n) - enddo - 1001 format(1x,i2,3x,a16,2x,a32,2x,i3) - print * - L = 1 - print *, ' Pressure Levels: ',L,plevs(L) - do L=2,lmana - print *, ' ',L,plevs(L) - enddo - print * - - nymd = yymmdd(1) - nhms = hhmmss(1) - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - 200 format(i8.8) - 300 format(i2.2) - 400 format('dset ^',a) - 600 format(a1,i2.2) - -C ********************************************************************** -C **** Get Analysis **** -C ********************************************************************** - - allocate ( p_ana(im,jm,lmana) ) - allocate ( er_ana(im,jm,lmana) ) - allocate ( z_ana(im,jm,lmana) ) - allocate ( u_ana(im,jm,lmana) ) - allocate ( v_ana(im,jm,lmana) ) - allocate ( t_ana(im,jm,lmana) ) - allocate ( t_ec (im,jm,lmana) ) - allocate ( h_ana(im,jm,lmana) ) - allocate ( q_ana(im,jm,lmana) ) - allocate ( ps_ana(im,jm) ) - allocate (phis_ana(im,jm) ) - - - if ( gmaoprs ) then - print *, 'Reading G5-prs Analysis for Date: ',nymd,' Time: ',nhms - print * - call get_gmaoana_data ( id,ps_ana,u_ana,v_ana,t_ana,q_ana,h_ana,phis_ana, - . im,jm,lmana,nymd,nhms,lon(1), - . imana,jmana,lmana,nvars,names,lmvars,undef,plevs ) - else - print *, 'Reading EC-prs Analysis for Date: ',nymd,' Time: ',nhms - print * - call get_ana_data ( id,ps_ana,u_ana,v_ana,t_ana,q_ana,h_ana,phis_ana, - . im,jm,lmana,nymd,nhms, - . imana,jmana,lmana,undef,plevs ) - endif - t_ec = t_ana - -! Construct Pressure Variables -! ---------------------------- - allocate( dp_ana(im,jm,lm) ) - allocate( pl_ana(im,jm,lm) ) - allocate( ple_ana(im,jm,lm+1) ) - allocate( logp (im,jm,lm) ) - allocate( logpl(im,jm,lm) ) - - allocate( ak(lm+1) ) - allocate( bk(lm+1) ) - - call set_eta ( lm,ks,ptop,pint,ak,bk ) - - do L=1,lm+1 - ple_ana(:,:,L) = ak(L) + ps_ana(:,:)*bk(L) - enddo - do L=1,lm - dp_ana(:,:,L) = ple_ana(:,:,L+1)-ple_ana(:,:,L) - pl_ana(:,:,L) = 0.5*(ple_ana(:,:,L+1)+ple_ana(:,:,L)) - logp(:,:,L) = log( 0.5*(ple_ana(:,:,L+1)+ple_ana(:,:,L)) ) - enddo - - if( i0.ne.0 .and. j0.ne.0 ) then - print *, 'Sample ANA Data at GEOS-5 Location: (',i0,',',j0,')' - print *, ' ANA_PS: ',ps_ana(i0,j0)/100,' ANA_PHIS: ',phis_ana(i0,j0) - print *, ' ANA_UNDEF: ',undef - print *, ' ANA Temperature and Wind Profile:' - else - print *, 'Sample ANA Data:' - print *, ' ANA_PS: ',ps_ana(1,jm/2)/100,' ANA_PHIS: ',phis_ana(1,jm/2) - print *, ' ANA_UNDEF: ',undef - print *, ' ANA_Temperature and Wind Profile:' - endif - do L=1,lmana - p_ana(:,:,L) = 100.0*plevs(L) - logpl(:,:,L) = log( 100.0*plevs(L) ) - if( i0.ne.0 .and. j0.ne.0 ) then - print *, L,plevs(L),t_ana(i0,j0,L),u_ana(i0,j0,L) - else - print *, L,plevs(L),t_ana(1,jm/2,L),u_ana(1,jm/2,L) - endif - enddo - print * - - allocate ( qdum(im,jm,lm) ) - - call interp ( qdum,u_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'UWND',niter,i0,j0,1 ) - deallocate ( u_ana ) - allocate ( u_ana(im,jm,lm) ) - u_ana = qdum - - call interp ( qdum,v_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'VWND',niter,i0,j0,1 ) - deallocate ( v_ana ) - allocate ( v_ana(im,jm,lm) ) - v_ana = qdum - - call interp ( qdum,t_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'TMPU',niter,i0,j0,1 ) - deallocate ( t_ana ) - allocate ( t_ana(im,jm,lm) ) - t_ana = qdum - - call interp ( qdum,q_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'SPHU',niter,i0,j0,-1 ) - deallocate ( q_ana ) - allocate ( q_ana(im,jm,lm) ) - q_ana = qdum - -C ********************************************************************** -C **** Remap for Analysis **** -C ********************************************************************** - - allocate( phis(im,jm) ) - allocate( ps(im,jm) ) - allocate( dp(im,jm,lm) ) - allocate( u(im,jm,lm) ) - allocate( v(im,jm,lm) ) - allocate( q(im,jm,lm) ) - allocate( pk(im,jm,lm) ) - allocate( thv(im,jm,lm) ) - allocate( ple(im,jm,lm+1) ) - allocate( pke(im,jm,lm+1) ) - - ps = ps_ana - dp = dp_ana - phis = phis_ana - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'Before REMAP: ' - print *, 'GEOS5 PHIS/grav: ',phis(i0,j0)/grav,' ps: ',ps(i0,j0)/100 - print *, 'ANA PHIS/grav: ',phis_ana(i0,j0)/grav,' ps: ',ps_ana(i0,j0)/100 - print * - endif - - print *, 'Calling Remap' - call remap ( ps, dp, u, v, thv, q, lm, - . ps_ana,dp_ana,u_ana,v_ana,t_ana,q_ana,lm,im,jm,1 ) - print *, ' Fini Remap' - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'AFter REMAP: ' - print *, 'GEOS5 PHIS/grav: ',phis(i0,j0)/grav,' ps: ',ps(i0,j0)/100 - print *, 'ANA PHIS/grav: ',phis_ana(i0,j0)/grav,' ps: ',ps_ana(i0,j0)/100 - print * - endif - -C ********************************************************************** -C **** Reconcile Heights **** -C ********************************************************************** - - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - - if( .not.norecon ) then - do j=1,jm - do i=1,im - - Lbeg = lm - phifg = phis(i,j) - phibg = phifg - - do k=lmana,1,-1 - if( i.eq.i0 .and. j.eq.j0 ) then - write(6,5001) k,p_ana(i,j,k)/100,h_ana(i,j,k),t_ec(i,j,k) - 5001 format(1x,'k: ',i3,3x,'ANA_PMAN: ',f8.3,3x,'ANA_HGHT: ',f9.3,3x,'ANA_TMPU: ',f7.3) - endif - - if( p_ana(i,j,k).lt.ps(i,j) .and. ! p_ana is above GEOS Surface Pressure - . h_ana(i,j,k)-phibg/grav.gt.10.0 .and. ! h_ana is at least 10-meters above previous level - . h_ana(i,j,k)-phis_ana(i,j)/grav.gt.10.0 ) then ! h_ana is at least 10-meters above Topography - - if( i.eq.i0 .and. j.eq.j0 ) print * - - do L=Lbeg,1,-1 - if( ple(i,j,L).gt.p_ana(i,j,k) ) then - phifg = phifg + cp*thv(i,j,L)*( pke(i,j,L+1)-pke(i,j,L) ) - if( i.eq.i0 .and. j.eq.j0 ) then - write(6,5002) L,ple(i,j,L)/100,phifg/grav,thv(i,j,L)*pk(i,j,L) - 5002 format(1x,'L: ',i3,3x,' G5_PLE: ',f8.3,3x,'G5_HGHT: ',f9.3,3x,'G5_TMPU: ',f7.3) - endif - else - exit - endif - enddo - Lend = L - if( Lbeg-Lend.le.2 ) then - phifg = phibg - cycle - endif - - phifg = phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-p_ana(i,j,k)**kappa ) - - if( i.eq.i0 .and. j.eq.j0 ) then - print * - print *, ' Lbeg: ',Lbeg,' Lend: ',Lend,' ple(Lend): ',ple(i,j,Lend)/100 - print *, 'ANA_HGHT: ',h_ana(i,j,k),' G5_HGHT: ',phifg/grav,' G5_HGHT0: ',phibg/grav - print *, 'ANA_TMPU: ',t_ec (i,j,k),' G5_TMPU: ',thv(i,j,Lend)*pk(i,j,LEND) - endif - - thbr1 = ( grav*h_ana(i,j,k)-phibg )/( pke(i,j,Lbeg+1)-p_ana(i,j,k)**kappa )/cp - thbr2 = ( phifg -phibg )/( pke(i,j,Lbeg+1)-p_ana(i,j,k)**kappa )/cp - delth = thbr1-thbr2 - - if( i.eq.i0 .and. j.eq.j0 ) then - print *, 'ANA_THETA_BR: ',thbr1,' G5_THETA_BR: ',thbr2 - print *, ' ANA_T_TOP: ',thbr1*p_ana(i,j,k)**kappa,' G5_T_TOP: ',thbr2*p_ana(i,j,k)**kappa - print *, ' ANA_T_BOT: ',thbr1*pke(i,j,Lbeg+1),' G5_T_BOT: ',thbr2*pke(i,j,Lbeg+1) - endif - - do L=Lbeg,Lend,-1 - thv(i,j,L) = thv(i,j,L) + delth - enddo - - phifg = phibg - do L=Lbeg,Lend+1,-1 - phifg = phifg + cp*thv(i,j,L)*( pke(i,j,L+1)-pke(i,j,L) ) - enddo - - if( i.eq.i0 .and. j.eq.j0 ) print *, 'ANA_HGHT: ',h_ana(i,j,k),' G5_HGHT: ', - . (phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-p_ana(i,j,k)**kappa ))/grav - - phifg = phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-pke(i,j,Lend) ) - Lbeg = Lend-1 - phibg = phifg - endif - enddo - - enddo ! End I-Loop - enddo ! End J-Loop - endif ! End RECON Test - -C ********************************************************************** -C **** Write ECMWF ANA.ETA File **** -C ********************************************************************** - - nq = 1 - call put_fveta ( ps,dp,u,v,thv,q,phis, - . im,jm,lm,nq,nymd,nhms,tag,ext,lon(1), - . timinc,precision ) - - stop - end - - subroutine interp ( q,qana,logp,logpl,pana,pl,ple,im,jm,lm,lmana,undef,name,niter,i0,j0,flag ) - implicit none - integer im,jm,lm,lmana,niter,i0,j0,flag - real undef - real q (im,jm,lm) - real pl (im,jm,lm) - real ple (im,jm,lm+1) - real er (im,jm,lm) - real logp (im,jm,lm) - real pana (im,jm,lmana) - real qana (im,jm,lmana) - real zana (im,jm,lmana) - real erana(im,jm,lmana) - real logpl(im,jm,lmana) - character*4 name - - integer i,j,L,n - -c Interpolate Analysis to GEOS Model Levels -c ----------------------------------------- - do L=1,lm - do j=1,jm - do i=1,im - call sigtopl( q(i,j,L),qana(i,j,:),logpl(i,j,:),logp(i,j,L),1,1,lmana,undef ) - enddo - enddo - enddo - if( flag.eq.-1 ) then - q = max( q,0.0 ) - endif - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'Initial ANA ',trim(name),' Profile at GEOS-5 Levels:' - do L=1,lm - print *, L,exp(logp(i0,j0,L))/100.,q(i0,j0,L) - enddo - print * - else - print *, 'Interpolating ',trim(name),' ...' - endif - -#ifdef DEBUG - call writit (q,im,jm,lm,66) -#endif - do n=1,niter -c Interpolate GEOS Model Back to EC Levels and Compute Error -c ---------------------------------------------------------- - do L=1,lmana - do j=1,jm - do i=1,im - call sigtopl( zana(i,j,L),q(i,j,:),logp(i,j,:),logpl(i,j,L),1,1,lm,undef ) - erana(i,j,L) = zana(i,j,L)-qana(i,j,L) - enddo - enddo - enddo - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'ANA ',trim(name),' Profile Comparison, ITER: ',n - print *, '----------------------------------------------' - do L=1,lmana - print *, L,exp(logpl(i0,j0,L))/100.,zana(i0,j0,L),qana(i0,j0,L),erana(i0,j0,L) - enddo - print * - endif - -c Interpolate and Add Error to GEOS Model Levels -c ---------------------------------------------- - call interp3 ( erana,pana,im,jm,lmana, er,pl,lm,ple(1,1,lm+1) ) - q = q - er - if( flag.eq.-1 ) then - q = max( q,0.0 ) - endif -#ifdef DEBUG - call writit (q,im,jm,lm,66) -#endif - enddo - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'Final ANA ',trim(name),' Profile at GEOS-5 Levels:' - do L=1,lm - print *, L,exp(logp(i0,j0,L))/100.,q(i0,j0,L) - enddo - print * - endif - - return - end - - subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, - . im,jm,lm,nymd,nhms, - . imana,jmana,lmana,undef,plevs ) - use MAPL_ConstantsMod - implicit none - integer id,im,jm,lm,nymd,nhms,rc - integer imana,jmana,lmana - - real ps(im,jm) - real u(im,jm,lm) - real v(im,jm,lm) - real t(im,jm,lm) - real h(im,jm,lm) - real rh(im,jm,lm) - real q(im,jm,lm) - real phis(im,jm) - real plevs(lm) - real slp(im,jm) - - real, allocatable :: dum2d(:,:) - real, allocatable :: dum3d(:,:,:) - real, allocatable :: dumu (:,:,:) - real, allocatable :: dumv (:,:,:) - - real undef,kappa,grav,dum,beta,cp,rgas - integer L,i,j,LM1 - - allocate ( dum2d(imana,jmana) ) - allocate ( dum3d(imana,jmana,lmana) ) - allocate ( dumu (imana,jmana,lmana) ) - allocate ( dumv (imana,jmana,lmana) ) - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - grav = MAPL_GRAV - cp = MAPL_CP - beta = 6.5e-3 - -! Writing variable: Mean_sea_level_pressure -! Writing variable: Surface_pressure -! Writing variable: Total_cloud_cover -! Writing variable: Height -! Writing variable: Relative_humidity -! Writing variable: Temperature -! Writing variable: U_velocity -! Writing variable: V_velocity - -c Read ANA Variables -c ------------------ - call gfio_getvar ( id,'Mean_sea_level_pressure',nymd,nhms,imana,jmana,0,1 ,dum2d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF SLP variable' - error stop 7 - endif - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum2d,imana,jmana,slp,im,jm,1,undef ) - else - slp = dum2d - endif - - call gfio_getvar ( id,'Surface_pressure',nymd,nhms,imana,jmana,0,1 ,dum2d ,rc ) ! New ECMWF Format 2011/05/11 06z - if( rc.ne.0 ) then - call gfio_getvar ( id,'logarithm_of_su',nymd,nhms,imana,jmana,0,1 ,dum2d ,rc ) ! Old ECMWF Format - if( rc.eq.0 ) then - dum2d = exp(dum2d) - else - print *, 'Could not find ECMWF Surface Pressure variable' - error stop 7 - endif - endif - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum2d,imana,jmana,ps,im,jm,1,undef ) - else - ps = dum2d - endif - - call gfio_getvar ( id,'Height',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF Height variable' - error stop 7 - endif - call zflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,h,im,jm,lm,undef ) - else - h = dum3d - endif - -c Winds -c ----- - call gfio_getvar ( id,'U_velocity',nymd,nhms,imana,jmana,1,lmana,dumu,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF U-Wind variable' - error stop 7 - endif - call gfio_getvar ( id,'V_velocity',nymd,nhms,imana,jmana,1,lmana,dumv,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF V-Wind variable' - error stop 7 - endif - - call zflip( dumu,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dumu,imana,jmana,u,im,jm,lm,undef ) - else - u = dumu - endif - - call zflip( dumv,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dumv,imana,jmana,v,im,jm,lm,undef ) - else - v = dumv - endif - -c Temperature -c ----------- - call gfio_getvar ( id,'Temperature',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF Temperature variable' - error stop 7 - endif - call zflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,t,im,jm,lm,undef ) - else - t = dum3d - endif - -c Relative Humidity -c ----------------- - call gfio_getvar ( id,'Relative_humidity',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF Rel.Hum. variable' - error stop 7 - endif - call zflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,rh,im,jm,lm,undef ) - else - rh = dum3d - endif - rh = max( rh,0.0 ) - -c Compute PHIS -c ------------ - do j=1,jm - do i=1,im - L=1 - do while( L.lt.lm .and. plevs(L).lt.ps(i,j)/100.0 ) - L=L+1 - enddo - LM1 = L-1 - phis(i,j) = h(i,j,L) - ( h(i,j,L)-h(i,j,LM1) )*log( 100*plevs(L)/ps(i,j) )/log( plevs(L)/plevs(LM1) ) - enddo - enddo - phis = phis*grav - -c Load GMAO Variables -c ------------------- - do L=1,lm - do j=1,jm - do i=1,im - call qsat (t(i,j,L),plevs(L),q(i,j,L),dum,.false.) - q(i,j,L) = rh(i,j,L)*q(i,j,L)*0.01 - enddo - enddo - enddo - - return - end - - subroutine hflip ( q,im,jm,lm ) - implicit none - integer im,jm,lm,i,j,L - real*4 q(im,jm,lm),dum(im) - do L=1,lm - do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j,L) - dum(i+im/2) = q(i,j,L) - enddo - q(:,j,L) = dum(:) - enddo - enddo - return - end - - subroutine zflip ( q,im,jm,lm ) - implicit none - integer im,jm,lm,L - real*4 q(im,jm,lm),dum(im,jm,lm) - dum = q - do L=1,lm - q(:,:,L) = dum(:,:,lm+1-L) - enddo - return - end - - subroutine writit (q,im,jm,lm,ku) - real q (im,jm,lm) - real*4 q2(im,jm) - do L=lm,1,-1 - q2(:,:) = q(:,:,L) - write(ku) q2 - enddo - return - end - - subroutine qsat (tt,p,q,dqdt,ldqdt) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute Saturation Specific Humidity -C -C INPUT: -C ====== -C TT ......... Temperature (Kelvin) -C P .......... Pressure (mb) -C LDQDT ...... Logical Flag to compute QSAT Derivative -C -C OUTPUT: -C ======= -C Q .......... Saturation Specific Humidity -C DQDT ....... Saturation Specific Humidity Derivative wrt Temperature -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IMPLICIT NONE - REAL TT, P, Q, DQDT - LOGICAL LDQDT - REAL AIRMW, H2OMW - - PARAMETER ( AIRMW = 28.97 ) - PARAMETER ( H2OMW = 18.01 ) - - REAL ESFAC, ERFAC - PARAMETER ( ESFAC = H2OMW/AIRMW ) - PARAMETER ( ERFAC = (1.0-ESFAC)/ESFAC ) - - real aw0, aw1, aw2, aw3, aw4, aw5, aw6 - real bw0, bw1, bw2, bw3, bw4, bw5, bw6 - real ai0, ai1, ai2, ai3, ai4, ai5, ai6 - real bi0, bi1, bi2, bi3, bi4, bi5, bi6 - - real d0, d1, d2, d3, d4, d5, d6 - real e0, e1, e2, e3, e4, e5, e6 - real f0, f1, f2, f3, f4, f5, f6 - real g0, g1, g2, g3, g4, g5, g6 - -c ******************************************************** -c *** Polynomial Coefficients WRT Water (Lowe, 1977) **** -c *** (Valid +50 C to -50 C) **** -c ******************************************************** - - parameter ( aw0 = 6.107799961e+00 * esfac ) - parameter ( aw1 = 4.436518521e-01 * esfac ) - parameter ( aw2 = 1.428945805e-02 * esfac ) - parameter ( aw3 = 2.650648471e-04 * esfac ) - parameter ( aw4 = 3.031240396e-06 * esfac ) - parameter ( aw5 = 2.034080948e-08 * esfac ) - parameter ( aw6 = 6.136820929e-11 * esfac ) - - parameter ( bw0 = +4.438099984e-01 * esfac ) - parameter ( bw1 = +2.857002636e-02 * esfac ) - parameter ( bw2 = +7.938054040e-04 * esfac ) - parameter ( bw3 = +1.215215065e-05 * esfac ) - parameter ( bw4 = +1.036561403e-07 * esfac ) - parameter ( bw5 = +3.532421810e-10 * esfac ) - parameter ( bw6 = -7.090244804e-13 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice (Lowe, 1977) **** -c *** (Valid +0 C to -50 C) **** -c ******************************************************** - - parameter ( ai0 = +6.109177956e+00 * esfac ) - parameter ( ai1 = +5.034698970e-01 * esfac ) - parameter ( ai2 = +1.886013408e-02 * esfac ) - parameter ( ai3 = +4.176223716e-04 * esfac ) - parameter ( ai4 = +5.824720280e-06 * esfac ) - parameter ( ai5 = +4.838803174e-08 * esfac ) - parameter ( ai6 = +1.838826904e-10 * esfac ) - - parameter ( bi0 = +5.030305237e-01 * esfac ) - parameter ( bi1 = +3.773255020e-02 * esfac ) - parameter ( bi2 = +1.267995369e-03 * esfac ) - parameter ( bi3 = +2.477563108e-05 * esfac ) - parameter ( bi4 = +3.005693132e-07 * esfac ) - parameter ( bi5 = +2.158542548e-09 * esfac ) - parameter ( bi6 = +7.131097725e-12 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -40 C to -70 C) **** -c ******************************************************** - - - parameter ( d0 = 0.535098336e+01 * esfac ) - parameter ( d1 = 0.401390832e+00 * esfac ) - parameter ( d2 = 0.129690326e-01 * esfac ) - parameter ( d3 = 0.230325039e-03 * esfac ) - parameter ( d4 = 0.236279781e-05 * esfac ) - parameter ( d5 = 0.132243858e-07 * esfac ) - parameter ( d6 = 0.314296723e-10 * esfac ) - - parameter ( e0 = 0.469290530e+00 * esfac ) - parameter ( e1 = 0.333092511e-01 * esfac ) - parameter ( e2 = 0.102164528e-02 * esfac ) - parameter ( e3 = 0.172979242e-04 * esfac ) - parameter ( e4 = 0.170017544e-06 * esfac ) - parameter ( e5 = 0.916466531e-09 * esfac ) - parameter ( e6 = 0.210844486e-11 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -65 C to -95 C) **** -c ******************************************************** - - parameter ( f0 = 0.298152339e+01 * esfac ) - parameter ( f1 = 0.191372282e+00 * esfac ) - parameter ( f2 = 0.517609116e-02 * esfac ) - parameter ( f3 = 0.754129933e-04 * esfac ) - parameter ( f4 = 0.623439266e-06 * esfac ) - parameter ( f5 = 0.276961083e-08 * esfac ) - parameter ( f6 = 0.516000335e-11 * esfac ) - - parameter ( g0 = 0.312654072e+00 * esfac ) - parameter ( g1 = 0.195789002e-01 * esfac ) - parameter ( g2 = 0.517837908e-03 * esfac ) - parameter ( g3 = 0.739410547e-05 * esfac ) - parameter ( g4 = 0.600331350e-07 * esfac ) - parameter ( g5 = 0.262430726e-09 * esfac ) - parameter ( g6 = 0.481960676e-12 * esfac ) - - REAL TMAX, TICE - PARAMETER ( TMAX=323.15, TICE=273.16) - - REAL T, D, W, QX, DQX - T = MIN(TT,TMAX) - TICE - DQX = 0. - QX = 0. - -c Fitting for temperatures above 0 degrees centigrade -c --------------------------------------------------- - if(t.gt.0.) then - qx = aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6))))) - if (ldqdt) then - dqx = bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6))))) - endif - endif - -c Fitting for temperatures between 0 and -40 -c ------------------------------------------ - if( t.le.0. .and. t.gt.-40.0 ) then - w = (40.0 + t)/40.0 - qx = w *(aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6)))))) - . + (1.-w)*(ai0+T*(ai1+T*(ai2+T*(ai3+T*(ai4+T*(ai5+T*ai6)))))) - if (ldqdt) then - dqx = w *(bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6)))))) - . + (1.-w)*(bi0+T*(bi1+T*(bi2+T*(bi3+T*(bi4+T*(bi5+T*bi6)))))) - endif - endif - -c Fitting for temperatures between -40 and -70 -c -------------------------------------------- - if( t.le.-40.0 .and. t.ge.-70.0 ) then - qx = d0+T*(d1+T*(d2+T*(d3+T*(d4+T*(d5+T*d6))))) - if (ldqdt) then - dqx = e0+T*(e1+T*(e2+T*(e3+T*(e4+T*(e5+T*e6))))) - endif - endif - -c Fitting for temperatures less than -70 -c -------------------------------------- - if(t.lt.-70.0) then - qx = f0+t*(f1+t*(f2+t*(f3+t*(f4+t*(f5+t*f6))))) - if (ldqdt) then - dqx = g0+t*(g1+t*(g2+t*(g3+t*(g4+t*(g5+t*g6))))) - endif - endif - -c Compute Saturation Specific Humidity -c ------------------------------------ - D = (P-ERFAC*QX) - IF(D.LT.0.) THEN - Q = 1.0 - IF (LDQDT) DQDT = 0. - ELSE - D = 1.0 / D - Q = MIN(QX * D,1.0) - IF (LDQDT) DQDT = (1.0 + ERFAC*Q) * D * DQX - ENDIF - RETURN - END - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*abs(undef) - return - end - - subroutine getchar (name,num) - character*2 num2 - character*3 num3 - integer num - character*1 junk(256) - character*1 name(256) - data junk /256*' '/ - equivalence ( num2,junk ) - equivalence ( num3,junk ) - - num2 = ' ' - num3 = ' ' - - if( num.lt.100 ) then - write(num2,102) num - else if( num.lt.1000 ) then - write(num3,103) num - endif - - name = junk - - 102 format(i2.2) - 103 format(i3.3) - - return - end - - subroutine usage() - print *, "Usage: " - print * - print *, " ec_prs2eta.x -ecmwf ecmwf.data " - print *, " [-im im]" - print *, " [-jm jm]" - print *, " [-tag tag]" - print * - print *, "where:" - print * - print *, " -ecmwf ecmwf.data: Filename of ECMWF Pressure-Level analysis data" - print *, " -im im: Optional Zonal Dimenstion for Output (Default: IM from File)" - print *, " -jm jm: Optional Meridional Dimenstion for Output (Default: JM from File)" - print *, " -tag tag: Optional Prefix tag for Output (Default: ec_prs2eta)" - print *, " -gmaoprs : Indicates input is really GMAO prs file (used for test only)" - print * - error stop 7 - end - - subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef ) - implicit none - integer iin,jin, iout,jout, mlev - real qin(iin,jin,mlev), qout(iout,jout,mlev) - real undef,pi,dlin,dpin,dlout,dpout - real dlam(iin), lons(iout*jout), lon - real dphi(jin), lats(iout*jout), lat - integer i,j,loc - - pi = 4.0*atan(1.0) - dlin = 2*pi/iin - dpin = pi/(jin-1) - dlam(:) = dlin - dphi(:) = dpin - - dlout = 2*pi/ iout - dpout = pi/(jout-1) - - loc = 0 - do j=1,jout - do i=1,iout - loc = loc + 1 - lon = -pi + (i-1)*dlout - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jout - lat = -pi/2.0 + (j-1)*dpout - do i=1,iout - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call interp_h ( qin,iin,jin,mlev,dlam,dphi, - . qout,iout*jout,lons,lats,undef, -pi ) - - return - end - - subroutine interp_h ( q_cmp,im,jm,lm,dlam,dphi, - . q_geo,irun,lon_geo,lat_geo, undef, lon_min ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - - real :: lon_min - -c Local Variables -c --------------- - integer i,j,l - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real ap1, ap0, am1, am2 - real bp1, bp0, bm1, bm2 - - real lon_cmp(im) - real lat_cmp(jm) - real q_tmp(irun) - - real pi,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp - real lam_cmp - real phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = lon_min ! user supplied orign - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - do i=1,irun - lam_cmp = lon_geo(i) - phi_cmp = lat_geo(i) - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm1 = lat_cmp(jm1(i)) - - if( jm2(i).eq.0 ) then - phi_jm2 = phi_jm1 - dphi(1) - else - phi_jm2 = lat_cmp(jm2(i)) - endif - - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - else - phi_jp0 = lat_cmp(jp0(i)) - if( jp1(i).eq.jm+1 ) then - phi_jp1 = phi_jp0 + dphi(jm-1) - else - phi_jp1 = lat_cmp(jp1(i)) - endif - endif - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - -c Interpolate Computational-Grid Quantities to Geophysical Grid -c ------------------------------------------------------------- - do L=1,lm - do i=1,irun - - if( lat_geo(i).le.lat_cmp(2) .or. - . lat_geo(i).ge.lat_cmp(jm-1) ) then - -c 1st Order Interpolation at Poles -c -------------------------------- - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - else - -c Cubic Interpolation away from Poles -c ----------------------------------- - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jp1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp1(i),L ).ne.undef .and. - . q_cmp( im2(i),jp1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm2(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm2(i),L ).ne.undef .and. - . q_cmp( im1(i),jm2(i),L ).ne.undef .and. - . q_cmp( im2(i),jm2(i),L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) - . + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) - . + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) - . + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) - . + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) - . + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) - . + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - return - - end - - subroutine sigtopl ( qprs,q,logpl,logp,im,jm,lm,undef ) -C*********************************************************************** -C -C PURPOSE -C To interpolate an arbitrary quantity from Model Vertical Grid to Pressure -C -C INPUT -C Q ..... Q (im,jm,lm) Arbitrary Quantity on Model Grid -C PKZ ... PKZ (im,jm,lm) Pressure to the Kappa at Model Levels (From Phillips) -C PKSRF . PKSRF(im,jm) Surface Pressure to the Kappa -C PTOP .. Pressure at Model Top -C P ..... Output Pressure Level (mb) -C IM .... Longitude Dimension of Input -C JM .... Latitude Dimension of Input -C LM .... Vertical Dimension of Input -C -C OUTPUT -C QPRS .. QPRS (im,jm) Arbitrary Quantity at Pressure p -C -C NOTE -C Quantity is interpolated Linear in P**Kappa. -C Between PTOP**Kappa and PKZ(1), quantity is extrapolated. -C Between PKSRF**Kappa and PKZ(LM), quantity is extrapolated. -C Undefined Model-Level quantities are not used. -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** -C - implicit none - integer i,j,l,im,jm,lm - - real qprs(im,jm) - real q (im,jm,lm) - real logpl(im,jm,lm) - - real undef - real logp,temp - -c Initialize to UNDEFINED -c ----------------------- - do i=1,im*jm - qprs(i,1) = undef - enddo - -c Interpolate to Pressure Between Model Levels -c -------------------------------------------- - do L=1,lm-1 - if( all( logpl(:,:,L )>logp ) ) exit - if( all( logpl(:,:,L+1) 2 and km-1 => km -! ----------------------------------------------------------------- - else if( LM1.eq.1 .or. LP0.eq.km .or. 1.eq.1 ) then - q2(i,j,k) = q1(i,j,LP0) + ( q1(i,j,LM1)-q1(i,j,LP0) )*( logpl2(i,j,k )-logpl1(i,j,LP0) ) - . /( logpl1(i,j,LM1)-logpl1(i,j,LP0) ) - -! Interpolate Cubicly in LogP between other model levels -! ------------------------------------------------------ - else - LP1 = LP0+1 - LM2 = LM1-1 - P = logpl2(i,j,k) - PLP1 = logpl1(i,j,LP1) - PLP0 = logpl1(i,j,LP0) - PLM1 = logpl1(i,j,LM1) - PLM2 = logpl1(i,j,LM2) - DLP0 = dlogp1(i,j,LP0) - DLM1 = dlogp1(i,j,LM1) - DLM2 = dlogp1(i,j,LM2) - - ap1 = (P-PLP0)*(P-PLM1)*(P-PLM2)/( DLP0*(DLP0+DLM1)*(DLP0+DLM1+DLM2) ) - ap0 = (PLP1-P)*(P-PLM1)*(P-PLM2)/( DLP0* DLM1 *( DLM1+DLM2) ) - am1 = (PLP1-P)*(PLP0-P)*(P-PLM2)/( DLM1* DLM2 *(DLP0+DLM1 ) ) - am2 = (PLP1-P)*(PLP0-P)*(PLM1-P)/( DLM2*(DLM1+DLM2)*(DLP0+DLM1+DLM2) ) - - q2(i,j,k) = ap1*q1(i,j,LP1) + ap0*q1(i,j,LP0) + am1*q1(i,j,LM1) + am2*q1(i,j,LM2) - - endif - - enddo - enddo - enddo - - return - end - - subroutine remap ( ps1,dp1,u1,v1,thv1,q1,lm1, - . ps2,dp2,u2,v2,t2 ,q2,lm2,im,jm,nq ) - -C*********************************************************************** -C -C Purpose -C Driver for remapping input analysis (2) to output model levels (1) -C -C Argument Description -C ps1 ...... model surface pressure -C dp1 ...... model pressure thickness -C u1 ....... model zonal wind -C v1 ....... model meridional wind -C thv1 ..... model virtual potential temperature -C q1 ....... model specific humidity -C oz1 ...... model ozone -C lm1 ...... model vertical dimension -C -C ps2 ...... analysis surface pressure -C dp2 ...... analysis pressure thickness -C u2 ....... analysis zonal wind -C v2 ....... analysis meridional wind -C t2 . ..... analysis dry-bulb temperature -C q2 ....... analysis specific humidity -C oz2 ...... analysis ozone -C lm2 ...... analysis vertical dimension -C -C im ....... zonal dimension -C jm ....... meridional dimension -C nq ....... number of tracers -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - integer im,jm,lm1,lm2,nq - -c fv-DAS variables -c ---------------- - real dp1(im,jm,lm1) - real u1(im,jm,lm1) - real v1(im,jm,lm1) - real thv1(im,jm,lm1) - real q1(im,jm,lm1,nq) - real ps1(im,jm) - - real ak(lm1+1) - real bk(lm1+1) - -c Target analysis variables -c ------------------------- - real dp2(im,jm,lm2) - real u2(im,jm,lm2) - real v2(im,jm,lm2) - real t2(im,jm,lm2) - real thv2(im,jm,lm2) - real q2(im,jm,lm2,nq) - real ps2(im,jm) - -c Local variables -c --------------- - real pe1(im,jm,lm1+1) - real pe2(im,jm,lm2+1) - real pk2(im,jm,lm2 ) - real pke1(im,jm,lm1+1) - real pke2(im,jm,lm2+1) - - real kappa,cp,ptop,pl,alf,pint - real rgas,pref,tref,pkref,tstar,eps,rvap,grav - integer i,j,L,n,ks - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - -c Construct target analysis pressure variables -c -------------------------------------------- - do j=1,jm - do i=1,im - pe2(i,j,lm2+1) = ps2(i,j) - enddo - enddo - - do L=lm2,1,-1 - do j=1,jm - do i=1,im - pe2(i,j,L) = pe2(i,j,L+1) - dp2(i,j,L) - enddo - enddo - enddo - - do j=1,jm - do i=1,im - pe2(i,j,1) = max( pe2(i,j,1),1.0 ) ! Set ptop = 0.01 mb (rather than 0.0 mb from NCEP) - enddo - enddo - - do L=1,lm2+1 - do j=1,jm - do i=1,im - pke2(i,j,L) = pe2(i,j,L)**kappa - enddo - enddo - enddo - -c Construct target virtual potential temperature -c ---------------------------------------------- - do L=1,lm2 - do j=1,jm - do i=1,im - pk2(i,j,L) = ( pke2(i,j,L+1)-pke2(i,j,L) )/( kappa*log(pe2(i,j,L+1)/pe2(i,j,L)) ) - thv2(i,j,L) = t2(i,j,L)*( 1.0+eps*max(0.0,q2(i,j,L,1)) )/pk2(i,j,L) - enddo - enddo - enddo - -c Construct fv pressure variables using surface pressure and AK & BK -c ------------------------------------------------------------------ - call set_eta ( lm1,ks,ptop,pint,ak,bk ) - - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1(i,j,L) = ak(L) + bk(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -c Map Input Analysis onto fv grid -c ------------------------------- - call gmap ( im,jm,nq, kappa, - . lm2, pke2, pe2, u2, v2, thv2, q2, - . lm1, pke1, pe1, u1, v1, thv1, q1) - - return - end - - subroutine put_fveta ( ps,dp,u,v,thv,q,phis, - . im,jm,lm,nq,nymd,nhms,tag,ext,lonbeg, - . timeinc,precision ) - use MAPL_BaseMod, only: MAPL_UNDEF - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - - integer im,jm,lm,nq,nymd,nhms - real phis(im,jm) - real ps(im,jm) - real dp(im,jm,lm) - real u(im,jm,lm) - real v(im,jm,lm) - real thv(im,jm,lm) - real q(im,jm,lm,nq) - integer timeinc - - real ple(im,jm,lm+1) - real pke(im,jm,lm+1) - real pk(im,jm,lm) - real tv(im,jm,lm) - real t(im,jm,lm) - - real lats(jm) - real lons(im) - real levs(lm) - real ak(lm+1) - real bk(lm+1) - - real rgas,rvap,eps,kappa,grav - real ptop,dlon,dlat,pref,dpref(lm),undef,lonbeg,pint - integer i,j,L,m,n,rc,ks - character*256 tag,ext,filename, fname - integer nvars,fid,precision - - character*256 levunits - character*256 title - character*256 source - character*256 contact - character*256, allocatable, dimension(:) :: vname - character*256, allocatable, dimension(:) :: vtitle - character*256, allocatable, dimension(:) :: vunits - integer, allocatable, dimension(:) :: lmvar - - real, allocatable :: v_range(:,:) - real, allocatable :: p_range(:,:) - - character*2 cnhms - character*3 cLM - character*8 cnymd - - print *, im,jm,lm,nq,nymd,nhms,trim(ext) - - undef = MAPL_UNDEF - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - eps = rvap/rgas-1.0 - - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - write( cLM,400 ) lm - 200 format(i8.8) - 300 format(i2.2) - 400 format(i3.3) - fname = trim(tag) // 'ec_prs2eta_L' // trim(cLM) // '.' // trim(cnymd) // '_' // trim(cnhms) // 'z.' // trim(ext) - print *, 'Creating 32-bit eta file: ',trim(fname) - - call set_eta ( lm,ks,ptop,pint,ak,bk ) - -! Construct T, TV -! --------------- - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - tv = thv*pk - t(:,:,:) = tv(:,:,:)/(1+eps*q(:,:,:,1)) - -c String and vars settings -c ------------------------ - title = 'EC_PRS2ETA Data' - source = 'Goddard Modeling and Assimilation Office, NASA/GSFC' - contact = 'data@gmao.gsfc.nasa.gov' - levunits = 'hPa' - - nvars = 7 - - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - allocate ( v_range(2,nvars) ) - allocate ( p_range(2,nvars) ) - - n = 1 - vname(n) = 'phis' - vtitle(n) = 'Topography geopotential' - vunits(n) = 'meter2/sec2' - lmvar(n) = 0 - - n = n + 1 - vname(n) = 'ps' - vtitle(n) = 'Surface Pressure' - vunits(n) = 'Pa' - lmvar(n) = 0 - - n = n + 1 - vname(n) = 'dp' - vtitle(n) = 'Pressure Thickness' - vunits(n) = 'Pa' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'u' - vtitle(n) = 'eastward_wind' - vunits(n) = 'm/s' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'v' - vtitle(n) = 'northward_wind' - vunits(n) = 'm/s' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'tv' - vtitle(n) = 'air_virtual_temperature' - vunits(n) = 'K' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'qv' - vtitle(n) = 'Specific Humidity Vapor' - vunits(n) = 'kg/kg' - lmvar(n) = lm - - v_range(:,:) = undef - p_range(:,:) = undef - -c Compute grid -c ------------ - dlon = 360.0/ im - dlat = 180.0/(jm-1) - - do j=1,jm - lats(j) = -90.0 + (j-1)*dlat - enddo - do i=1,im - lons(i) = lonbeg + (i-1)*dlon - enddo - do L=1,lm - dpref(L) = (ak(L+1)-ak(L)) + (bk(L+1)-bk(L))*98400.0 - enddo - pref = ptop + 0.5*dpref(1) - levs(1) = pref - do L=2,lm - pref = pref + 0.5*( dpref(L)+dpref(L-1) ) - levs(L) = pref - enddo - levs(:) = levs(:)/100 - -c Create GFIO file -c ---------------- - call GFIO_Create ( fname, title, source, contact, undef, - . im, jm, lm, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vname, vtitle, vunits, lmvar, - . v_range, p_range, precision, - . fid, rc ) -c Write GFIO data -c --------------- - n = 1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,0, 1,phis,rc ) ; n = n+1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,0, 1,ps ,rc ) ; n = n+1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,dp ,rc ) ; n = n+1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,u ,rc ) ; n = n+1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,v ,rc ) ; n = n+1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,tv ,rc ) ; n = n+1 - do m=1,nq - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,q(1,1,1,m),rc ) ; n = n+1 - enddo - -c Write GFIO global attributes -c ---------------------------- - call GFIO_PutRealAtt ( fid,'ak', lm+1,ak ,precision,rc ) - call GFIO_PutRealAtt ( fid,'bk', lm+1,bk ,precision,rc ) - - call gfio_close ( fid,rc ) - return - end - - subroutine get_gmaoana_data ( id,ps,u,v,t,q,h,phis, - . im,jm,lm,nymd,nhms,lonbeg, - . imana,jmana,lmana,nvars,names,lmvars,undef,plevs ) - use MAPL_ConstantsMod - implicit none - integer id,im,jm,lm,nymd,nhms,rc - integer imana,jmana,lmana - integer nvars - integer lmvars(nvars) - character*256 names(nvars) - character*256 filename, format - - real lonbeg - real ps(im,jm) - real u(im,jm,lm) - real v(im,jm,lm) - real t(im,jm,lm) - real h(im,jm,lm) - real rh(im,jm,lm) - real q(im,jm,lm) - real phis(im,jm) - real plevs(lm) - real slp(im,jm) - real thv(im,jm) - - real, allocatable :: dum2d(:,:) - real, allocatable :: dum3d(:,:,:) - real, allocatable :: dumu (:,:,:) - real, allocatable :: dumv (:,:,:) - - real undef,kappa,grav,dum,beta,cp,rgas,gamma,dp - integer L,i,j,n,LM1 - - allocate ( dum2d(imana,jmana) ) - allocate ( dum3d(imana,jmana,lmana) ) - allocate ( dumu (imana,jmana,lmana) ) - allocate ( dumv (imana,jmana,lmana) ) - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - grav = MAPL_GRAV - cp = MAPL_CP - beta = 6.5e-3 - -! Writing variable: slp -! Writing variable: ps -! Writing variable: hght -! Writing variable: rh -! Writing variable: tmpu -! Writing variable: u -! Writing variable: v - -c Read ANA Variables -c ------------------ - call gfio_getvar ( id,'slp',nymd,nhms,imana,jmana,0,1 ,dum2d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find GMAO SLP variable' - error stop 7 - endif - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum2d,imana,jmana,slp,im,jm,1,undef ) - else - slp = dum2d - endif - - call gfio_getvar ( id,'ps',nymd,nhms,imana,jmana,0,1 ,dum2d ,rc ) ! New ECMWF Format 2011/05/11 06z - if( rc.ne.0 ) then - print *, 'Could not find GMAO Surface Pressure variable' - error stop 7 - endif - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum2d,imana,jmana,ps,im,jm,1,undef ) - else - ps = dum2d - endif - - call gfio_getvar ( id,'hght',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find GMAO Height variable' - error stop 7 - endif - call zflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,h,im,jm,lm,undef ) - else - h = dum3d - endif - -c Winds -c ----- - call gfio_getvar ( id,'u',nymd,nhms,imana,jmana,1,lmana,dumu,rc ) - if( rc.ne.0 ) then - print *, 'Could not find GMAO U-Wind variable' - error stop 7 - endif - call gfio_getvar ( id,'v',nymd,nhms,imana,jmana,1,lmana,dumv,rc ) - if( rc.ne.0 ) then - print *, 'Could not find GMAO V-Wind variable' - error stop 7 - endif - - call zflip( dumu,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dumu,imana,jmana,u,im,jm,lm,undef ) - else - u = dumu - endif - - call zflip( dumv,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dumv,imana,jmana,v,im,jm,lm,undef ) - else - v = dumv - endif - -c Temperature -c ----------- - call gfio_getvar ( id,'tmpu',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find GMAO Temperature variable' - error stop 7 - endif - call zflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,t,im,jm,lm,undef ) - else - t = dum3d - endif - -c Relative Humidity -c ----------------- - call gfio_getvar ( id,'rh',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find GMAO Rel.Hum. variable' - error stop 7 - endif - call zflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,rh,im,jm,lm,undef ) - else - rh = dum3d - endif - rh = max( rh,0.0 ) - -c Compute PHIS -c ------------ - do j=1,jm - do i=1,im - L=1 - do while( L.lt.lm .and. plevs(L).lt.ps(i,j)/100.0 ) - L=L+1 - enddo - LM1 = L-1 - phis(i,j) = h(i,j,L) - ( h(i,j,L)-h(i,j,LM1) )*log( 100*plevs(L)/ps(i,j) )/log( plevs(L)/plevs(LM1) ) - enddo - enddo - phis = phis*grav - -c Load GMAO Variables -c ------------------- - do L=1,lm - do j=1,jm - do i=1,im - call qsat (t(i,j,L),plevs(L),q(i,j,L),dum,.false.) - q(i,j,L) = rh(i,j,L)*q(i,j,L)*0.01 - enddo - enddo - enddo - - return - end diff --git a/GEOS_Util/post/ec_prs2fv.F b/GEOS_Util/post/ec_prs2fv.F deleted file mode 100644 index 7fd42926..00000000 --- a/GEOS_Util/post/ec_prs2fv.F +++ /dev/null @@ -1,4742 +0,0 @@ - program main - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to create fv restarts from Pressure Level Data **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm - real pbelow,pabove,ptop,pint - real rgas,eps,rvap - - real dum - integer niter,i0,j0 - parameter ( niter = 5 ) - -! GEOS Restart Variables -! ---------------------- - real*4, allocatable :: dum4(:,:) - real*8, allocatable :: dum8(:,:) - real*8, allocatable :: ak(:) - real*8, allocatable :: bk(:) - - integer headr1(6) - integer headr2(5) - - real, allocatable :: phis(:,:) - -c Set analysis, fvdas, date and time -c ---------------------------------- - character*2 cnhms - character*8 cnymd - - character*256 dynrst, mstrst, prsdata, topog, tag, ext - character*256 dynrst2, mstrst2 - - real :: phibg, phifg, thbr1, thbr2, delth, cp - real :: kappa = 2.0/7.0 - real :: grav = 9.80 - - integer nymd,nhms - integer Lbeg,Lend - -c fv restart variables and topography -c ----------------------------------- - real, allocatable :: ps(:,:) - real, allocatable :: dp(:,:,:) - real, allocatable :: pl(:,:,:) - real, allocatable :: ple(:,:,:) - real, allocatable :: u(:,:,:), ud(:,:,:) - real, allocatable :: v(:,:,:), vd(:,:,:) - real, allocatable :: th(:,:,:) - real, allocatable :: thv(:,:,:) - real, allocatable :: pke(:,:,:) - real, allocatable :: pk (:,:,:) - real, allocatable :: q(:,:,:) - - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - integer timinc - real undef - -c Analysis variables -c ------------------ - real, allocatable :: phis_ana(:,:) - real, allocatable :: ps_ana(:,:) - real, allocatable :: u_ana(:,:,:) - real, allocatable :: v_ana(:,:,:) - real, allocatable :: z_ana(:,:,:) - real, allocatable :: er_ana(:,:,:) - real, allocatable :: q_ana(:,:,:) - real, allocatable :: p_ana(:,:,:) - real, allocatable :: dp_ana(:,:,:) - real, allocatable :: pl_ana(:,:,:) - real, allocatable :: t_ana(:,:,:) - real, allocatable :: t_ec(:,:,:) - real, allocatable :: h_ana(:,:,:) - real, allocatable :: ple_ana(:,:,:) - real, allocatable :: logp (:,:,:) - real, allocatable :: logpl(:,:,:) - real, allocatable :: qdum (:,:,:) - integer id,rc,ks - integer imax,jmax - integer nvars, ngatts, ntime - - character*120, allocatable :: arg(:) - - logical recon - integer precision - integer i,j,k,L,n,nargs - -c Analysis Grads CTL File Variables -c --------------------------------- - character*256 ctlfile - integer imana,jmana,lmana - - real, pointer :: plevs(:) - -C ********************************************************************** -C **** Initialize Filenames, Methods, etc. **** -C ********************************************************************** - - i0 = 0 - j0 = 0 - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - recon = .true. - - pabove = 10.00 ! 10 mb - pbelow = 30.00 ! 30 mb - precision = 0 ! 32-bit - ctlfile = 'xxx' - nymd = -999 - nhms = -999 - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-dyn' ) dynrst = trim(arg(n+1)) - if( trim(arg(n)).eq.'-moist' ) mstrst = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ecmwf' ) prsdata = trim(arg(n+1)) - if( trim(arg(n)).eq.'-topo' ) topog = trim(arg(n+1)) - if( trim(arg(n)).eq.'-tag' ) tag = trim(arg(n+1)) - if( trim(arg(n)).eq.'-plow ' ) read(arg(n+1), * ) pbelow - if( trim(arg(n)).eq.'-phigh' ) read(arg(n+1), * ) pabove - if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1), * ) nymd - if( trim(arg(n)).eq.'-nhms' ) read(arg(n+1), * ) nhms - if( trim(arg(n)).eq.'-i0' ) read(arg(n+1), * ) i0 - if( trim(arg(n)).eq.'-j0' ) read(arg(n+1), * ) j0 - if( trim(arg(n)).eq.'-recon' ) read(arg(n+1), * ) recon - enddo - if( pbelow.lt.pabove ) then - dum = pbelow - pbelow = pabove - pabove = dum - endif - endif - pabove = pabove*100 - pbelow = pbelow*100 - - if( trim(tag).ne.'' ) tag = trim(tag) // '.' - ext = 'nc4' - -! ********************************************************************** -! **** Read dycore internal Restart **** -! ********************************************************************** - - open (10,file=trim(dynrst),form='unformatted',access='sequential') - read (10) headr1 - read (10) headr2 - - if( nymd.eq.-999 ) nymd = headr1(1)*10000 + headr1(2)*100 + headr1(3) - if( nhms.eq.-999 ) nhms = headr1(4)*10000 + headr1(5)*100 + headr1(6) - - im = headr2(1) - jm = headr2(2) - lm = headr2(3) - - allocate ( dum8(im,jm) ) - allocate ( u(im,jm,lm) ) - allocate ( ud(im,jm,lm) ) - allocate ( v(im,jm,lm) ) - allocate ( vd(im,jm,lm) ) - allocate ( th(im,jm,lm) ) - allocate ( thv(im,jm,lm) ) - allocate ( dp(im,jm,lm) ) - allocate ( pk(im,jm,lm) ) - allocate ( ple(im,jm,lm+1) ) - allocate ( pke(im,jm,lm+1) ) - allocate ( ps(im,jm) ) - allocate ( ak(lm+1) ) - allocate ( bk(lm+1) ) - - read (10) ak - read (10) bk - - do L=1,lm - read(10) dum8 ; ud(:,:,L) = dum8 - enddo - do L=1,lm - read(10) dum8 ; vd(:,:,L) = dum8 - enddo - do L=1,lm - read(10) dum8 ; th(:,:,L) = dum8 ! Note: GEOS-5 variable is DRY potential temperature - enddo - do L=1,lm+1 - read(10) dum8 ; ple(:,:,L) = dum8 - enddo - do L=1,lm - read(10) dum8 ; pk(:,:,L) = dum8 - enddo - - close (10) - - call dtoa_winds ( ud,vd,u,v,im,jm,lm ) - -! Construct Pressure Variables -! ---------------------------- - - ps(:,:) = ple(:,:,lm+1) - do L=lm,1,-1 - dp(:,:,L) = ple(:,:,L+1)-ple(:,:,L) - pl(:,:,L) = (ple(:,:,L+1)+ple(:,:,L))*0.5 - enddo - -c call set_eta ( lm,ks,ptop,pint,ak,bk ) -c do L=1,lm+1 -c ple(:,:,L) = ak(L) + ps(:,:)*bk(L) -c enddo -c do L=1,lm -c pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) -c . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) -c enddo - -! ********************************************************************** -! **** Read moist internal Restart **** -! ********************************************************************** - - allocate ( q(im,jm,lm) ) - allocate ( dum4(im,jm) ) - - open (10,file=trim(mstrst),form='unformatted',access='sequential') - do L=1,lm - read(10) dum4 - q(:,:,L) = dum4(:,:) ! First moist variable is SPHU - enddo - close (10) - -! Construct THV for REMAPPING -! --------------------------- - thv = th*(1+eps*q) - -! ********************************************************************** -! **** Read Topography Dataset **** -! ********************************************************************** - - allocate ( phis(im,jm) ) - - print *, 'Reading Topography Dataset: ',trim(topog) - open (10,file=trim(topog),form='unformatted',access='sequential') - read (10) phis - close(10) - - phis = phis*grav -#ifdef DEBUG - call writit ( phis,im,jm,1,65 ) -#endif - -C ********************************************************************** -C **** Read ANA MetaData **** -C ********************************************************************** - - call gfio_open ( trim(prsdata),1,id,rc ) - call gfio_diminquire ( id,imana,jmana,lmana,ntime,nvars,ngatts,rc ) - - allocate ( lon(imana) ) - allocate ( lat(jmana) ) - allocate ( lev(lmana) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,imana,jmana,lmana,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - - allocate ( plevs(lmana) ) - do L=1,lmana - plevs(L) = lev(lmana-L+1) - enddo - - print * - print *, ' GEOS Resolution: ',im,jm,lm - print *, ' nymd: ',nymd - print *, ' nhms: ',nhms - print * - print *, ' ANA File: ',trim(prsdata) - print *, ' rslv: ',imana,jmana,lmana - print *, ' lon(1): ',lon(1)*180.0/3.14159 - print *, ' Reconcile Heights: ',recon - print * - print *, ' Number of Variables: ',nvars - print * - do n=1,nvars - write(6,1001) n,trim(vname(n)),trim(vtitle(n)),kmvar(n) - enddo - 1001 format(1x,i2,3x,a16,2x,a32,2x,i3) - print * - L = 1 - print *, ' Pressure Levels: ',L,plevs(L) - do L=2,lmana - print *, ' ',L,plevs(L) - enddo - print * - print *, ' Blending between: ',pbelow/100,' and ',pabove/100,' mb' - print * - - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - 200 format(i8.8) - 300 format(i2.2) - 400 format('dset ^',a) - 600 format(a1,i2.2) - -C ********************************************************************** -C **** Get Analysis **** -C ********************************************************************** - - allocate ( p_ana(im,jm,lmana) ) - allocate ( er_ana(im,jm,lmana) ) - allocate ( z_ana(im,jm,lmana) ) - allocate ( u_ana(im,jm,lmana) ) - allocate ( v_ana(im,jm,lmana) ) - allocate ( t_ana(im,jm,lmana) ) - allocate ( t_ec (im,jm,lmana) ) - allocate ( h_ana(im,jm,lmana) ) - allocate ( q_ana(im,jm,lmana) ) - allocate ( ps_ana(im,jm) ) - allocate (phis_ana(im,jm) ) - - print *, 'Reading Analysis for Date: ',nymd,' Time: ',nhms - print * - - call get_ana_data ( id,ps_ana,u_ana,v_ana,t_ana,q_ana,h_ana,phis_ana, - . im,jm,lmana,nymd,nhms,lon(1), - . imana,jmana,lmana,undef,plevs ) - t_ec = t_ana - - allocate( dp_ana(im,jm,lm) ) - allocate( pl_ana(im,jm,lm) ) - allocate( ple_ana(im,jm,lm+1) ) - allocate( logp (im,jm,lm) ) - allocate( logpl(im,jm,lm) ) - do L=1,lm+1 - ple_ana(:,:,L) = ak(L) + ps_ana(:,:)*bk(L) - enddo - do L=1,lm - dp_ana(:,:,L) = ple_ana(:,:,L+1)-ple_ana(:,:,L) - pl_ana(:,:,L) = 0.5*(ple_ana(:,:,L+1)+ple_ana(:,:,L)) - logp(:,:,L) = log( 0.5*(ple_ana(:,:,L+1)+ple_ana(:,:,L)) ) - enddo - - if( i0.ne.0 .and. j0.ne.0 ) then - print *, 'Sample ANA Data at GEOS-5 Location: (',i0,',',j0,')' - print *, ' ANA_PS: ',ps_ana(i0,j0)/100,' ANA_PHIS: ',phis_ana(i0,j0) - print *, ' ANA_UNDEF: ',undef - print *, ' ANA Temperature and Wind Profile:' - else - print *, 'Sample ANA Data:' - print *, ' ANA_PS: ',ps_ana(1,jm/2)/100,' ANA_PHIS: ',phis_ana(1,jm/2) - print *, ' ANA_UNDEF: ',undef - print *, ' ANA_Temperature and Wind Profile:' - endif - do L=1,lmana - p_ana(:,:,L) = 100.0*plevs(L) - logpl(:,:,L) = log( 100.0*plevs(L) ) - if( i0.ne.0 .and. j0.ne.0 ) then - print *, L,plevs(L),t_ana(i0,j0,L),u_ana(i0,j0,L) - else - print *, L,plevs(L),t_ana(1,jm/2,L),u_ana(1,jm/2,L) - endif - enddo - print * - - allocate ( qdum(im,jm,lm) ) - - call interp ( qdum,u_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'UWND ',niter,i0,j0,1 ) - deallocate ( u_ana ) - allocate ( u_ana(im,jm,lm) ) - u_ana = qdum - - call interp ( qdum,v_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'VWND ',niter,i0,j0,1 ) - deallocate ( v_ana ) - allocate ( v_ana(im,jm,lm) ) - v_ana = qdum - - call interp ( qdum,t_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'TMPU ',niter,i0,j0,1 ) - deallocate ( t_ana ) - allocate ( t_ana(im,jm,lm) ) - t_ana = qdum - - call interp ( qdum,q_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'SPHU ',niter,i0,j0,-1 ) - deallocate ( q_ana ) - allocate ( q_ana(im,jm,lm) ) - q_ana = qdum - -C ********************************************************************** -C **** Remap for Analysis **** -C ********************************************************************** - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'Before REMAP: ' - print *, 'GEOS5 PHIS/grav: ',phis(i0,j0)/grav,' ps: ',ps(i0,j0)/100 - print *, 'ANA PHIS/grav: ',phis_ana(i0,j0)/grav,' ps: ',ps_ana(i0,j0)/100 - print * - endif - - print *, 'Calling Remap' - call remap ( ps,dp,u,v,thv,q,phis,lm, - . ps_ana,dp_ana,u_ana,v_ana,t_ana,q_ana,phis_ana,lm,im,jm,1,pbelow,pabove ) - print *, ' Fini Remap' - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'AFter REMAP: ' - print *, 'GEOS5 PHIS/grav: ',phis(i0,j0)/grav,' ps: ',ps(i0,j0)/100 - print *, 'ANA PHIS/grav: ',phis_ana(i0,j0)/grav,' ps: ',ps_ana(i0,j0)/100 - print * - endif - -C ********************************************************************** -C **** Reconcile Heights **** -C ********************************************************************** - - cp = MAPL_CP - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - - if( recon ) then - do j=1,jm - do i=1,im - - Lbeg = lm - phifg = phis(i,j) - phibg = phifg - - do k=lmana,1,-1 - if( i.eq.i0 .and. j.eq.j0 ) then - write(6,5001) k,p_ana(i,j,k)/100,h_ana(i,j,k),t_ec(i,j,k) - 5001 format(1x,'k: ',i3,3x,'ANA_PMAN: ',f8.3,3x,'ANA_HGHT: ',f9.3,3x,'ANA_TMPU: ',f7.3) - endif - - if( p_ana(i,j,k).lt.ps(i,j) .and. ! p_ana is above GEOS Surface Pressure - . h_ana(i,j,k)-phibg/grav.gt.10.0 .and. ! h_ana is at least 10-meters above previous level - . h_ana(i,j,k)-phis_ana(i,j)/grav.gt.10.0 .and. ! h_ana is at least 10-meters above Topography - . p_ana(i,j,k).gt.pabove ) then ! p_ana is below Blending Region - if( i.eq.i0 .and. j.eq.j0 ) print * - - do L=Lbeg,1,-1 - if( ple(i,j,L).gt.p_ana(i,j,k) ) then - phifg = phifg + cp*thv(i,j,L)*( pke(i,j,L+1)-pke(i,j,L) ) - if( i.eq.i0 .and. j.eq.j0 ) then - write(6,5002) L,ple(i,j,L)/100,phifg/grav,thv(i,j,L)*pk(i,j,L) - 5002 format(1x,'L: ',i3,3x,' G5_PLE: ',f8.3,3x,'G5_HGHT: ',f9.3,3x,'G5_TMPU: ',f7.3) - endif - else - exit - endif - enddo - Lend = L - if( Lbeg-Lend.le.2 ) then - phifg = phibg - cycle - endif - - phifg = phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-p_ana(i,j,k)**kappa ) - - if( i.eq.i0 .and. j.eq.j0 ) then - print * - print *, ' Lbeg: ',Lbeg,' Lend: ',Lend,' ple(Lend): ',ple(i,j,Lend)/100 - print *, 'ANA_HGHT: ',h_ana(i,j,k),' G5_HGHT: ',phifg/grav,' G5_HGHT0: ',phibg/grav - print *, 'ANA_TMPU: ',t_ec (i,j,k),' G5_TMPU: ',thv(i,j,Lend)*pk(i,j,LEND) - endif - - thbr1 = ( grav*h_ana(i,j,k)-phibg )/( pke(i,j,Lbeg+1)-p_ana(i,j,k)**kappa )/cp - thbr2 = ( phifg -phibg )/( pke(i,j,Lbeg+1)-p_ana(i,j,k)**kappa )/cp - delth = thbr1-thbr2 - - if( i.eq.i0 .and. j.eq.j0 ) then - print *, 'ANA_THETA_BR: ',thbr1,' G5_THETA_BR: ',thbr2 - print *, ' ANA_T_TOP: ',thbr1*p_ana(i,j,k)**kappa,' G5_T_TOP: ',thbr2*p_ana(i,j,k)**kappa - print *, ' ANA_T_BOT: ',thbr1*pke(i,j,Lbeg+1),' G5_T_BOT: ',thbr2*pke(i,j,Lbeg+1) - endif - - do L=Lbeg,Lend,-1 - thv(i,j,L) = thv(i,j,L) + delth - enddo - - phifg = phibg - do L=Lbeg,Lend+1,-1 - phifg = phifg + cp*thv(i,j,L)*( pke(i,j,L+1)-pke(i,j,L) ) - enddo - - if( i.eq.i0 .and. j.eq.j0 ) print *, 'ANA_HGHT: ',h_ana(i,j,k),' G5_HGHT: ', - . (phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-p_ana(i,j,k)**kappa ))/grav - - phifg = phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-pke(i,j,Lend) ) - Lbeg = Lend-1 - phibg = phifg - endif - enddo - - enddo - enddo - endif - -! ********************************************************************** -! **** Write dycore internal Restart **** -! ********************************************************************** - - call atod_winds ( u,v,ud,vd,im,jm,lm ) - - th = thv/(1+eps*q) - - dynrst2 = trim(dynrst) // '.ecmwf' - print * - print *, 'Creating GEOS-5 fvcore_internal_restart' - - open (20,file=trim(dynrst2),form='unformatted',access='sequential') - write(20) headr1 - write(20) headr2 - write(20) ak - write(20) bk - do L=1,lm - dum8(:,:) = ud(:,:,L) - write(20) dum8 - enddo - do L=1,lm - dum8(:,:) = vd(:,:,L) - write(20) dum8 - enddo - do L=1,lm - dum8(:,:) = th(:,:,L) - write(20) dum8 - enddo - do L=1,lm+1 - dum8(:,:) = ple(:,:,L) - write(20) dum8 - enddo - do L=1,lm - dum8(:,:) = pk(:,:,L) - write(20) dum8 - enddo - close (20) - -! ********************************************************************** -! **** Write Moist Internal Restart **** -! ********************************************************************** - - mstrst2 = trim(mstrst) // '.ecmwf' - - open (10,file=trim(mstrst) ,form='unformatted',access='sequential') - open (20,file=trim(mstrst2),form='unformatted',access='sequential') - - print *, 'Creating GEOS-5 moist_internal_restart' - do L=1,lm - read(10) dum4 - dum4 = q(:,:,L) ! First moist variable is SPHU - write(20) dum4 - enddo - - rc = 0 - dowhile (rc.eq.0) - read (10,iostat=rc) dum4 - if( rc.eq.0 ) write(20) dum4 - enddo - - stop - end - - subroutine interp ( q,qana,logp,logpl,pana,pl,ple,im,jm,lm,lmana,undef,name,niter,i0,j0,flag ) - implicit none - integer im,jm,lm,lmana,niter,i0,j0,flag - real undef - real q (im,jm,lm) - real pl (im,jm,lm) - real ple (im,jm,lm+1) - real er (im,jm,lm) - real logp (im,jm,lm) - real pana (im,jm,lmana) - real qana (im,jm,lmana) - real zana (im,jm,lmana) - real erana(im,jm,lmana) - real logpl(im,jm,lmana) - character*8 name - - integer i,j,L,n - -c Interpolate Analysis to GEOS Model Levels -c ----------------------------------------- - do L=1,lm - do j=1,jm - do i=1,im - call sigtopl( q(i,j,L),qana(i,j,:),logpl(i,j,:),logp(i,j,L),1,1,lmana,undef ) - enddo - enddo - enddo - if( flag.eq.-1 ) then - q = max( q,0.0 ) - endif - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'Initial ANA ',trim(name),' Profile at GEOS-5 Levels:' - do L=1,lm - print *, L,exp(logp(i0,j0,L))/100.,q(i0,j0,L) - enddo - print * - else - print *, 'Interpolating ',trim(name),' ...' - endif - -#ifdef DEBUG - call writit (q,im,jm,lm,66) -#endif - do n=1,niter -c Interpolate GEOS Model Back to EC Levels and Compute Error -c ---------------------------------------------------------- - do L=1,lmana - do j=1,jm - do i=1,im - call sigtopl( zana(i,j,L),q(i,j,:),logp(i,j,:),logpl(i,j,L),1,1,lm,undef ) - erana(i,j,L) = zana(i,j,L)-qana(i,j,L) - enddo - enddo - enddo - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'ANA ',trim(name),' Profile Comparison, ITER: ',n - print *, '----------------------------------------------' - do L=1,lmana - print *, L,exp(logpl(i0,j0,L))/100.,zana(i0,j0,L),qana(i0,j0,L),erana(i0,j0,L) - enddo - print * - endif - -c Interpolate and Add Error to GEOS Model Levels -c ---------------------------------------------- - call interp3 ( erana,pana,im,jm,lmana, er,pl,lm,ple(1,1,lm+1) ) - q = q - er - if( flag.eq.-1 ) then - q = max( q,0.0 ) - endif -#ifdef DEBUG - call writit (q,im,jm,lm,66) -#endif - enddo - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'Final ANA ',trim(name),' Profile at GEOS-5 Levels:' - do L=1,lm - print *, L,exp(logp(i0,j0,L))/100.,q(i0,j0,L) - enddo - print * - endif - - return - end - - subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, - . im,jm,lm,nymd,nhms,lonbeg, - . imana,jmana,lmana,undef,plevs ) - use MAPL_ConstantsMod - implicit none - integer id,im,jm,lm,nymd,nhms,rc - integer imana,jmana,lmana - - real lonbeg - real ps(im,jm) - real u(im,jm,lm) - real v(im,jm,lm) - real t(im,jm,lm) - real h(im,jm,lm) - real rh(im,jm,lm) - real q(im,jm,lm) - real phis(im,jm) - real plevs(lm) - real phis2(im,jm) - real slp(im,jm) - - real, allocatable :: vor (:,:) - real, allocatable :: div (:,:) - real, allocatable :: chi (:,:) - real, allocatable :: psi (:,:) - real, allocatable :: dchidx(:,:) - real, allocatable :: dchidy(:,:) - real, allocatable :: dpsidx(:,:) - real, allocatable :: dpsidy(:,:) - - real, allocatable :: dum2d(:,:) - real, allocatable :: dum3d(:,:,:) - real, allocatable :: dumu (:,:,:) - real, allocatable :: dumv (:,:,:) - - real undef,kappa,grav,dum,beta,cp,rgas,gamma,dp - integer L,i,j,LM1 - - allocate ( vor (imana,jmana) ) - allocate ( div (imana,jmana) ) - allocate ( chi (imana,jmana) ) - allocate ( psi (imana,jmana) ) - allocate ( dchidx(imana,jmana) ) - allocate ( dchidy(imana,jmana) ) - allocate ( dpsidx(imana,jmana) ) - allocate ( dpsidy(imana,jmana) ) - - allocate ( dum2d(imana,jmana) ) - allocate ( dum3d(imana,jmana,lmana) ) - allocate ( dumu (imana,jmana,lmana) ) - allocate ( dumv (imana,jmana,lmana) ) - - rgas = MAPL_RGAS - kappa = MAPL_KAPPA - grav = MAPL_GRAV - cp = MAPL_CP - beta = 6.5e-3 - -c Read ANA Variables -c ------------------ - call gfio_getvar ( id,'mean_sea_level_',nymd,nhms,imana,jmana,0,1 ,dum2d,rc ) - if( lonbeg.eq.0.0 ) call hflip( dum2d,imana,jmana,1 ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum2d,imana,jmana,slp,im,jm,1,undef ) - else - slp = dum2d - endif - - call gfio_getvar ( id,'surface_pressur',nymd,nhms,imana,jmana,0,1 ,dum2d ,rc ) ! New ECMWF Format 2011/05/11 06z - if( rc.ne.0 ) then - call gfio_getvar ( id,'logarithm_of_su',nymd,nhms,imana,jmana,0,1 ,dum2d ,rc ) ! Old ECMWF Format - if( rc.ne.0 ) then - print *, 'Could not find ECMWF Surface Pressure variable' - error stop 7 - endif - dum2d = exp(dum2d) - endif - if( lonbeg.eq.0.0 ) call hflip( dum2d,imana,jmana,1 ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum2d,imana,jmana,ps,im,jm,1,undef ) - else - ps = dum2d - endif - - call gfio_getvar ( id,'height',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF Height variable' - error stop 7 - endif - if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,h,im,jm,lm,undef ) - else - h = dum3d - endif - -c Winds -c ----- - call gfio_getvar ( id,'u_velocity',nymd,nhms,imana,jmana,1,lmana,dumu,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF U-Wind variable' - error stop 7 - endif - call gfio_getvar ( id,'v_velocity',nymd,nhms,imana,jmana,1,lmana,dumv,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF V-Wind variable' - error stop 7 - endif - -#if 0 - do L=1,lmana - call getvordiv( dumu(1,1,L),dumv(1,1,L),vor,div,imana,jmana ) - call laplacian( vor,psi,imana,jmana ) - call laplacian( div,chi,imana,jmana ) - call gradq ( chi,dchidx,dchidy,imana,jmana ) - call gradq ( psi,dpsidx,dpsidy,imana,jmana ) - dumu(:,:,L) = dchidx - dpsidy - dumv(:,:,L) = dpsidx + dchidy - enddo -#endif - - if( lonbeg.eq.0.0 ) call hflip( dumu,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dumu,imana,jmana,u,im,jm,lm,undef ) - else - u = dumu - endif - - if( lonbeg.eq.0.0 ) call hflip( dumv,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dumv,imana,jmana,v,im,jm,lm,undef ) - else - v = dumv - endif - -c Temperature -c ----------- - call gfio_getvar ( id,'temperature',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF Temperature variable' - error stop 7 - endif - if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,t,im,jm,lm,undef ) - else - t = dum3d - endif - -c Relative Humidity -c ----------------- - call gfio_getvar ( id,'relative_humidi',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF Rel.Hum. variable' - error stop 7 - endif - if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,rh,im,jm,lm,undef ) - else - rh = dum3d - endif - rh = max( rh,0.0 ) - -c do n=1,nvars -c if( lmvars(n).gt.1 .and. mlev.gt.lmana ) then -c do L=1,mlev-lmana -c qdum(:,:,L) = qdum(:,:,mlev-lmana+1) -c enddo -c endif -c enddo - -c Compute PHIS -c ------------ - do j=1,jm - do i=1,im - L=1 - do while( L.lt.lm .and. plevs(L).lt.ps(i,j)/100.0 ) - L=L+1 - enddo - LM1 = L-1 - phis(i,j) = h(i,j,L) - ( h(i,j,L)-h(i,j,LM1) )*log( 100*plevs(L)/ps(i,j) )/log( plevs(L)/plevs(LM1) ) - enddo - enddo - phis = phis*grav -#ifdef DEBUG - call writit ( phis,im,jm,1,65 ) -#endif - - do j=1,jm - do i=1,im - L=lm - do while( L.gt.1 .and. plevs(L).gt.ps(i,j)/100.0 ) - L=L-1 - enddo - dp = ps(i,j)/100.0 - plevs(L) - do while( dp.le.150.0 ) - L=L-1 - dp = ps(i,j)/100.0 - plevs(L) - enddo - L=L+1 - gamma = kappa * (0.01*ps(i,j))**kappa * log( slp(i,j)/ps(i,j) ) - . / ( 1.0 - 0.5*beta*rgas/grav * log( slp(i,j)/ps(i,j) ) ) - phis2(i,j) = grav*h(i,j,L)*gamma / ( gamma - plevs(L)**kappa + (0.01*ps(i,j))**kappa ) - enddo - enddo -#ifdef DEBUG - call writit ( phis2,im,jm,1,65 ) -#endif - - do j=1,jm - do i=1,im - L=lm - do while( L.gt.1 .and. plevs(L).gt.ps(i,j)/100.0 ) - L=L-1 - enddo - gamma = rgas * log( slp(i,j)/ps(i,j) ) - phis2(i,j) = gamma * ( t(i,j,L)+beta*h(i,j,L) ) / ( 1+0.5*beta*gamma/grav ) - enddo - enddo -#ifdef DEBUG - call writit ( phis2,im,jm,1,65 ) -#endif - -c Load GMAO Variables -c ------------------- - do L=1,lm - do j=1,jm - do i=1,im - call qsat (t(i,j,L),plevs(L),q(i,j,L),dum,.false.) - q(i,j,L) = rh(i,j,L)*q(i,j,L)*0.01 - enddo - enddo - enddo - - return - end - - subroutine hflip ( q,im,jm,lm ) - implicit none - integer im,jm,lm,i,j,L - real*4 q(im,jm,lm),dum(im) - do L=1,lm - do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j,L) - dum(i+im/2) = q(i,j,L) - enddo - q(:,j,L) = dum(:) - enddo - enddo - return - end - - subroutine writit (q,im,jm,lm,ku) - real q (im,jm,lm) - real*4 q2(im,jm) - do L=lm,1,-1 - q2(:,:) = q(:,:,L) - write(ku) q2 - enddo - return - end - - subroutine qsat (tt,p,q,dqdt,ldqdt) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute Saturation Specific Humidity -C -C INPUT: -C ====== -C TT ......... Temperature (Kelvin) -C P .......... Pressure (mb) -C LDQDT ...... Logical Flag to compute QSAT Derivative -C -C OUTPUT: -C ======= -C Q .......... Saturation Specific Humidity -C DQDT ....... Saturation Specific Humidity Derivative wrt Temperature -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IMPLICIT NONE - REAL TT, P, Q, DQDT - LOGICAL LDQDT - REAL AIRMW, H2OMW - - PARAMETER ( AIRMW = 28.97 ) - PARAMETER ( H2OMW = 18.01 ) - - REAL ESFAC, ERFAC - PARAMETER ( ESFAC = H2OMW/AIRMW ) - PARAMETER ( ERFAC = (1.0-ESFAC)/ESFAC ) - - real aw0, aw1, aw2, aw3, aw4, aw5, aw6 - real bw0, bw1, bw2, bw3, bw4, bw5, bw6 - real ai0, ai1, ai2, ai3, ai4, ai5, ai6 - real bi0, bi1, bi2, bi3, bi4, bi5, bi6 - - real d0, d1, d2, d3, d4, d5, d6 - real e0, e1, e2, e3, e4, e5, e6 - real f0, f1, f2, f3, f4, f5, f6 - real g0, g1, g2, g3, g4, g5, g6 - -c ******************************************************** -c *** Polynomial Coefficients WRT Water (Lowe, 1977) **** -c *** (Valid +50 C to -50 C) **** -c ******************************************************** - - parameter ( aw0 = 6.107799961e+00 * esfac ) - parameter ( aw1 = 4.436518521e-01 * esfac ) - parameter ( aw2 = 1.428945805e-02 * esfac ) - parameter ( aw3 = 2.650648471e-04 * esfac ) - parameter ( aw4 = 3.031240396e-06 * esfac ) - parameter ( aw5 = 2.034080948e-08 * esfac ) - parameter ( aw6 = 6.136820929e-11 * esfac ) - - parameter ( bw0 = +4.438099984e-01 * esfac ) - parameter ( bw1 = +2.857002636e-02 * esfac ) - parameter ( bw2 = +7.938054040e-04 * esfac ) - parameter ( bw3 = +1.215215065e-05 * esfac ) - parameter ( bw4 = +1.036561403e-07 * esfac ) - parameter ( bw5 = +3.532421810e-10 * esfac ) - parameter ( bw6 = -7.090244804e-13 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice (Lowe, 1977) **** -c *** (Valid +0 C to -50 C) **** -c ******************************************************** - - parameter ( ai0 = +6.109177956e+00 * esfac ) - parameter ( ai1 = +5.034698970e-01 * esfac ) - parameter ( ai2 = +1.886013408e-02 * esfac ) - parameter ( ai3 = +4.176223716e-04 * esfac ) - parameter ( ai4 = +5.824720280e-06 * esfac ) - parameter ( ai5 = +4.838803174e-08 * esfac ) - parameter ( ai6 = +1.838826904e-10 * esfac ) - - parameter ( bi0 = +5.030305237e-01 * esfac ) - parameter ( bi1 = +3.773255020e-02 * esfac ) - parameter ( bi2 = +1.267995369e-03 * esfac ) - parameter ( bi3 = +2.477563108e-05 * esfac ) - parameter ( bi4 = +3.005693132e-07 * esfac ) - parameter ( bi5 = +2.158542548e-09 * esfac ) - parameter ( bi6 = +7.131097725e-12 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -40 C to -70 C) **** -c ******************************************************** - - - parameter ( d0 = 0.535098336e+01 * esfac ) - parameter ( d1 = 0.401390832e+00 * esfac ) - parameter ( d2 = 0.129690326e-01 * esfac ) - parameter ( d3 = 0.230325039e-03 * esfac ) - parameter ( d4 = 0.236279781e-05 * esfac ) - parameter ( d5 = 0.132243858e-07 * esfac ) - parameter ( d6 = 0.314296723e-10 * esfac ) - - parameter ( e0 = 0.469290530e+00 * esfac ) - parameter ( e1 = 0.333092511e-01 * esfac ) - parameter ( e2 = 0.102164528e-02 * esfac ) - parameter ( e3 = 0.172979242e-04 * esfac ) - parameter ( e4 = 0.170017544e-06 * esfac ) - parameter ( e5 = 0.916466531e-09 * esfac ) - parameter ( e6 = 0.210844486e-11 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -65 C to -95 C) **** -c ******************************************************** - - parameter ( f0 = 0.298152339e+01 * esfac ) - parameter ( f1 = 0.191372282e+00 * esfac ) - parameter ( f2 = 0.517609116e-02 * esfac ) - parameter ( f3 = 0.754129933e-04 * esfac ) - parameter ( f4 = 0.623439266e-06 * esfac ) - parameter ( f5 = 0.276961083e-08 * esfac ) - parameter ( f6 = 0.516000335e-11 * esfac ) - - parameter ( g0 = 0.312654072e+00 * esfac ) - parameter ( g1 = 0.195789002e-01 * esfac ) - parameter ( g2 = 0.517837908e-03 * esfac ) - parameter ( g3 = 0.739410547e-05 * esfac ) - parameter ( g4 = 0.600331350e-07 * esfac ) - parameter ( g5 = 0.262430726e-09 * esfac ) - parameter ( g6 = 0.481960676e-12 * esfac ) - - REAL TMAX, TICE - PARAMETER ( TMAX=323.15, TICE=273.16) - - REAL T, D, W, QX, DQX - T = MIN(TT,TMAX) - TICE - DQX = 0. - QX = 0. - -c Fitting for temperatures above 0 degrees centigrade -c --------------------------------------------------- - if(t.gt.0.) then - qx = aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6))))) - if (ldqdt) then - dqx = bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6))))) - endif - endif - -c Fitting for temperatures between 0 and -40 -c ------------------------------------------ - if( t.le.0. .and. t.gt.-40.0 ) then - w = (40.0 + t)/40.0 - qx = w *(aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6)))))) - . + (1.-w)*(ai0+T*(ai1+T*(ai2+T*(ai3+T*(ai4+T*(ai5+T*ai6)))))) - if (ldqdt) then - dqx = w *(bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6)))))) - . + (1.-w)*(bi0+T*(bi1+T*(bi2+T*(bi3+T*(bi4+T*(bi5+T*bi6)))))) - endif - endif - -c Fitting for temperatures between -40 and -70 -c -------------------------------------------- - if( t.le.-40.0 .and. t.ge.-70.0 ) then - qx = d0+T*(d1+T*(d2+T*(d3+T*(d4+T*(d5+T*d6))))) - if (ldqdt) then - dqx = e0+T*(e1+T*(e2+T*(e3+T*(e4+T*(e5+T*e6))))) - endif - endif - -c Fitting for temperatures less than -70 -c -------------------------------------- - if(t.lt.-70.0) then - qx = f0+t*(f1+t*(f2+t*(f3+t*(f4+t*(f5+t*f6))))) - if (ldqdt) then - dqx = g0+t*(g1+t*(g2+t*(g3+t*(g4+t*(g5+t*g6))))) - endif - endif - -c Compute Saturation Specific Humidity -c ------------------------------------ - D = (P-ERFAC*QX) - IF(D.LT.0.) THEN - Q = 1.0 - IF (LDQDT) DQDT = 0. - ELSE - D = 1.0 / D - Q = MIN(QX * D,1.0) - IF (LDQDT) DQDT = (1.0 + ERFAC*Q) * D * DQX - ENDIF - RETURN - END - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*abs(undef) - return - end - - subroutine getchar (name,num) - character*2 num2 - character*3 num3 - integer num - character*1 junk(256) - character*1 name(256) - data junk /256*' '/ - equivalence ( num2,junk ) - equivalence ( num3,junk ) - - num2 = ' ' - num3 = ' ' - - if( num.lt.100 ) then - write(num2,102) num - else if( num.lt.1000 ) then - write(num3,103) num - endif - - name = junk - - 102 format(i2.2) - 103 format(i3.3) - - return - end - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end - - function nsecf2 (nhhmmss,nmmdd,nymd) -C*********************************************************************** -C Purpose -C Computes the Total Number of seconds from NYMD using NHHMMSS & NMMDD -C -C Arguments Description -C NHHMMSS IntervaL Frequency (HHMMSS) -C NMMDD Interval Frequency (MMDD) -C NYMD Current Date (YYMMDD) -C -C NOTE: -C IF (NMMDD.ne.0), THEN HOUR FREQUENCY HH MUST BE < 24 -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - PARAMETER ( NSDAY = 86400 ) - PARAMETER ( NCYCLE = 1461*24*3600 ) - - INTEGER YEAR, DAY, SEC - - DIMENSION MNDY(12,4) - DATA MNDY /0,31,60,91,121,152,182,213,244,274,305,335,366, - . 397,34*0 / - -C*********************************************************************** -C* COMPUTE # OF SECONDS FROM NHHMMSS * -C*********************************************************************** - - nsecf2 = nsecf( nhhmmss ) - - if( nmmdd.eq.0 ) return - -C*********************************************************************** -C* COMPUTE # OF DAYS IN A 4-YEAR CYCLE * -C*********************************************************************** - - DO 100 I=15,48 - MNDY(I,1) = MNDY(I-12,1) + 365 -100 CONTINUE - -C*********************************************************************** -C* COMPUTE # OF SECONDS FROM NMMDD * -C*********************************************************************** - - nsegm = nmmdd/100 - nsegd = mod(nmmdd,100) - - YEAR = NYMD / 10000 - MONTH = MOD(NYMD,10000) / 100 - DAY = MOD(NYMD,100) - SEC = NSECF(NHMS) - - IDAY = MNDY( MONTH ,MOD(YEAR ,4)+1 ) - month = month + nsegm - If( month.gt.12 ) then - month = month - 12 - year = year + 1 - endif - IDAY2 = MNDY( MONTH ,MOD(YEAR ,4)+1 ) - - nday = iday2-iday - if(nday.lt.0) nday = nday + 1461 - nday = nday + nsegd - - nsecf2 = nsecf2 + nday*nsday - - return - end - - subroutine remap ( ps1,dp1,u1,v1,thv1,q1,phis1,lm1, - . ps2,dp2,u2,v2,t2 ,q2,phis2,lm2,im,jm,nq,pbelow,pabove ) - -C*********************************************************************** -C -C Purpose -C Driver for remapping of target analysis to fv model levels -C -C Argument Description -C ps1 ...... model surface pressure -C dp1 ...... model pressure thickness -C u1 ....... model zonal wind -C v1 ....... model meridional wind -C thv1 ..... model virtual potential temperature -C q1 ....... model specific humidity -C oz1 ...... model ozone -C phis1 .... model surface geopotential -C lm1 ...... model vertical dimension -C -C ps2 ...... analysis surface pressure -C dp2 ...... analysis pressure thickness -C u2 ....... analysis zonal wind -C v2 ....... analysis meridional wind -C t2 . ..... analysis dry-bulb temperature -C q2 ....... analysis specific humidity -C oz2 ...... analysis ozone -C phis2 .... analysis surface geopotential -C lm2 ...... analysis vertical dimension -C -C im ....... zonal dimension -C jm ....... meridional dimension -C nq ....... number of trancers -C pbelow ... pressure below which analysis is used completely -C pabove ... pressure above which model is used completely -C Note: a blend is used in-between pbelow and pabove -C If pbelow=pabove, blending code is disabled -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - integer im,jm,nq,lm1,lm2 - -c fv-DAS variables -c ---------------- - real dp1(im,jm,lm1), dp0(im,jm,lm1) - real u1(im,jm,lm1), u0(im,jm,lm1) - real v1(im,jm,lm1), v0(im,jm,lm1) - real thv1(im,jm,lm1), thv0(im,jm,lm1) - real q1(im,jm,lm1,nq), q0(im,jm,lm1,nq) - real ps1(im,jm), ps0(im,jm) - - real phis1(im,jm) - real ak(lm1+1) - real bk(lm1+1) - -c Target analysis variables -c ------------------------- - real dp2(im,jm,lm2) - real u2(im,jm,lm2) - real v2(im,jm,lm2) - real t2(im,jm,lm2) - real thv2(im,jm,lm2) - real q2(im,jm,lm2,nq) - real ps2(im,jm) - real phis2(im,jm) - -c Local variables -c --------------- - real pe0(im,jm,lm1+1) - real pe1(im,jm,lm1+1) - real pe2(im,jm,lm2+1) - real pk (im,jm,lm2 ) - real pke0(im,jm,lm1+1) - real pke1(im,jm,lm1+1) - real pke2(im,jm,lm2+1) - real phi2(im,jm,lm2+1) - - real kappa,cp,ptop,pbelow,pabove,pl,alf,pint - real rgas,pref,tref,pkref,tstar,eps,rvap,grav - integer i,j,L,n,ks - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - - call set_eta ( lm1,ks,ptop,pint,ak,bk ) - -c Compute edge-level pressures -c ---------------------------- - pe1(:,:,lm1+1) = ps1(:,:) - do L=lm1,1,-1 - pe1(:,:,L) = pe1(:,:,L+1)-dp1(:,:,L) - enddo - -c Copy input fv state into local variables -c ---------------------------------------- - ps0(:,:) = ps1(:,:) - dp0(:,:,:) = dp1(:,:,:) - u0(:,:,:) = u1(:,:,:) - v0(:,:,:) = v1(:,:,:) - thv0(:,:,:) = thv1(:,:,:) - q0(:,:,:,:) = q1(:,:,:,:) - pe0(:,:,:) = pe1(:,:,:) - pke0(:,:,:) = pe0(:,:,:)**kappa - -c Construct target analysis pressure variables -c -------------------------------------------- - do j=1,jm - do i=1,im - pe2(i,j,lm2+1) = ps2(i,j) - enddo - enddo - - do L=lm2,1,-1 - do j=1,jm - do i=1,im - pe2(i,j,L) = pe2(i,j,L+1) - dp2(i,j,L) - enddo - enddo - enddo - - do j=1,jm - do i=1,im - pe2(i,j,1) = 1.0 ! Set ptop = 0.01 mb - enddo - enddo - - do L=1,lm2+1 - do j=1,jm - do i=1,im - pke2(i,j,L) = pe2(i,j,L)**kappa - enddo - enddo - enddo - -c Construct target virtual potential temperature -c ---------------------------------------------- - do L=1,lm2 - do j=1,jm - do i=1,im - pk (i,j,L) = ( pke2(i,j,L+1)-pke2(i,j,L) )/( kappa*log(pe2(i,j,L+1)/pe2(i,j,L)) ) - thv2(i,j,L) = t2(i,j,L)*( 1.0+eps*max(0.0,q2(i,j,L,1)) )/pk(i,j,L) - enddo - enddo - enddo - -c Construct target analysis heights -c --------------------------------- - phi2(:,:,lm2+1) = phis2(:,:) - do L=lm2,1,-1 - phi2(:,:,L) = phi2(:,:,L+1) + cp*thv2(:,:,L)*( pke2(:,:,L+1)-pke2(:,:,L) ) - enddo - -c Compute new surface pressure consistent with fv topography -c ---------------------------------------------------------- - do j=1,jm - do i=1,im - L = lm2 - do while ( phi2(i,j,L).lt.phis1(i,j) ) - L = L-1 - enddo - ps1(i,j) = pe2(i,j,L+1)*( 1 + (phi2(i,j,L+1)-phis1(i,j))/(cp*thv2(i,j,L)*pke2(i,j,L+1)) )**(1.0/kappa) - enddo - enddo - -c Construct fv pressure variables using new surface pressure -c ---------------------------------------------------------- - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1(i,j,L) = ak(L) + bk(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -c Map original fv state onto new eta grid -c --------------------------------------- - print *, ' ReMapping Original FV-State onto New Eta Grid' - call gmap ( im,jm,nq, kappa, - . lm1, pke0, pe0, u1, v1, thv1, q1, - . lm1, pke1, pe1, u0, v0, thv0, q0) - -c Map target analysis onto fv grid -c -------------------------------- - print *, ' Mapping Analysis-State onto New Eta Grid' - call gmap ( im,jm,nq, kappa, - . lm2, pke2, pe2, u2, v2, thv2, q2, - . lm1, pke1, pe1, u1, v1, thv1, q1) - -c Blend result with original fv state -c ----------------------------------- - if( pbelow.ne.pabove ) then - print *, ' Blending FV and Analysis States' - do L=1,lm1 - do j=1,jm - do i=1,im - pl=0.5*(pe1(i,j,L+1)+pe1(i,j,L)) - alf=(pl-pabove)/(pbelow-pabove) - if( pl.lt.pabove ) then - u1(i,j,L) = u0(i,j,L) - v1(i,j,L) = v0(i,j,L) - thv1(i,j,L) = thv0(i,j,L) - else if( pl.lt.pbelow ) then - u1(i,j,L) = u1(i,j,L)*alf + u0(i,j,L)*(1-alf) - v1(i,j,L) = v1(i,j,L)*alf + v0(i,j,L)*(1-alf) - thv1(i,j,L) = thv1(i,j,L)*alf + thv0(i,j,L)*(1-alf) - endif - enddo - enddo - enddo - do n=1,nq - do L=1,lm1 - do j=1,jm - do i=1,im - pl=0.5*(pe1(i,j,L+1)+pe1(i,j,L)) - alf=(pl-pabove)/(pbelow-pabove) - if( pl.lt.pabove ) then - q1(i,j,L,n) = q0(i,j,L,n) - else if( pl.lt.pbelow ) then - q1(i,j,L,n) = q1(i,j,L,n)*alf + q0(i,j,L,n)*(1-alf) - endif - enddo - enddo - enddo - enddo - endif - - return - end - - subroutine gauss_lat_nmc(gaul,k) - implicit double precision (a-h,o-z) - dimension a(500) - real gaul(1) - save - esp=1.d-14 - c=(1.d0-(2.d0/3.14159265358979d0)**2)*0.25d0 - fk=k - kk=k/2 - call bsslz1(a,kk) - do 30 is=1,kk - xz=cos(a(is)/sqrt((fk+0.5d0)**2+c)) - iter=0 - 10 pkm2=1.d0 - pkm1=xz - iter=iter+1 - if(iter.gt.10) go to 70 - do 20 n=2,k - fn=n - pk=((2.d0*fn-1.d0)*xz*pkm1-(fn-1.d0)*pkm2)/fn - pkm2=pkm1 - 20 pkm1=pk - pkm1=pkm2 - pkmrk=(fk*(pkm1-xz*pk))/(1.d0-xz**2) - sp=pk/pkmrk - xz=xz-sp - avsp=abs(sp) - if(avsp.gt.esp) go to 10 - a(is)=xz - 30 continue - if(k.eq.kk*2) go to 50 - a(kk+1)=0.d0 - pk=2.d0/fk**2 - do 40 n=2,k,2 - fn=n - 40 pk=pk*fn**2/(fn-1.d0)**2 - 50 continue - do 60 n=1,kk - l=k+1-n - a(l)=-a(n) - 60 continue - radi=180./(4.*atan(1.)) - do 211 n=1,k - gaul(n)=acos(a(n))*radi-90.0 - 211 continue - return - 70 write(6,6000) - 6000 format(//5x,14herror in gauaw//) - stop - end - - subroutine bsslz1(bes,n) - implicit double precision (a-h,o-z) - dimension bes(n) - dimension bz(50) - data pi/3.14159265358979d0/ - data bz / 2.4048255577d0, 5.5200781103d0, - $ 8.6537279129d0,11.7915344391d0,14.9309177086d0,18.0710639679d0, - $ 21.2116366299d0,24.3524715308d0,27.4934791320d0,30.6346064684d0, - $ 33.7758202136d0,36.9170983537d0,40.0584257646d0,43.1997917132d0, - $ 46.3411883717d0,49.4826098974d0,52.6240518411d0,55.7655107550d0, - $ 58.9069839261d0,62.0484691902d0,65.1899648002d0,68.3314693299d0, - $ 71.4729816036d0,74.6145006437d0,77.7560256304d0,80.8975558711d0, - $ 84.0390907769d0,87.1806298436d0,90.3221726372d0,93.4637187819d0, - $ 96.6052679510d0,99.7468198587d0,102.888374254d0,106.029930916d0, - $ 109.171489649d0,112.313050280d0,115.454612653d0,118.596176630d0, - $ 121.737742088d0,124.879308913d0,128.020877005d0,131.162446275d0, - $ 134.304016638d0,137.445588020d0,140.587160352d0,143.728733573d0, - $ 146.870307625d0,150.011882457d0,153.153458019d0,156.295034268d0/ - nn=n - if(n.le.50) go to 12 - bes(50)=bz(50) - do 5 j=51,n - 5 bes(j)=bes(j-1)+pi - nn=49 - 12 do 15 j=1,nn - 15 bes(j)=bz(j) - return - end - - - subroutine get_ozone ( ozone,pl,im,jm,lm,nymd,nhms ) - implicit none - - integer nlats - integer nlevs - parameter ( nlats = 37 ) ! 37 Latitudes - parameter ( nlevs = 34 ) ! 34 Pressure Levels - - real o3(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - -c Input Variables -c --------------- - integer im,jm,lm,nymd,nhms - real ozone(im,jm,lm) - real pl(im,jm,lm) - -c Local Variables -c --------------- - real xlat(im,jm) - integer i,j,koz - - real voltomas - PARAMETER ( VOLTOMAS = 1.655E-6 ) - - koz = 40 - - do j=1,jm - do i=1,im - xlat(i,j) = -90. + (j-1)*180./(jm-1) - enddo - enddo - - call chemistry (koz,nymd,nhms,o3,lats,levs,nlats,nlevs) - call interp_oz (o3,lats,levs,nlats,nlevs,im*jm,xlat,lm,pl,ozone) - - ozone(:,:,:) = ozone(:,:,:) * VOLTOMAS - - return - end - - subroutine chemistry (koz,nymd,nhms,ozone,lats,levs,nlats,nlevs) -C*********************************************************************** -C PURPOSE -C Chemistry Model -C -C ARGUMENTS DESCRIPTION -C koz Unit to read Stratospheric Ozone -C kqz Unit to read Stratospheric Moisture -C nymd Current Date -C nhms Current Time -C -C chemistry .. Chemistry State Data Structure -C grid ....... Dynamics Grid Data Structure -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer koz - integer nymd,nhms - - integer nlats - integer nlevs - real ozone(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - real o3(nlats,nlevs,12) - -c Local Variables -c --------------- - integer j,L - integer nymd1,nhms1,nymd2,nhms2,ipls,imns - real facm,facp - -C ********************************************************************** -C **** Read Ozone and Moisture Data (12 Monthly Means) **** -C ********************************************************************** - - call read_oz (koz,o3,lats,levs,nlats,nlevs,12) - -C ********************************************************************** -C **** Update Chemistry State to Current Time **** -C ********************************************************************** - - call time_bound ( nymd, nymd1,nhms1, nymd2,nhms2, imns,ipls ) - call interp_time ( nymd,nhms, nymd1,nhms1, nymd2,nhms2, facm,facp ) - - do L = 1,nlevs - do j = 1,nlats - ozone(j,L) = o3(j,L,imns)*facm + o3(j,L,ipls)*facp - enddo - enddo - - return - end - - subroutine read_oz (ku,oz,lats,levs,nlat,nlev,ntime) -C*********************************************************************** -C PURPOSE -C To Read Ozone Value -C -C ARGUMENTS DESCRIPTION -C ku ...... Unit to Read Ozone Data -C oz ...... Ozone Data -C lats .... Ozone Data Latitudes (degrees) -C levs .... Ozone Data Levels (mb) -C nlat .... Number of ozone latitudes -C nlev .... Number of ozone levels -C ntime ... Number of ozone time values -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer ku,nlat,nlev,ntime - - real oz(nlat,nlev,ntime) - real*4 o3(nlat) - real lats(nlat) - real levs(nlev) - - integer time - integer lat - integer lev - integer nrec - - real plevs(34) - data plevs/ 0.003, 0.005, 0.007, 0.01, 0.015, 0.02, 0.03, 0.05, - . 0.07, 0.1, 0.15, 0.2, 0.3, 0.5, 0.7, 1.0, 1.5, 2.0, - . 3.0, 5.0, 7.0, 10.0, 15.0, 20.0, 30.0, 50.0, 70.0, - . 100.0, 150.0, 200.0, 300.0, 500.0, 700.0, 1000.0 / - - rewind ku - -c Set Ozone Data Latitudes -c ------------------------ - do lat = 1,nlat - lats(lat) = -90. + (lat-1)*5. - enddo - -c Set Ozone Data Levels -c ------------------------ - do lev = 1,nlev - levs(lev) = plevs(lev)*100 - enddo - -c Read Ozone Amounts by Month and Level -c ------------------------------------- - close (ku) - open (ku, file="/home/ltakacs/data/bcs/TSMo3.v02.gra", - . form='unformatted', access='direct', recl=nlat*4) - - do time=1,ntime - do lev=1,nlev - nrec = lev+(time-1)*nlev*2 ! Note: 2 quantities in Ozone Dataset - read(ku,rec=nrec) o3 - do lat=1,nlat - oz(lat,nlev-lev+1,time) = o3(lat) - enddo - enddo - enddo - - close (ku) - return - end - - subroutine interp_oz (ozone,lats,levs,nlats,nlevs,irun ,xlat,km,plevs,ozrad) - -c Declare Modules and Data Structures -c ----------------------------------- - implicit none - integer nlats,nlevs - real ozone(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - - integer irun,km - real xlat (irun) - real plevs (irun,km) - real ozrad (irun,km) - -c Local Variables -c --------------- - real zero,one,o3min - PARAMETER ( ZERO = 0.0 ) - PARAMETER ( ONE = 1.0 ) - PARAMETER ( O3MIN = 1.0E-10 ) - - integer i,k,L1,L2,LM,LP - integer jlat,jlatm,jlatp - real O3INT1(IRUN,nlevs) - real QPR1(IRUN), QPR2(IRUN), SLOPE(IRUN) - real PR1(IRUN), PR2(IRUN) - -C ********************************************************************** -C **** INTERPOLATE ozone data to model latitudes *** -C ********************************************************************** - - DO 32 K=1,nlevs - DO 34 I=1,IRUN - - DO 36 jlat = 1,nlats - IF( lats(jlat).gt.xlat(i) ) THEN - IF( jlat.EQ.1 ) THEN - jlatm = 1 - jlatp = 1 - slope(i) = zero - ELSE - jlatm = jlat-1 - jlatp = jlat - slope(i) = ( XLAT(I) -lats(jlat-1) ) - . / ( lats(jlat)-lats(jlat-1) ) - ENDIF - GOTO 37 - ENDIF - 36 CONTINUE - jlatm = nlats - jlatp = nlats - slope(i) = one - 37 CONTINUE - QPR1(I) = ozone(jlatm,k) - QPR2(I) = ozone(jlatp,k) - 34 CONTINUE - - DO 38 I=1,IRUN - o3int1(i,k) = qpr1(i) + slope(i)*( qpr2(i)-qpr1(i) ) - 38 CONTINUE - - 32 CONTINUE - -C ********************************************************************** -C **** INTERPOLATE latitude ozone data to model pressures *** -C ********************************************************************** - - DO 40 L2 = 1,km - - DO 44 I = 1,IRUN - DO 46 L1 = 1,nlevs - IF( levs(L1).GT.PLEVS(I,L2) ) THEN - IF( L1.EQ.1 ) THEN - LM = 1 - LP = 2 - ELSE - LM = L1-1 - LP = L1 - ENDIF - GOTO 47 - ENDIF - 46 CONTINUE - LM = nlevs-1 - LP = nlevs - 47 CONTINUE - PR1(I) = levs (LM) - PR2(I) = levs (LP) - QPR1(I) = O3INT1(I,LM) - QPR2(I) = O3INT1(I,LP) - 44 CONTINUE - - DO 48 I=1,IRUN - SLOPE(I) = ( QPR1(I)-QPR2(I) ) - . / ( PR1(I)- PR2(I) ) - ozrad(I,L2) = QPR2(I) + ( PLEVS(I,L2)-PR2(I) )*SLOPE(I) - - if( ozrad(i,l2).lt.o3min ) then - ozrad(i,l2) = o3min - endif - - 48 CONTINUE - 40 CONTINUE - - RETURN - END - - subroutine interp_time ( nymd ,nhms , - . nymd1,nhms1, nymd2,nhms2, fac1,fac2 ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute interpolation factors, fac1 & fac2, to be used in the -C calculation of the instantanious boundary conditions, ie: -C -C q(i,j) = fac1*q1(i,j) + fac2*q2(i,j) -C where: -C q(i,j) => Boundary Data valid at (nymd , nhms ) -C q1(i,j) => Boundary Data centered at (nymd1 , nhms1) -C q2(i,j) => Boundary Data centered at (nymd2 , nhms2) -C -C INPUT: -C ====== -C nymd : Date (yymmdd) of Current Timestep -C nhms : Time (hhmmss) of Current Timestep -C nymd1 : Date (yymmdd) of Boundary Data 1 -C nhms1 : Time (hhmmss) of Boundary Data 1 -C nymd2 : Date (yymmdd) of Boundary Data 2 -C nhms2 : Time (hhmmss) of Boundary Data 2 -C -C OUTPUT: -C ======= -C fac1 : Interpolation factor for Boundary Data 1 -C fac2 : Interpolation factor for Boundary Data 2 -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER YEAR , MONTH , DAY , SEC - INTEGER YEAR1, MONTH1, DAY1, SEC1 - INTEGER YEAR2, MONTH2, DAY2, SEC2 - - real fac1, fac2 - real time, time1, time2 - - INTEGER DAYSCY - PARAMETER (DAYSCY = 365*4+1) - - REAL MNDY(12,4) - - LOGICAL FIRST - DATA FIRST/.TRUE./ - - DATA MNDY /0,31,60,91,121,152,182,213,244,274,305,335,366, - . 397,34*0 / - -C*********************************************************************** -C* SET TIME BOUNDARIES * -C*********************************************************************** - - YEAR = NYMD / 10000 - MONTH = MOD(NYMD,10000) / 100 - DAY = MOD(NYMD,100) - SEC = NSECF(NHMS) - - YEAR1 = NYMD1 / 10000 - MONTH1 = MOD(NYMD1,10000) / 100 - DAY1 = MOD(NYMD1,100) - SEC1 = NSECF(NHMS1) - - YEAR2 = NYMD2 / 10000 - MONTH2 = MOD(NYMD2,10000) / 100 - DAY2 = MOD(NYMD2,100) - SEC2 = NSECF(NHMS2) - -C*********************************************************************** -C* COMPUTE DAYS IN 4-YEAR CYCLE * -C*********************************************************************** - - IF(FIRST) THEN - DO I=15,48 - MNDY(I,1) = MNDY(I-12,1) + 365 - ENDDO - FIRST=.FALSE. - ENDIF - -C*********************************************************************** -C* COMPUTE INTERPOLATION FACTORS * -C*********************************************************************** - - time = DAY + MNDY(MONTH ,MOD(YEAR ,4)+1) + float(sec )/86400. - time1 = DAY1 + MNDY(MONTH1,MOD(YEAR1,4)+1) + float(sec1)/86400. - time2 = DAY2 + MNDY(MONTH2,MOD(YEAR2,4)+1) + float(sec2)/86400. - - if( time .lt.time1 ) time = time + dayscy - if( time2.lt.time1 ) time2 = time2 + dayscy - - fac1 = (time2-time)/(time2-time1) - fac2 = (time-time1)/(time2-time1) - - RETURN - END - - subroutine time_bound ( nymd,nymd1,nhms1,nymd2,nhms2, imnm,imnp ) -C*********************************************************************** -C PURPOSE -C Compute Date and Time boundaries. -C -C ARGUMENTS DESCRIPTION -C nymd .... Current Date -C nhms .... Current Time -C nymd1 ... Previous Date Boundary -C nhms1 ... Previous Time Boundary -C nymd2 ... Subsequent Date Boundary -C nhms2 ... Subsequent Time Boundary -C -C imnm .... Previous Time Index for Interpolation -C imnp .... Subsequent Time Index for Interpolation -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer nymd, nymd1,nhms1, nymd2,nhms2 - -c Local Variables -c --------------- - integer month,day,nyear,midmon1,midmon,midmon2 - integer imnm,imnp - INTEGER DAYS(14), daysm, days0, daysp - DATA DAYS /31,31,28,31,30,31,30,31,31,30,31,30,31,31/ - - integer nmonf,ndayf,n - NMONF(N) = MOD(N,10000)/100 - NDAYF(N) = MOD(N,100) - -C********************************************************************* -C**** Find Proper Month and Time Boundaries for Climatological Data ** -C********************************************************************* - - MONTH = NMONF(NYMD) - DAY = NDAYF(NYMD) - - daysm = days(month ) - days0 = days(month+1) - daysp = days(month+2) - -c Check for Leap Year -c ------------------- - nyear = nymd/10000 - if( 4*(nyear/4).eq.nyear ) then - if( month.eq.3 ) daysm = daysm+1 - if( month.eq.2 ) days0 = days0+1 - if( month.eq.1 ) daysp = daysp+1 - endif - - MIDMON1 = daysm/2 + 1 - MIDMON = days0/2 + 1 - MIDMON2 = daysp/2 + 1 - - - IF(DAY.LT.MIDMON) THEN - imnm = month - imnp = month + 1 - nymd2 = (nymd/10000)*10000 + month*100 + midmon - nhms2 = 000000 - nymd1 = nymd2 - nhms1 = nhms2 - call tick ( nymd1,nhms1, -midmon *86400 ) - call tick ( nymd1,nhms1,-(daysm-midmon1)*86400 ) - ELSE - IMNM = MONTH + 1 - IMNP = MONTH + 2 - nymd1 = (nymd/10000)*10000 + month*100 + midmon - nhms1 = 000000 - nymd2 = nymd1 - nhms2 = nhms1 - call tick ( nymd2,nhms2,(days0-midmon)*86400 ) - call tick ( nymd2,nhms2, midmon2*86400 ) - ENDIF - -c ------------------------------------------------------------- -c Note: At this point, imnm & imnp range between 01-14, where -c 01 -> Previous years December -c 02-13 -> Current years January-December -c 14 -> Next years January -c ------------------------------------------------------------- - - imnm = imnm-1 - imnp = imnp-1 - - if( imnm.eq.0 ) imnm = 12 - if( imnp.eq.0 ) imnp = 12 - if( imnm.eq.13 ) imnm = 1 - if( imnp.eq.13 ) imnp = 1 - - return - end - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - END - - FUNCTION INCYMD (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - - RETURN - END - - subroutine usage() - print *, "Usage: " - print * - print *, " ec2fv.x [-ecmwf ecmwf.data]" - print *, " [-ctl ecmwf.ctl]" - print *, " [-bkg bkg.data]" - print *, " [-nymd nymd]" - print *, " [-nhms nhms]" - print *, " [-plow plow]" - print *, " [-phigh phigh]" - print *, " [-tag tag]" - print *, " [-ozone]" - print * - print *, "where:" - print * - print *, " -ecmwf ecmwf.data: Filename of ECMWF Pressure-Level analysis data" - print *, " -ctl ecmwf.ctl : Filename of ECMWF Pressure-Level analysis ctl" - print *, " -bkg bkg.data: Filename of GMAO Background Data (ana.eta format)" - print * - print *, " -plow plow: Pressure Level to begin blending" - print *, " -phigh phigh: Pressure Level to end blending" - print * - print *, " -nymd nymd: Desired date in yyyymmdd format" - print *, " -nhms nhms: Desired time in hhmmss format" - print * - print *, " -tag tag: Optional Prefix tag for output files" - print *, " -ozone Optional Flag to add ozone" - print * - error stop 7 - end - - subroutine get_slp ( ps,phis,slp,pe,pk,tv,rgas,grav,im,jm,km ) - implicit none - integer im,jm,km - real grav - real rgas - real pk(im,jm,km) ! layer-mean P**kappa - real tv(im,jm,km) ! layer-mean virtual Temperature - real pe(im,jm,km+1) ! press at layer edges (Pa) - real ps(im,jm) ! surface pressure (Pa) - real phis(im,jm) ! surface geopotential - real slp(im,jm) ! sea-level pressure (hPa) - - real p_offset - real p_bot - real tstar ! extrapolated temperature (K) - real tref ! Reference virtual temperature (K) - real pref ! Reference pressure level (Pa) - real pkref ! Reference pressure level (Pa) ** kappa - real dp1, dp2 - real factor, yfactor - real gg - real gamma - integer k_bot, k, k1, k2, i,j - - gamma = 6.5e-3 - gg = gamma / grav - factor = grav / ( Rgas * gamma ) - yfactor = Rgas * gg - p_offset = 15000. ! 150 hPa above surface - - do j=1,jm - do i=1,im - p_bot = ps(i,j) - p_offset - k_bot = -1 - do k = km, 2, -1 - if ( pe(i,j,k+1) .lt. p_bot ) then - k_bot = k - go to 123 - endif - enddo -123 continue - k1 = k_bot - 1 - k2 = k_bot - dp1 = pe(i,j,k_bot) - pe(i,j,k_bot-1) - dp2 = pe(i,j,k_bot+1) - pe(i,j,k_bot) - pkref = ( pk(i,j,k1)*dp1 + pk(i,j,k2)*dp2 ) / (dp1+dp2) - tref = ( tv(i,j,k1)*dp1 + tv(i,j,k2)*dp2 ) / (dp1+dp2) - pref = 0.5 * ( pe(i,j,k_bot+1) + pe(i,j,k_bot-1) ) - tstar = tref*( ps(i,j)/pref )**yfactor - slp(i,j) = ps(i,j)*( 1.0+gg*phis(i,j)/tstar )**factor - enddo - enddo - - return - end - -C ********************************************************************** -C **** Read Grads CTL File for Meta Data **** -C ********************************************************************** - - subroutine read_ctl ( ctlfile,im,jm,lm,undef,format, - . nvars,names,descs,lmvars, - . lats,lons,levs ) - implicit none - - character*256, pointer :: names(:) - character*256, pointer :: descs(:) - integer, pointer :: lmvars(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - real, pointer :: levs(:) - - character*256 ctlfile, format - integer im,jm,lm,nvars - real undef,dx,dy,dz - integer i,j,L,m,n,ndum - character*256 dummy - character*256, allocatable :: dum(:) - - open (10,file=trim(ctlfile),form='formatted') - format = 'direct' - do - read(10,*,end=500) dummy - -c OPTIONS -c ------- - if( trim(dummy).eq.'options' ) then - ndum = 1 - do - backspace(10) - allocate ( dum(ndum) ) - read(10,*,err=101) dummy - if( trim(dummy).eq.'options' ) then - backspace(10) - read(10,*,end=101) dummy,( dum(n),n=1,ndum ) - else - goto 101 - endif - if( trim(dum(ndum)).eq.'sequential' ) format = 'sequential' - deallocate ( dum ) - ndum = ndum + 1 - enddo - 100 format(a5) - 101 continue - deallocate ( dum ) - endif - -c XDEF -c ---- - if( trim(dummy).eq.'xdef' ) then - backspace(10) - read(10,*) dummy,im - allocate( lons(im) ) - backspace(10) - read(10,*) dummy,im,dummy,lons(1),dx - if( trim(dummy).eq.'linear' ) then - do i=2,im - lons(i) = lons(i-1) + dx - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lons(i),i=1,im) - endif - endif - -c YDEF -c ---- - if( trim(dummy).eq.'ydef' ) then - backspace(10) - read(10,*) dummy,jm - allocate( lats(jm) ) - backspace(10) - read(10,*) dummy,jm,dummy,lats(1),dy - if( trim(dummy).eq.'linear' ) then - do j=2,jm - lats(j) = lats(j-1) + dy - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lats(j),j=1,jm) - endif - endif - -c ZDEF -c ---- - if( trim(dummy).eq.'zdef' ) then - backspace(10) - read(10,*) dummy,lm -#if 1 - allocate( levs(lm) ) - backspace(10) - if( lm.eq.1 ) then - read(10,*) dummy,lm,dummy,levs(1) - else - read(10,*) dummy,lm,dummy,levs(1),dz - endif - if( trim(dummy).eq.'linear' ) then - do L=2,lm - levs(L) = levs(L-1) + dz - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(levs(L),L=1,lm) - endif -#endif - endif - -c UNDEF -c ----- - if( trim(dummy).eq.'undef' ) then - backspace(10) - read(10,*) dummy,undef - endif - - if( trim(dummy).eq.'vars' ) then - backspace(10) - read(10,*) dummy,nvars - allocate( names(nvars) ) - allocate( descs(nvars) ) - allocate( lmvars(nvars) ) - - do n=1,nvars - read(10,*) names(n),lmvars(n),m,descs(n) - if( lmvars(n).eq.0 ) lmvars(n) = 1 - enddo - - endif - enddo - 500 continue - rewind(10) - - if( nvars.eq.0 ) then - print *, 'Warning, nvars = 0!' - stop - endif - - return - end subroutine read_ctl - - subroutine atod_winds ( ua,va,ud,vd,im,jm,lm ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded winds **** -C **** to 'D' gridded winds **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C ****************************************************************** - - real ua(im,jm,lm), ud(im,jm,lm) - real va(im,jm,lm), vd(im,jm,lm) - - call atod ( ua,ud,im,jm,lm,2 ) - call atod ( va,vd,im,jm,lm,1 ) - - return - end - - subroutine dtoa_winds ( ud,vd,ua,va,im,jm,lm ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded winds **** -C **** to 'A' gridded winds **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C ****************************************************************** - - real ua(im,jm,lm), ud(im,jm,lm) - real va(im,jm,lm), vd(im,jm,lm) - - real sinx(im/2) - real cosx(im/2) - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - do i=1,imh - sinx(i) = sin( -pi + (i-1)*dx ) - cosx(i) = cos( -pi + (i-1)*dx ) - enddo - -C ********************************************************* -C **** Average D-Grid Winds **** -C ********************************************************* - - call dtoa ( ud,ua,im,jm,lm,2 ) - call dtoa ( vd,va,im,jm,lm,1 ) - -C ********************************************************* -C **** Fix A-Grid Pole Winds **** -C ********************************************************* - - do L=1,lm - - do m=1,2 - n = (-1)**m - jpole = 1 + (m-1)*(jm-1) - jstar = 2 + (m-1)*(jm-3) - - upole = 0.0 - vpole = 0.0 - do i=1,imh - upole = upole + ( ua(i+imh,jstar,L)-ua(i,jstar,L) )*sinx(i) - . + n*( va(i+imh,jstar,L)-va(i,jstar,L) )*cosx(i) - vpole = vpole - n*( ua(i+imh,jstar,L)-ua(i,jstar,L) )*cosx(i) - . + ( va(i+imh,jstar,L)-va(i,jstar,L) )*sinx(i) - enddo - upole = upole / im - vpole = vpole / im - do i=1,imh - ua(i ,jpole,L) = - upole*sinx(i) + n*vpole*cosx(i) - va(i ,jpole,L) = - n*upole*cosx(i) - vpole*sinx(i) - ua(i+imh,jpole,L) = - ua(i,jpole,L) - va(i+imh,jpole,L) = - va(i,jpole,L) - enddo - enddo - - enddo - - return - end - - subroutine atod ( qa,qd,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded data **** -C **** to 'D' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted left (westward), **** -C **** u is shifted down (southward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real,allocatable :: qax(:,:) - real,allocatable :: cx(:,:) - real,allocatable :: qay(:,:) - real,allocatable :: cy(:,:) - - real,allocatable :: sinx(:) - real,allocatable :: cosx(:) - real,allocatable :: siny(:) - real,allocatable :: cosy(:) - real,allocatable :: trigx(:) - real,allocatable :: trigy(:) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - - allocate( qax ( im+2 ,lm) ) - allocate( cx (2*(im+2),lm) ) - allocate( qay ( 2*jm ,lm) ) - allocate( cy (2*(2*jm),lm) ) - - allocate( cosx(im/2) ) - allocate( sinx(im/2) ) - allocate( cosy(jm) ) - allocate( siny(jm) ) - allocate( trigx(3*(im+1)) ) - allocate( trigy(3*(2*jm)) ) - -C ********************************************************* -C **** shift left (-dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qa(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) + qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) - qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qd(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift down (-dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qa(i,j+1,L) - qay(j+jmm1,L) = -qa(i+imh,jm-j,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) + qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) - qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qd(i,j+1,L) = qay(j,L) - qd(i+imh,jm-j+1,L) = -qay(j+jmm1,L) - enddo - enddo - enddo - - endif - - deallocate( qax ) - deallocate( cx ) - deallocate( qay ) - deallocate( cy ) - - deallocate( cosx ) - deallocate( sinx ) - deallocate( cosy ) - deallocate( siny ) - deallocate( trigx ) - deallocate( trigy ) - - return - end - - subroutine dtoa ( qd,qa,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real,allocatable :: qax(:,:) - real,allocatable :: cx(:,:) - real,allocatable :: qay(:,:) - real,allocatable :: cy(:,:) - - real,allocatable :: sinx(:) - real,allocatable :: cosx(:) - real,allocatable :: siny(:) - real,allocatable :: cosy(:) - real,allocatable :: trigx(:) - real,allocatable :: trigy(:) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - - allocate( qax ( im+2 ,lm) ) - allocate( cx (2*(im+2),lm) ) - allocate( qay ( 2*jm ,lm) ) - allocate( cy (2*(2*jm),lm) ) - - allocate( cosx(im/2) ) - allocate( sinx(im/2) ) - allocate( cosy(jm) ) - allocate( siny(jm) ) - allocate( trigx(3*(im+1)) ) - allocate( trigy(3*(2*jm)) ) - -C ********************************************************* -C **** shift right (dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qd(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) - qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) + qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qa(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift up (dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qd(i,j+1,L) - qay(j+jmm1,L) = -qd(i+imh,jm-j+1,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) - qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) + qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qa(i,j+1,L) = qay(j,L) - qa(i+imh,jm-j,L) = -qay(j+jmm1,L) - enddo - enddo - - enddo - - do L=1,lm - do i=1,imh - qa(i+imh,jm,L) = -qa(i,jm,L) - qa(i,1,L) = -qa(i+imh,1,L) - enddo - enddo - endif - - deallocate( qax ) - deallocate( cx ) - deallocate( qay ) - deallocate( cy ) - - deallocate( cosx ) - deallocate( sinx ) - deallocate( cosy ) - deallocate( siny ) - deallocate( trigx ) - deallocate( trigy ) - - return - end - - subroutine rfftmlt (a,work,trigs,ifax,inc,jump,n,lot,isign) - integer INC, JUMP, N, LOT, ISIGN - real(kind=KIND(1.0)) A(N),WORK(N),TRIGS(N) - integer IFAX(*) -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR -! CALL Q8QST4 ( 4HXLIB, 6HFFT99F, 6HFFT991, 10HVERSION 01) -!FPP$ NOVECTOR R - integer NFAX, NH, NX, INK - integer I, J, IBASE, JBASE, L, IGO, IA, LA, K, M, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, - * INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, - * 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 -!DIR$ IVDEP - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END - - subroutine fftfax (n,ifax,trigs) - integer IFAX(13) - integer N - REAL(kind=KIND(1.0)) TRIGS(*) -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - integer I, MODE - DATA MODE /3/ -!FPP$ NOVECTOR R - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) WRITE(6,FMT="(//5X, ' FFTFAX -- INVALID N =', I5,/)") N - IF (IFAX(1) .LE. 0 ) STOP 999 - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END - - subroutine fft99a (a,work,trigs,inc,jump,n,lot) - integer inc, jump, N, lot - real(kind=KIND(1.0)) A(N),WORK(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 -! (SPECTRAL TO GRIDPOINT TRANSFORM) -! -!FPP$ NOVECTOR R - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) C, S - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - IA=1 - IB=N*INC+1 - JA=1 - JB=2 -!DIR$ IVDEP - DO 10 L=1,LOT - WORK(JA)=A(IA)+A(IB) - WORK(JB)=A(IA)-A(IB) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 10 CONTINUE -! -! REMAINING WAVENUMBERS - IABASE=2*INC+1 - IBBASE=(N-2)*INC+1 - JABASE=3 - JBBASE=N-1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - WORK(JA)=(A(IA)+A(IB))- - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JB)=(A(IA)+A(IB))+ - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+ - * (A(IA+INC)-A(IB+INC)) - WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))- - * (A(IA+INC)-A(IB+INC)) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 20 CONTINUE - IABASE=IABASE+INK - IBBASE=IBBASE-INK - JABASE=JABASE+2 - JBBASE=JBBASE-2 - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE -!DIR$ IVDEP - DO 40 L=1,LOT - WORK(JA)=2.0*A(IA) - WORK(JA+1)=-2.0*A(IA+INC) - IA=IA+JUMP - JA=JA+NX - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fft99b (work,a,trigs,inc,jump,n,lot) - integer INC, JUMP, N, LOT - real(kind=KIND(1.0)) WORK(N),A(N) - REAL(kind=KIND(1.0)) TRIGS(N) - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) SCALE - real(kind=KIND(1.0)) C, S -! -! SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 -! (GRIDPOINT TO SPECTRAL TRANSFORM) -! -!FPP$ NOVECTOR R - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - SCALE=1.0/FLOAT(N) - IA=1 - IB=2 - JA=1 - JB=N*INC+1 -!DIR$ IVDEP - DO 10 L=1,LOT - A(JA)=SCALE*(WORK(IA)+WORK(IB)) - A(JB)=SCALE*(WORK(IA)-WORK(IB)) - A(JA+INC)=0.0 - A(JB+INC)=0.0 - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 10 CONTINUE -! -! REMAINING WAVENUMBERS - SCALE=0.5*SCALE - IABASE=3 - IBBASE=N-1 - JABASE=2*INC+1 - JBBASE=(N-2)*INC+1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - A(JA)=SCALE*((WORK(IA)+WORK(IB)) - * +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JB)=SCALE*((WORK(IA)+WORK(IB)) - * -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * +(WORK(IB+1)-WORK(IA+1))) - A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * -(WORK(IB+1)-WORK(IA+1))) - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 20 CONTINUE - IABASE=IABASE+2 - IBBASE=IBBASE-2 - JABASE=JABASE+INK - JBBASE=JBBASE-INK - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - SCALE=2.0*SCALE -!DIR$ IVDEP - DO 40 L=1,LOT - A(JA)=SCALE*WORK(IA) - A(JA+INC)=-SCALE*WORK(IA+1) - IA=IA+NX - JA=JA+JUMP - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fax (ifax,n,mode) - integer IFAX(10) - integer N, MODE -!FPP$ NOVECTOR R - integer NN, K, L, INC, II, ISTOP, ITEM, NFAX, I - NN=N - IF (IABS(MODE).EQ.1) GO TO 10 - IF (IABS(MODE).EQ.8) GO TO 10 - NN=N/2 - IF ((NN+NN).EQ.N) GO TO 10 - IFAX(1)=-99 - RETURN - 10 K=1 -! TEST FOR FACTORS OF 4 - 20 IF (MOD(NN,4).NE.0) GO TO 30 - K=K+1 - IFAX(K)=4 - NN=NN/4 - IF (NN.EQ.1) GO TO 80 - GO TO 20 -! TEST FOR EXTRA FACTOR OF 2 - 30 IF (MOD(NN,2).NE.0) GO TO 40 - K=K+1 - IFAX(K)=2 - NN=NN/2 - IF (NN.EQ.1) GO TO 80 -! TEST FOR FACTORS OF 3 - 40 IF (MOD(NN,3).NE.0) GO TO 50 - K=K+1 - IFAX(K)=3 - NN=NN/3 - IF (NN.EQ.1) GO TO 80 - GO TO 40 -! NOW FIND REMAINING FACTORS - 50 L=5 - INC=2 -! INC ALTERNATELY TAKES ON VALUES 2 AND 4 - 60 IF (MOD(NN,L).NE.0) GO TO 70 - K=K+1 - IFAX(K)=L - NN=NN/L - IF (NN.EQ.1) GO TO 80 - GO TO 60 - 70 L=L+INC - INC=6-INC - GO TO 60 - 80 IFAX(1)=K-1 -! IFAX(1) CONTAINS NUMBER OF FACTORS - NFAX=IFAX(1) -! SORT FACTORS INTO ASCENDING ORDER - IF (NFAX.EQ.1) GO TO 110 - DO 100 II=2,NFAX - ISTOP=NFAX+2-II - DO 90 I=2,ISTOP - IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 - ITEM=IFAX(I) - IFAX(I)=IFAX(I+1) - IFAX(I+1)=ITEM - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN - END - - subroutine fftrig (trigs,n,mode) - REAL(kind=KIND(1.0)) TRIGS(*) - integer N, MODE -!FPP$ NOVECTOR R - real(kind=KIND(1.0)) PI - integer IMODE, NN, L, I, NH, LA - real(kind=KIND(1.0)) DEL, ANGLE - PI=2.0*ASIN(1.0) - IMODE=IABS(MODE) - NN=N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 - DEL=(PI+PI)/FLOAT(NN) - L=NN+NN - DO 10 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(I)=COS(ANGLE) - TRIGS(I+1)=SIN(ANGLE) - 10 CONTINUE - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - DEL=0.5*DEL - NH=(NN+1)/2 - L=NH+NH - LA=NN+NN - DO 20 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(LA+I)=COS(ANGLE) - TRIGS(LA+I+1)=SIN(ANGLE) - 20 CONTINUE - IF (IMODE.LE.3) RETURN - DEL=0.5*DEL - LA=LA+NN - IF (MODE.EQ.5) GO TO 40 - DO 30 I=2,NN - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=2.0*SIN(ANGLE) - 30 CONTINUE - RETURN - 40 CONTINUE - DEL=0.5*DEL - DO 50 I=2,N - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=SIN(ANGLE) - 50 CONTINUE - RETURN - END - - subroutine vpassm (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la) - integer INC1,INC2,INC3,INC4,LOT,N,IFAC,LA - real(kind=KIND(1.0)) A(N),B(N),C(N),D(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA" -! PERFORMS ONE PASS THROUGH DATA -! AS PART OF MULTIPLE COMPLEX FFT ROUTINE -! A IS FIRST REAL INPUT VECTOR -! B IS FIRST IMAGINARY INPUT VECTOR -! C IS FIRST REAL OUTPUT VECTOR -! D IS FIRST IMAGINARY OUTPUT VECTOR -! TRIGS IS PRECALCULATED TABLE OF SINES & COSINES -! INC1 IS ADDRESSING INCREMENT FOR A AND B -! INC2 IS ADDRESSING INCREMENT FOR C AND D -! INC3 IS ADDRESSING INCREMENT BETWEEN As & Bs -! INC4 IS ADDRESSING INCREMENT BETWEEN Cs & Ds -! LOT IS THE NUMBER OF VECTORS -! N IS LENGTH OF VECTORS -! IFAC IS CURRENT FACTOR OF N -! LA IS PRODUCT OF PREVIOUS FACTORS -! - real(kind=KIND(1.0)) SIN36, COS36, SIN72, COS72, SIN60 - DATA SIN36/0.587785252292473/,COS36/0.809016994374947/, - * SIN72/0.951056516295154/,COS72/0.309016994374947/, - * SIN60/0.866025403784437/ - integer M, IINK, JINK, JUMP, IBASE, JBASE, IGO, IA, JA, IB, JB - integer IC, JC, ID, JD, IE, JE - integer I, J, K, L, IJK, LA1, KB, KC, KD, KE - real(kind=KIND(1.0)) C1, S1, C2, S2, C3, S3, C4, S4 -! -!FPP$ NOVECTOR R - M=N/IFAC - IINK=M*INC1 - JINK=LA*INC2 - JUMP=(IFAC-1)*JINK - IBASE=0 - JBASE=0 - IGO=IFAC-1 - IF (IGO.GT.4) RETURN - GO TO (10,50,90,130),IGO -! -! CODING FOR FACTOR 2 -! - 10 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - DO 20 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 15 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=A(IA+I)-A(IB+I) - D(JB+J)=B(IA+I)-B(IB+I) - I=I+INC3 - J=J+INC4 - 15 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 20 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 40 K=LA1,M,LA - KB=K+K-2 - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - DO 30 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 25 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) - D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) - I=I+INC3 - J=J+INC4 - 25 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 30 CONTINUE - JBASE=JBASE+JUMP - 40 CONTINUE - RETURN -! -! CODING FOR FACTOR 3 -! - 50 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - DO 60 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 55 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))) - C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))) - D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))) - D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))) - I=I+INC3 - J=J+INC4 - 55 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 60 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 80 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - DO 70 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 65 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)= - * C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - D(JB+J)= - * S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - C(JC+J)= - * C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - D(JC+J)= - * S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - I=I+INC3 - J=J+INC4 - 65 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 70 CONTINUE - JBASE=JBASE+JUMP - 80 CONTINUE - RETURN -! -! CODING FOR FACTOR 4 -! - 90 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - DO 100 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 95 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) - C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) - C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) - D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) - D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) - I=I+INC3 - J=J+INC4 - 95 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 100 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 120 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - DO 110 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 105 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - C(JC+J)= - * C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - D(JC+J)= - * S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - C(JB+J)= - * C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - D(JB+J)= - * S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - C(JD+J)= - * C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - D(JD+J)= - * S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 105 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 110 CONTINUE - JBASE=JBASE+JUMP - 120 CONTINUE - RETURN -! -! CODING FOR FACTOR 5 -! - 130 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - IE=ID+IINK - JE=JD+JINK - DO 140 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 135 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 135 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 140 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 160 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - KE=KD+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - C4=TRIGS(KE+1) - S4=TRIGS(KE+2) - DO 150 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 145 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)= - * C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JB+J)= - * S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JE+J)= - * C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JE+J)= - * S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JC+J)= - * C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JC+J)= - * S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - C(JD+J)= - * C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JD+J)= - * S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - I=I+INC3 - J=J+INC4 - 145 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 150 CONTINUE - JBASE=JBASE+JUMP - 160 CONTINUE - RETURN - END - - subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef ) - implicit none - integer iin,jin, iout,jout, mlev - real qin(iin,jin,mlev), qout(iout,jout,mlev) - real undef,pi,dlin,dpin,dlout,dpout - real dlam(iin), lons(iout*jout), lon - real dphi(jin), lats(iout*jout), lat - integer i,j,loc - - pi = 4.0*atan(1.0) - dlin = 2*pi/iin - dpin = pi/(jin-1) - dlam(:) = dlin - dphi(:) = dpin - - dlout = 2*pi/iout - dpout = pi/(jout-1) - - loc = 0 - do j=1,jout - do i=1,iout - loc = loc + 1 - lon = -pi + (i-1)*dlout - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jout - lat = -pi/2.0 + (j-1)*dpout - do i=1,iout - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call interp_h ( qin,iin,jin,mlev,dlam,dphi, - . qout,iout*jout,lons,lats,undef, -pi ) - - return - end - - subroutine interp_h ( q_cmp,im,jm,lm,dlam,dphi, - . q_geo,irun,lon_geo,lat_geo, undef, lon_min ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - - real :: lon_min - -c Local Variables -c --------------- - integer i,j,l - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real ap1, ap0, am1, am2 - real bp1, bp0, bm1, bm2 - - real lon_cmp(im) - real lat_cmp(jm) - real q_tmp(irun) - - real pi,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp - real lam_cmp - real phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = lon_min ! user supplied orign - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - do i=1,irun - lam_cmp = lon_geo(i) - phi_cmp = lat_geo(i) - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm1 = lat_cmp(jm1(i)) - - if( jm2(i).eq.0 ) then - phi_jm2 = phi_jm1 - dphi(1) - else - phi_jm2 = lat_cmp(jm2(i)) - endif - - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - else - phi_jp0 = lat_cmp(jp0(i)) - if( jp1(i).eq.jm+1 ) then - phi_jp1 = phi_jp0 + dphi(jm-1) - else - phi_jp1 = lat_cmp(jp1(i)) - endif - endif - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - -c Interpolate Computational-Grid Quantities to Geophysical Grid -c ------------------------------------------------------------- - do L=1,lm - do i=1,irun - - if( lat_geo(i).le.lat_cmp(2) .or. - . lat_geo(i).ge.lat_cmp(jm-1) ) then - -c 1st Order Interpolation at Poles -c -------------------------------- - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - else - -c Cubic Interpolation away from Poles -c ----------------------------------- - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jp1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp1(i),L ).ne.undef .and. - . q_cmp( im2(i),jp1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm2(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm2(i),L ).ne.undef .and. - . q_cmp( im1(i),jm2(i),L ).ne.undef .and. - . q_cmp( im2(i),jm2(i),L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) - . + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) - . + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) - . + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) - . + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) - . + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) - . + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - return - - end - - subroutine sigtopl ( qprs,q,logpl,logp,im,jm,lm,undef ) -C*********************************************************************** -C -C PURPOSE -C To interpolate an arbitrary quantity from Model Vertical Grid to Pressure -C -C INPUT -C Q ..... Q (im,jm,lm) Arbitrary Quantity on Model Grid -C PKZ ... PKZ (im,jm,lm) Pressure to the Kappa at Model Levels (From Phillips) -C PKSRF . PKSRF(im,jm) Surface Pressure to the Kappa -C PTOP .. Pressure at Model Top -C P ..... Output Pressure Level (mb) -C IM .... Longitude Dimension of Input -C JM .... Latitude Dimension of Input -C LM .... Vertical Dimension of Input -C -C OUTPUT -C QPRS .. QPRS (im,jm) Arbitrary Quantity at Pressure p -C -C NOTE -C Quantity is interpolated Linear in P**Kappa. -C Between PTOP**Kappa and PKZ(1), quantity is extrapolated. -C Between PKSRF**Kappa and PKZ(LM), quantity is extrapolated. -C Undefined Model-Level quantities are not used. -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** -C - implicit none - integer i,j,l,im,jm,lm - - real qprs(im,jm) - real q (im,jm,lm) - real logpl(im,jm,lm) - - real undef - real logp,temp - -c Initialize to UNDEFINED -c ----------------------- - do i=1,im*jm - qprs(i,1) = undef - enddo - -c Interpolate to Pressure Between Model Levels -c -------------------------------------------- - do L=1,lm-1 - if( all( logpl(:,:,L )>logp ) ) exit - if( all( logpl(:,:,L+1) 2 and km-1 => km -! ----------------------------------------------------------------- - else if( LM1.eq.1 .or. LP0.eq.km .or. 1.eq.1 ) then - q2(i,j,k) = q1(i,j,LP0) + ( q1(i,j,LM1)-q1(i,j,LP0) )*( logpl2(i,j,k )-logpl1(i,j,LP0) ) - . /( logpl1(i,j,LM1)-logpl1(i,j,LP0) ) - -! Interpolate Cubicly in LogP between other model levels -! ------------------------------------------------------ - else - LP1 = LP0+1 - LM2 = LM1-1 - P = logpl2(i,j,k) - PLP1 = logpl1(i,j,LP1) - PLP0 = logpl1(i,j,LP0) - PLM1 = logpl1(i,j,LM1) - PLM2 = logpl1(i,j,LM2) - DLP0 = dlogp1(i,j,LP0) - DLM1 = dlogp1(i,j,LM1) - DLM2 = dlogp1(i,j,LM2) - - ap1 = (P-PLP0)*(P-PLM1)*(P-PLM2)/( DLP0*(DLP0+DLM1)*(DLP0+DLM1+DLM2) ) - ap0 = (PLP1-P)*(P-PLM1)*(P-PLM2)/( DLP0* DLM1 *( DLM1+DLM2) ) - am1 = (PLP1-P)*(PLP0-P)*(P-PLM2)/( DLM1* DLM2 *(DLP0+DLM1 ) ) - am2 = (PLP1-P)*(PLP0-P)*(PLM1-P)/( DLM2*(DLM1+DLM2)*(DLP0+DLM1+DLM2) ) - - q2(i,j,k) = ap1*q1(i,j,LP1) + ap0*q1(i,j,LP0) + am1*q1(i,j,LM1) + am2*q1(i,j,LM2) - - endif - - enddo - enddo - enddo - - return - end - - SUBROUTINE GETVORDIV ( U,V,VOR,DIV,IM,JM ) -C ******************************************************************** -C **** **** -C **** THIS PROGRAM CALCULATES DIVERGENCE **** -C **** AT EACH LEVEL FOR A NON-STAGGERED A-GRID **** -C **** **** -C **** INPUT: **** -C **** U ....... ZONAL WIND **** -C **** V ....... MERIDIONAL WIND **** -C **** IM ...... NUMBER OF LONGITUDE POINTS **** -C **** JM ...... NUMBER OF LATITUDE POINTS **** -C **** **** -C **** OUTPUT: **** -C **** VOR (IM,JM) .... VORTICITY **** -C **** DIV (IM,JM) .... DIVERGENCE **** -C **** **** -C ******************************************************************** - - real U(IM,JM) - real V(IM,JM) - real VOR(IM,JM) - real DIV(IM,JM) - - real P1X (IM,JM) - real P1Y (IM,JM) - real TMP1(IM,JM) - real TMP2(IM,JM) - real cosij(IM,JM) - - DIMENSION MSGN(2) - - DATA MSGN /-1,1/ - -C ********************************************************* -C **** INITIALIZATION FOR DIVERGENCE **** -C ********************************************************* - - A = 6.372e6 - pi = 4.*atan(1.) - dlon = 2*pi/ im - dlat = pi/(jm-1) - - C11 = 1.0 / (2.0*A*IM*(1.0-COS(0.5*dlat))) - - CX1 = 1.0 / (2.0*A*dlon) - CY1 = 1.0 / (2.0*A*dlat) - - do j=2,jm-1 - phi = -pi/2.+(j-1)*dlat - cosphi = cos(phi) - do i=1,im - cosij(i,j) = cosphi - enddo - enddo - cosij(:,1) = 0.0 - cosij(:,jm) = 0.0 - -C ******************************************************** -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - DO j=2,jm-1 - i =im - DO ip1=1,im - P1X(i,j) = ( U(ip1,j)+U(i,j) ) - i =ip1 - ENDDO - ENDDO - - DO j=1,jm-1 - DO I=1,im - P1Y(I,j) = ( V(I,J+1)*COSIJ(I,J+1)+V(I,j)*COSIJ(I,j) ) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE **** -C ********************************************************* - - DO j=2,jm-1 - im1=im - DO i=1,im - TMP1(i,j) = ( P1X(i,j)-P1X(im1,j) )*CX1 - im1=i - ENDDO - - DO I=1,im - TMP2(I,j) = ( P1Y(I,j) -P1Y(I,j-1) )*CY1 - DIV (I,j) = ( TMP1(I,j)+TMP2(I,j) )/(cosij(i,j)) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE AT POLES **** -C ********************************************************* - - DO M=1,2 - JPOLE = 1 + (M-1)*(jm-1) - JPH = 1 + (M-1)*(jm-2) - - SUM11 = 0.0 - DO I=1,im - SUM11 = SUM11 + P1Y(I,JPH) - ENDDO - - DO I=1,im - DIV(I,JPOLE) = - MSGN(M) * C11*SUM11 - ENDDO - ENDDO - -C ******************************************************** -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - DO j=2,jm-1 - i =im - DO ip1=1,im - P1X(i,j) = ( V(ip1,j)+V(i,j) ) - i =ip1 - ENDDO - ENDDO - - DO j=1,jm-1 - DO I=1,im - P1Y(I,j) = ( U(I,J+1)*COSIJ(I,J+1)+U(I,j)*COSIJ(I,j) ) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL VORTICITY **** -C ********************************************************* - - DO j=2,jm-1 - im1=im - DO i=1,im - TMP1(i,j) = ( P1X(i,j)-P1X(im1,j) )*CX1 - im1=i - ENDDO - - DO I=1,im - TMP2(I,j) = ( P1Y(I,j) -P1Y(I,j-1) )*CY1 - VOR (I,j) = ( TMP1(I,j)-TMP2(I,j) )/(cosij(i,j)) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE AT POLES **** -C ********************************************************* - - DO M=1,2 - JPOLE = 1 + (M-1)*(jm-1) - JPH = 1 + (M-1)*(jm-2) - - SUM11 = 0.0 - DO I=1,im - SUM11 = SUM11 + P1Y(I,JPH) - ENDDO - - DO I=1,im - VOR(I,JPOLE) = - MSGN(M) * C11*SUM11 - ENDDO - ENDDO - - RETURN - END - SUBROUTINE GRADQ (Q,DQDX,DQDY,IM,JM) -C ********************************************************* -C **** **** -C **** THIS PROGRAM CALCULATES THE HORIZONTAL **** -C **** GRADIENT OF THE INPUT FIELD Q **** -C **** **** -C **** ARGUMENTS: **** -C **** Q ....... FIELD TO BE DIFFERENTIATED **** -C **** DQDX .... LONGITUDINAL Q-DERIVATIVE **** -C **** DQDY .... MERIDIONAL Q-DERIVATIVE **** -C **** IM ...... NUMBER OF LONGITUDINAL POINTS **** -C **** JM ...... NUMBER OF LATITUDINAL POINTS **** -C **** **** -C ********************************************************* - - use MAPL_ConstantsMod - implicit none - integer im,jm - - real Q(IM,JM) - real DQDX(IM,JM) - real DQDY(IM,JM) - real Q1X(IM,JM) - real Q2X(IM,JM) - real Q1Y(IM,JM) - real Q2Y(IM,JM) - real acos(JM) - real sinl(IM) - real cosl(IM) - - real cx1,cx2,cy1,cy2,uc,vc,us,vs - real dl,dp,a,pi,fjeq,phi - integer i,j,m,ip1,ip2,jpole,msgn - -C ********************************************************* -C **** INITIALIZATION **** -C ********************************************************* - - a = MAPL_RADIUS - pi = 4.0*atan(1.0) - dl = 2.0*pi/im - dp = pi/(jm-1) - - CX1 = 2.0 / ( 3.0*A*DL) - CX2 = 1.0 / (12.0*A*DL) - CY1 = 2.0 / ( 3.0*A*DP) - CY2 = 1.0 / (12.0*A*DP) - - Q1X(:,:) = 0.0 - Q2X(:,:) = 0.0 - Q1Y(:,:) = 0.0 - Q2Y(:,:) = 0.0 - - fjeq = ( jm+1 )*0.5 - do j=2,jm-1 - phi = dp * (j-fjeq) - acos(j) = 1.0/( cos(phi) ) - enddo - do i=1,im/2 - cosl(i) = -cos((i-1)*dl) - cosl(i+im/2) = -cosl(i) - sinl(i) = -sin((i-1)*dl) - sinl(i+im/2) = -sinl(i) - enddo - -C ********************************************************* -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - do j = 2,jm-1 - i = im-1 - ip1 = im - do ip2 = 1,im - Q1X(i ,j) = Q(ip1,j) + Q(i,j) - Q2X(ip1,j) = Q(ip2,j) + Q(i,j) - i = ip1 - ip1 = ip2 - enddo - enddo - - do j=1,jm-1 - do i=1,im - Q1Y(i,j) = Q(i,j+1) + Q(i,j) - enddo - enddo - - do j=2,jm-1 - do i=1,im - Q2Y(i,j) = Q(i,j+1) + Q(i,j-1) - enddo - enddo - - do i=1,im/2 - Q2Y(i, 1) = Q(i,2) - Q2Y(i,jm) = Q(i,jm-1) - enddo - - do i=1,im/2 - Q2Y(i , 1) = Q(i+im/2,2) + Q2Y(i,1) - Q2Y(i+im/2, 1) = Q2Y(i,1) - Q2Y(i ,jm) = Q(i+im/2,jm-1) + Q2Y(i,jm) - Q2Y(i+im/2,jm) = Q2Y(i,jm) - enddo - -C ********************************************************* -C **** CALCULATE Q-GRADIENTS **** -C ********************************************************* - - do j = 2,jm-1 - i = im-1 - ip1 = im - do ip2 = 1,im - DQDX(ip1,j) = ACOS(j) * ( ( Q1X(ip1,j)-Q1X(i,j) )*CX1 - . - ( Q2X(ip2,j)-Q2X(i,j) )*CX2 ) - i = ip1 - ip1 = ip2 - enddo - enddo - - do j=2,jm-1 - do i=1,im - DQDY(i,j) = ( Q1Y(i,j) -Q1Y(i,j-1) )*CY1 - . - ( Q2Y(i,j+1)-Q2Y(i,j-1) )*CY2 - enddo - enddo - -C ********************************************************* -C **** CALCULATE Q-GRADIENTS (POLES) **** -C ********************************************************* - - do i=1,im/2 - Q1Y(i, 2) = Q(i, 1) + Q(i+im/2,2) - Q1Y(i+im/2, 2) = Q(i+im/2, 1) + Q(i, 2) - Q2Y(i, 1) = Q(i, 1) + Q(i+im/2,3) - Q2Y(i+im/2, 1) = Q(i+im/2, 1) + Q(i, 3) - - Q1Y(i, jm) = Q(i, jm) + Q(i+im/2,jm-1) - Q1Y(i+im/2,jm) = Q(i+im/2,jm) + Q(i, jm-1) - Q2Y(i, jm) = Q(i, jm) + Q(i+im/2,jm-2) - Q2Y(i+im/2,jm) = Q(i+im/2,jm) + Q(i, jm-2) - enddo - - do i=1,im - DQDY(i,jm) = ( Q1Y(i,jm)-Q1Y(i,jm-1) )*CY1 - . - ( Q2Y(i,jm)-Q2Y(i,jm-1) )*CY2 - - DQDY(i, 1) = ( Q1Y(i,1)-Q1Y(i,2) )*CY1 - . - ( Q2Y(i,2)-Q2Y(i,1) )*CY2 - enddo - -C APPLY BOUNDARY CONDITIONS AT THE POLES -C ========================================== - - DO 170 M=1,2 - MSGN = (-1)**M - JPOLE = 1 + (M-1)*(jm - 1) - - VC = 0.0 - VS = 0.0 - DO 180 I=1,IM - VC = VC + DQDY(I,JPOLE)*COSL(I) - VS = VS + DQDY(I,JPOLE)*SINL(I) - 180 CONTINUE - VC = 2.0 * VC / IM - VS = 2.0 * VS / IM - - UC = - MSGN*VS - US = MSGN*VC - - DO 190 I=1,IM - DQDX(I,JPOLE) = US*SINL(I) + UC*COSL(I) - DQDY(I,JPOLE) = VS*SINL(I) + VC*COSL(I) - 190 CONTINUE - - 170 CONTINUE - - RETURN - END - SUBROUTINE LAPLACIAN (DIV,VELP,im,jnp) - - integer IM,JNP - real DIV(IM,JNP) - real VELP(IM,JNP) - - real*8, allocatable :: VP(:,:) - real*8, allocatable :: w(:) - real*8, allocatable :: bdtf(:) - real*8, allocatable :: bdts(:) - real*8, allocatable :: bdps(:) - real*8, allocatable :: bdpf(:) - real*8 ts,tf,ps,pf,elmbda,pertrb,pi - - imp = im+1 - iwk = 11*jnp+6*imp - - allocate ( vp(jnp,imp) ) - allocate ( w(iwk) ) - allocate ( bdtf(imp) ) - allocate ( bdts(imp) ) - allocate ( bdps(jnp) ) - allocate ( bdpf(jnp) ) - - vp(:,:)=0.0 - w(:)=0.0 - bdtf(:)=0.0 - bdts(:)=0.0 - bdps(:)=0.0 - bdpf(:)=0.0 - -c Transpose the input array -c ------------------------- - do j=1,jnp - do i=1,im - vp(j,i) = div(i,j) - enddo - vp(j,imp) = vp(j,1) - enddo - -C === SET THE INPUT VARIABLES - RAD = 6371000.0 - PI = 3.14159265358979D0 - INTL=0 - TS=0.0 - TF=PI - M=JNP-1 - MBDCND=9 - PS=0.0 - PF=2*PI - N=IM - NBDCND=0 - ELMBDA=0 - PERTRB=0 - IDIMF=M+1 - - CALL PWSSSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS, - * BDPF,ELMBDA,VP,IDIMF,PERTRB,IERROR,W) - - if( ierror.ne.0 ) then - print *, 'PWSSSP IERROR = ',ierror - stop - endif - -c Scale by earth radius -c --------------------- - do j=1,jnp - do i=1,im - VELP(I,J) = VP(J,I) * RAD * RAD - enddo - enddo - -c Remove global mean -c ------------------ - CALL ZEROG (VELP,IM,JNP) - - deallocate ( vp ) - deallocate ( w ) - deallocate ( bdtf ) - deallocate ( bdts ) - deallocate ( bdps ) - deallocate ( bdpf ) - RETURN - END - - SUBROUTINE ZEROG (VEL,IM,JNP) - integer IM,JNP - real VEL(IM,JNP) - - pi = 4.0*atan(1.0) - dl = 2*pi/im - dp = pi/(jnp-1) - cap = 1-cos(0.5*dp) - -c Ensure unique pole values -c ------------------------- - sum1 = 0.0 - sum2 = 0.0 - do i=1,im - sum1 = sum1 + vel(i,1) - sum2 = sum2 + vel(i,jnp) - enddo - sum1 = sum1/im - sum2 = sum2/im - do i=1,im - vel(i,1) = sum1 - vel(i,jnp) = sum2 - enddo - -c Compute global average -c ---------------------- - sum1 = 0.0 - sum2 = 0.0 - do i=1,im - sum1 = sum1 + cap*vel(i,1) - sum2 = sum2 + cap - enddo - - do j=2,jnp-1 - cosj = cos( -pi/2 + (j-1)*dp ) - do i=1,im - sum1 = sum1 + cosj*dp*vel(i,j) - sum2 = sum2 + cosj*dp - enddo - enddo - - do i=1,im - sum1 = sum1 + cap*vel(i,jnp) - sum2 = sum2 + cap - enddo - - qave = sum1/sum2 - - do j=1,jnp - do i=1,im - vel(i,j) = vel(i,j)-qave - enddo - enddo - -c print *, 'Remove Global Average: ', qave - - RETURN - END diff --git a/GEOS_Util/post/era5_prs2eta.F b/GEOS_Util/post/era5_prs2eta.F deleted file mode 100644 index 5c7d6596..00000000 --- a/GEOS_Util/post/era5_prs2eta.F +++ /dev/null @@ -1,2138 +0,0 @@ - program main - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - include 'mpif.h' - - integer comm,myid,npes,ierror - integer imglobal - integer jmglobal - integer npex,npey - logical root - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Create ECMWF ANA.ETA File from Pressure Level Data **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm,nq - real ptop,pint - real rgas,eps,rvap - real kappa - real grav - - integer niter,i0,j0 - parameter ( niter = 5 ) - -! GEOS Restart Variables -! ---------------------- - real, allocatable :: ak(:) - real, allocatable :: bk(:) - real, allocatable :: phis(:,:) - -c Set analysis, fvdas, date and time -c ---------------------------------- - character*2 cnhms - character*8 cnymd - - character*256 prsdata, phisdata, tag, ext - - real :: phibg, phifg, thbr1, thbr2, delth, cp - - integer nymd,nhms - integer Lbeg,Lend - -c fv restart variables and topography -c ----------------------------------- - real, allocatable :: ps(:,:) - real, allocatable :: dp(:,:,:) - real, allocatable :: ple(:,:,:) - real, allocatable :: u(:,:,:) - real, allocatable :: v(:,:,:) - real, allocatable :: thv(:,:,:) - real, allocatable :: pke(:,:,:) - real, allocatable :: pk (:,:,:) - real, allocatable :: q(:,:,:) - - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - integer timinc - real undef - -c Analysis variables -c ------------------ - real, allocatable :: phis_ana(:,:) - real, allocatable :: ps_ana(:,:) - real, allocatable :: u_ana(:,:,:) - real, allocatable :: v_ana(:,:,:) - real, allocatable :: z_ana(:,:,:) - real, allocatable :: er_ana(:,:,:) - real, allocatable :: q_ana(:,:,:) - real, allocatable :: p_ana(:,:,:) - real, allocatable :: dp_ana(:,:,:) - real, allocatable :: pl_ana(:,:,:) - real, allocatable :: t_ana(:,:,:) - real, allocatable :: t_ec(:,:,:) - real, allocatable :: h_ana(:,:,:) - real, allocatable :: ple_ana(:,:,:) - real, allocatable :: logp (:,:,:) - real, allocatable :: logpl(:,:,:) - real, allocatable :: qdum (:,:,:) - integer id,id2,rc - integer nvars, ngatts, ntime - - character*256, allocatable :: arg(:) - - integer precision - integer i,j,k,L,n,nargs,ks - integer nt,nv,ng,imphis,jmphis,lmphis - logical norecon - logical Lzflip - -c Analysis Grads CTL File Variables -c --------------------------------- - character*256 ctlfile - integer imana,jmana,lmana - - character*256, pointer :: names (:) - integer, pointer :: lmvars(:) - real, pointer :: plevs(:) - - interface - subroutine gfio_get ( fname,id,im,jm,lm,ntime,nvars,nymdb,nhmsb,nymde,nhmse,ndt,rc ) - character (len=*), intent(IN) :: fname - integer , optional, intent(OUT) :: id - integer , optional, intent(OUT) :: im - integer , optional, intent(OUT) :: jm - integer , optional, intent(OUT) :: lm - integer , optional, intent(OUT) :: ntime - integer , optional, intent(OUT) :: nvars - integer , optional, intent(OUT) :: nymdb - integer , optional, intent(OUT) :: nhmsb - integer , optional, intent(OUT) :: nymde - integer , optional, intent(OUT) :: nhmse - integer , optional, intent(OUT) :: ndt - integer , optional, intent(OUT) :: rc - end subroutine gfio_get - end interface - -C ********************************************************************** - - call mpi_init ( ierror ) ; comm = mpi_comm_world - call mpi_comm_rank ( comm,myid,ierror ) - call mpi_comm_size ( comm,npes,ierror ) - npex = nint ( sqrt( float(npes) ) ) - npey = npex - do while ( npex*npey .ne. npes ) - npex = npex-1 - npey = nint ( float(npes)/float(npex) ) - enddo - - root = myid.eq.0 - -C ********************************************************************** -C **** Initialize Filenames, Methods, etc. **** -C ********************************************************************** - - i0 = 0 - i0 = 0 - lm = 72 - im = -999 - jm = -999 - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - - precision = 0 ! 32-bit - ctlfile = 'xxx' - nymd = -999 - nhms = -999 - tag = '' - norecon =.false. - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-ecmwf' ) prsdata = trim(arg(n+1)) - if( trim(arg(n)).eq.'-phis' ) phisdata = trim(arg(n+1)) - if( trim(arg(n)).eq.'-tag' ) tag = trim(arg(n+1)) - if( trim(arg(n)).eq.'-i0' ) read(arg(n+1), * ) i0 - if( trim(arg(n)).eq.'-j0' ) read(arg(n+1), * ) j0 - if( trim(arg(n)).eq.'-norecon') norecon =.true. - enddo - endif - - if( trim(tag).ne.'' ) tag = trim(tag) // '.' - ext = 'nc4' - - -C ********************************************************************** -C **** Read ANA MetaData **** -C ********************************************************************** - - call gfio_open ( trim(prsdata),1,id,rc ) - call gfio_diminquire ( id,imglobal,jmglobal,lmana,ntime,nvars,ngatts,rc ) - - call create_dynamics_lattice ( lattice,npex,npey ) - call init_dynamics_lattice ( lattice,comm,imglobal,jmglobal,lmana ) - - imana = lattice%im( lattice%pei ) - jmana = lattice%jm( lattice%pej ) - - if( im.eq.-999 ) im = imana - if( jm.eq.-999 ) jm = jmana - -C ********************************************************************** -C **** Read PHIS Data **** -C ********************************************************************** - - allocate ( phis_ana(im,jm) ) - call gfio_get ( trim(phisdata),id=id2,nymdb=nymd,nhmsb=nhms,rc=rc ) - - if( root ) print *, 'Reading EC_PHIS for date: ',nymd,nhms,' on UNIT: ',id2 - - call mpi_gfio_getvar ( id2,'z',nymd,nhms,imana,jmana,0,1 ,phis_ana,rc,lattice ) - call gfio_close ( id2,rc ) - -C ********************************************************************** - - allocate ( lon(imglobal) ) - allocate ( lat(jmglobal) ) - allocate ( lev(lmana) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,imglobal,jmglobal,lmana,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - - ! We want PLEVS to be ordered from model top (L=1) to surface (L=lmana) - ! --------------------------------------------------------------------- - Lzflip = lev(1).gt.lev(lmana) - allocate ( plevs(lmana) ) - do L=1,lmana - if( Lzflip ) then - plevs(L) = lev(lmana-L+1) - else - plevs(L) = lev(L) - endif - enddo - - if(root) then - print * - print *, ' ERA5 Analysis File: ',trim(prsdata) - print *, ' rslv: ',imglobal,jmglobal,lmana - print *, ' lon(1): ',lon(1) - print * - print *, ' Number of Variables: ',nvars - print * - do n=1,nvars - write(6,1001) n,trim(vname(n)),trim(vtitle(n)),kmvar(n) - enddo - 1001 format(1x,i2,3x,a16,2x,a32,2x,i3) - print * - L = 1 - print *, ' Pressure Levels: ',L,plevs(L) - do L=2,lmana - print *, ' ',L,plevs(L) - enddo - print * - endif - - nymd = yymmdd(1) - nhms = hhmmss(1) - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - 200 format(i8.8) - 300 format(i2.2) - 400 format('dset ^',a) - 600 format(a1,i2.2) - -C ********************************************************************** -C **** Get Analysis **** -C ********************************************************************** - - allocate ( p_ana(im,jm,lmana) ) - allocate ( er_ana(im,jm,lmana) ) - allocate ( z_ana(im,jm,lmana) ) - allocate ( u_ana(im,jm,lmana) ) - allocate ( v_ana(im,jm,lmana) ) - allocate ( t_ana(im,jm,lmana) ) - allocate ( t_ec (im,jm,lmana) ) - allocate ( h_ana(im,jm,lmana) ) - allocate ( q_ana(im,jm,lmana) ) - allocate ( ps_ana(im,jm) ) - - if( root ) then - print *, 'Reading ERA5 Pressure Level Analysis for Date: ',nymd,' Time: ',nhms - print * - endif - call get_ana_data ( id,ps_ana,u_ana,v_ana,t_ana,q_ana,h_ana, - . im,jm,lmana,nymd,nhms, - . imana,jmana,lmana,undef,plevs,Lzflip,lattice ) - t_ec = t_ana - -! Construct Pressure Variables -! ---------------------------- - allocate( dp_ana(im,jm,lm) ) - allocate( pl_ana(im,jm,lm) ) - allocate( ple_ana(im,jm,lm+1) ) - allocate( logp (im,jm,lm) ) - allocate( logpl(im,jm,lm) ) - - allocate( ak(lm+1) ) - allocate( bk(lm+1) ) - - call set_eta ( lm,ks,ptop,pint,ak,bk ) - - do L=1,lm+1 - ple_ana(:,:,L) = ak(L) + ps_ana(:,:)*bk(L) - enddo - do L=1,lm - dp_ana(:,:,L) = ple_ana(:,:,L+1)-ple_ana(:,:,L) - pl_ana(:,:,L) = 0.5*(ple_ana(:,:,L+1)+ple_ana(:,:,L)) - logp(:,:,L) = log( 0.5*(ple_ana(:,:,L+1)+ple_ana(:,:,L)) ) - enddo - - if( i0.ne.0 .and. j0.ne.0 ) then - do j=1,jm - do i=1,im - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - print *, 'Sample ANA Data at GEOS-5 Location: (',i,',',j,')' - print *, ' ANA_PS: ',ps_ana(i,j)/100,' ANA_PHIS: ',phis_ana(i,j) - print *, ' ANA_UNDEF: ',undef - print *, ' ANA Temperature and Wind Profile:' - endif - enddo - enddo - else - if( lattice%myid.eq.0 ) then - print *, 'Sample ANA Data:' - print *, ' ANA_PS: ',ps_ana(1,jm/2)/100,' ANA_PHIS: ',phis_ana(1,jm/2) - print *, ' ANA_UNDEF: ',undef - print *, ' ANA_Temperature and Wind Profile:' - endif - endif - do L=1,lmana - p_ana(:,:,L) = 100.0*plevs(L) - logpl(:,:,L) = log( 100.0*plevs(L) ) - if( i0.ne.0 .and. j0.ne.0 ) then - do j=1,jm - do i=1,im - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - print *, L,plevs(L),t_ana(i,j,L),u_ana(i,j,L) - endif - enddo - enddo - else - if( lattice%myid.eq.0 ) then - print *, L,plevs(L),t_ana(1,jm/2,L),u_ana(1,jm/2,L) - endif - endif - enddo - if( lattice%myid.eq.0 ) print * - - allocate ( qdum(im,jm,lm) ) - - call interp ( qdum,u_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'UWND',niter,i0,j0,1,lattice ) - deallocate ( u_ana ) - allocate ( u_ana(im,jm,lm) ) - u_ana = qdum - - call interp ( qdum,v_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'VWND',niter,i0,j0,1,lattice ) - deallocate ( v_ana ) - allocate ( v_ana(im,jm,lm) ) - v_ana = qdum - - call interp ( qdum,t_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'TMPU',niter,i0,j0,1,lattice ) - deallocate ( t_ana ) - allocate ( t_ana(im,jm,lm) ) - t_ana = qdum - - call interp ( qdum,q_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'SPHU',niter,i0,j0,-1,lattice ) - deallocate ( q_ana ) - allocate ( q_ana(im,jm,lm) ) - q_ana = qdum - -C ********************************************************************** -C **** Remap for Analysis **** -C ********************************************************************** - - allocate( phis(im,jm) ) - allocate( ps(im,jm) ) - allocate( dp(im,jm,lm) ) - allocate( u(im,jm,lm) ) - allocate( v(im,jm,lm) ) - allocate( q(im,jm,lm) ) - allocate( pk(im,jm,lm) ) - allocate( thv(im,jm,lm) ) - allocate( ple(im,jm,lm+1) ) - allocate( pke(im,jm,lm+1) ) - - ps = ps_ana - dp = dp_ana - phis = phis_ana - - if( i0.ne.0 .and. j0.ne.0 ) then - do j=1,jm - do i=1,im - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - print * - print *, 'Before REMAP: ' - print *, 'GEOS5 PHIS/grav: ',phis(i,j)/grav,' ps: ',ps(i,j)/100 - print *, 'ANA PHIS/grav: ',phis_ana(i,j)/grav,' ps: ',ps_ana(i,j)/100 - print * - endif - enddo - enddo - endif - - if( lattice%myid.eq.0 ) print *, 'Calling Remap' - call remap ( ps, dp, u, v, thv, q, lm, - . ps_ana,dp_ana,u_ana,v_ana,t_ana,q_ana,lm,im,jm,1 ) - if( lattice%myid.eq.0 ) print *, ' Fini Remap' - - if( i0.ne.0 .and. j0.ne.0 ) then - do j=1,jm - do i=1,im - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - print * - print *, 'AFter REMAP: ' - print *, 'GEOS5 PHIS/grav: ',phis(i0,j0)/grav,' ps: ',ps(i0,j0)/100 - print *, 'ANA PHIS/grav: ',phis_ana(i0,j0)/grav,' ps: ',ps_ana(i0,j0)/100 - print * - endif - enddo - enddo - endif - -C ********************************************************************** -C **** Reconcile Heights **** -C ********************************************************************** - - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - - if( .not.norecon ) then - do j=1,jm - do i=1,im - - Lbeg = lm - phifg = phis(i,j) - phibg = phifg - - do k=lmana,1,-1 - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - write(6,5001) k,p_ana(i,j,k)/100,h_ana(i,j,k),t_ec(i,j,k) - 5001 format(1x,'k: ',i3,3x,'ANA_PMAN: ',f8.3,3x,'ANA_HGHT: ',f9.3,3x,'ANA_TMPU: ',f7.3) - endif - - if( p_ana(i,j,k).lt.ps(i,j) .and. ! p_ana is above GEOS Surface Pressure - . h_ana(i,j,k)-phibg/grav.gt.10.0 .and. ! h_ana is at least 10-meters above previous level - . h_ana(i,j,k)-phis_ana(i,j)/grav.gt.10.0 ) then ! h_ana is at least 10-meters above Topography - - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) print * - - do L=Lbeg,1,-1 - if( ple(i,j,L).gt.p_ana(i,j,k) ) then - phifg = phifg + cp*thv(i,j,L)*( pke(i,j,L+1)-pke(i,j,L) ) - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - write(6,5002) L,ple(i,j,L)/100,phifg/grav,thv(i,j,L)*pk(i,j,L) - 5002 format(1x,'L: ',i3,3x,' G5_PLE: ',f8.3,3x,'G5_HGHT: ',f9.3,3x,'G5_TMPU: ',f7.3) - endif - else - exit - endif - enddo - Lend = L - if( Lbeg-Lend.le.2 ) then - phifg = phibg - cycle - endif - - phifg = phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-p_ana(i,j,k)**kappa ) - - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - print * - print *, ' Lbeg: ',Lbeg,' Lend: ',Lend,' ple(Lend): ',ple(i,j,Lend)/100 - print *, 'ANA_HGHT: ',h_ana(i,j,k),' G5_HGHT: ',phifg/grav,' G5_HGHT0: ',phibg/grav - print *, 'ANA_TMPU: ',t_ec (i,j,k),' G5_TMPU: ',thv(i,j,Lend)*pk(i,j,LEND) - endif - - thbr1 = ( grav*h_ana(i,j,k)-phibg )/( pke(i,j,Lbeg+1)-p_ana(i,j,k)**kappa )/cp - thbr2 = ( phifg -phibg )/( pke(i,j,Lbeg+1)-p_ana(i,j,k)**kappa )/cp - delth = thbr1-thbr2 - - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - print *, 'ANA_THETA_BR: ',thbr1,' G5_THETA_BR: ',thbr2 - print *, ' ANA_T_TOP: ',thbr1*p_ana(i,j,k)**kappa,' G5_T_TOP: ',thbr2*p_ana(i,j,k)**kappa - print *, ' ANA_T_BOT: ',thbr1*pke(i,j,Lbeg+1),' G5_T_BOT: ',thbr2*pke(i,j,Lbeg+1) - endif - - do L=Lbeg,Lend,-1 - thv(i,j,L) = thv(i,j,L) + delth - enddo - - phifg = phibg - do L=Lbeg,Lend+1,-1 - phifg = phifg + cp*thv(i,j,L)*( pke(i,j,L+1)-pke(i,j,L) ) - enddo - - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - print *, 'ANA_HGHT: ',h_ana(i,j,k),' G5_HGHT: ', - . (phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-p_ana(i,j,k)**kappa ))/grav - endif - - phifg = phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-pke(i,j,Lend) ) - Lbeg = Lend-1 - phibg = phifg - endif - enddo - - enddo ! End I-Loop - enddo ! End J-Loop - endif ! End RECON Test - -C ********************************************************************** -C **** Write ECMWF ANA.ETA File **** -C ********************************************************************** - - nq = 1 - call put_fveta ( ps,dp,u,v,thv,q,phis, - . im,jm,lm,nq,nymd,nhms,tag,ext,lat,lon, - . timinc,precision,lattice ) - - stop - end - - subroutine interp ( q,qana,logp,logpl,pana,pl,ple,im,jm,lm,lmana,undef,name,niter,i0,j0,flag,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,lm,lmana,niter,i0,j0,flag - real undef - real q (im,jm,lm) - real pl (im,jm,lm) - real ple (im,jm,lm+1) - real er (im,jm,lm) - real logp (im,jm,lm) - real pana (im,jm,lmana) - real qana (im,jm,lmana) - real zana (im,jm,lmana) - real erana(im,jm,lmana) - real logpl(im,jm,lmana) - character*4 name - - integer i,j,L,n - -c Interpolate Analysis to GEOS Model Levels -c ----------------------------------------- - do L=1,lm - do j=1,jm - do i=1,im - call sigtopl( q(i,j,L),qana(i,j,:),logpl(i,j,:),logp(i,j,L),1,1,lmana,undef ) - enddo - enddo - enddo - if( flag.eq.-1 ) then - q = max( q,0.0 ) - endif - - if( i0.ne.0 .and. j0.ne.0 ) then - do j=1,jm - do i=1,im - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - print * - print *, 'Initial ANA ',trim(name),' Profile at GEOS-5 Levels:' - do L=1,lm - print *, L,exp(logp(i,j,L))/100.,q(i,j,L) - enddo - print * - endif - enddo - enddo - else - if( lattice%myid.eq.0 ) print *, 'Interpolating ',trim(name),' ...' - endif - -#ifdef DEBUG - call writit (q,im,jm,lm,66) -#endif - do n=1,niter -c Interpolate GEOS Model Back to EC Levels and Compute Error -c ---------------------------------------------------------- - do L=1,lmana - do j=1,jm - do i=1,im - call sigtopl( zana(i,j,L),q(i,j,:),logp(i,j,:),logpl(i,j,L),1,1,lm,undef ) - erana(i,j,L) = zana(i,j,L)-qana(i,j,L) - enddo - enddo - enddo - if( i0.ne.0 .and. j0.ne.0 ) then - do j=1,jm - do i=1,im - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - print * - print *, 'ANA ',trim(name),' Profile Comparison, ITER: ',n - print *, '----------------------------------------------' - do L=1,lmana - print *, L,exp(logpl(i,j,L))/100.,zana(i,j,L),qana(i,j,L),erana(i,j,L) - enddo - print * - endif - enddo - enddo - endif - -c Interpolate and Add Error to GEOS Model Levels -c ---------------------------------------------- - call interp3 ( erana,pana,im,jm,lmana, er,pl,lm,ple(1,1,lm+1) ) - q = q - er - if( flag.eq.-1 ) then - q = max( q,0.0 ) - endif -#ifdef DEBUG - call writit (q,im,jm,lm,66) -#endif - enddo - - if( i0.ne.0 .and. j0.ne.0 ) then - do j=1,jm - do i=1,im - if( lattice%iglobal(i).eq.i0 .and. lattice%jglobal(j).eq.j0 ) then - print * - print *, 'Final ANA ',trim(name),' Profile at GEOS-5 Levels:' - do L=1,lm - print *, L,exp(logp(i,j,L))/100.,q(i,j,L) - enddo - print * - endif - enddo - enddo - endif - - return - end - - subroutine get_ana_data ( id,ps,u,v,t,q,h, - . im,jm,lm,nymd,nhms, - . imana,jmana,lmana,undef,plevs,Lzflip,lattice ) - use MAPL_ConstantsMod - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer id,im,jm,lm,nymd,nhms,rc - integer imana,jmana,lmana - logical Lzflip - - real ps(im,jm) - real u(im,jm,lm) - real v(im,jm,lm) - real t(im,jm,lm) - real h(im,jm,lm) - real rh(im,jm,lm) - real q(im,jm,lm) - ! real phis(im,jm) - real plevs(lm) - real slp(im,jm) - - real undef,kappa,grav,beta,cp,rgas - integer L,i,j,LM1 - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - grav = MAPL_GRAV - cp = MAPL_CP - beta = 6.5e-3 - -c Read ANA Variables -c ------------------ - call mpi_gfio_getvar ( id,'msl',nymd,nhms,imana,jmana,0,1 ,slp,rc,lattice ) - - call mpi_gfio_getvar ( id,'sp',nymd,nhms,imana,jmana,0,1 ,ps ,rc,lattice ) - -c Heights -c ------- - call mpi_gfio_getvar ( id,'z',nymd,nhms,imana,jmana,1,lmana,h,rc,lattice ) - if( Lzflip ) call zflip( h,imana,jmana,lmana ) - h = h / grav - -c Winds -c ----- - call mpi_gfio_getvar ( id,'u',nymd,nhms,imana,jmana,1,lmana,u,rc,lattice ) - if( Lzflip ) call zflip( u,imana,jmana,lmana ) - - call mpi_gfio_getvar ( id,'v',nymd,nhms,imana,jmana,1,lmana,v,rc,lattice ) - if( Lzflip ) call zflip( v,imana,jmana,lmana ) - -c Temperature -c ----------- - call mpi_gfio_getvar ( id,'t',nymd,nhms,imana,jmana,1,lmana,t,rc,lattice ) - if( Lzflip ) call zflip( t,imana,jmana,lmana ) - -c Specific Humidity -c ----------------- - call mpi_gfio_getvar ( id,'q',nymd,nhms,imana,jmana,1,lmana,q,rc,lattice ) - if( Lzflip ) call zflip( q,imana,jmana,lmana ) - -c Compute PHIS -c ------------ - ! do j=1,jm - ! do i=1,im - ! L=1 - ! do while( L.lt.lm .and. plevs(L).lt.ps(i,j)/100.0 ) - ! L=L+1 - ! enddo - ! LM1 = L-1 - ! phis(i,j) = h(i,j,L) - ( h(i,j,L)-h(i,j,LM1) )*log( 100*plevs(L)/ps(i,j) )/log( plevs(L)/plevs(LM1) ) - ! enddo - ! enddo - ! phis = phis*grav - - return - end - - subroutine mpi_gfio_getvar ( id,name,nymd,nhms,im,jm,lbeg,lm,q,rc,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer L,id,nymd,nhms,im,jm,img,jmg,lbeg,lm - real q(im,jm,lm) - real,allocatable :: glo(:,:,:) - character(*) name - integer rc - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg,lm) ) - if( lattice%myid.eq.0 ) then - call gfio_getvar ( id,trim(name),nymd,nhms,img,jmg,lbeg,lm,glo,rc ) - if( rc.ne.0 ) then - print *, 'Could not find ECMWF ',trim(name),' RC = ',rc - error stop 7 - endif - endif - do L=1,lm - call scatter_2d ( glo(1,1,L),q(1,1,L),lattice ) - enddo - deallocate ( glo ) - return - end - - subroutine mpi_gfio_putvar ( id,name,nymd,nhms,im,jm,lbeg,lm,q,rc,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer L,id,nymd,nhms,im,jm,img,jmg,lbeg,lm - real q(im,jm,lm) - real,allocatable :: glo(:,:,:) - character(*) name - integer rc - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg,lm) ) - do L=1,lm - call gather_2d ( glo(1,1,L),q(1,1,L),lattice ) - enddo - if( lattice%myid.eq.0 ) then - call gfio_putvar ( id,trim(name),nymd,nhms,img,jmg,lbeg,lm,glo,rc ) - endif - deallocate ( glo ) - return - end - - subroutine hflip ( q,im,jm,lm ) - implicit none - integer im,jm,lm,i,j,L - real*4 q(im,jm,lm),dum(im) - do L=1,lm - do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j,L) - dum(i+im/2) = q(i,j,L) - enddo - q(:,j,L) = dum(:) - enddo - enddo - return - end - - subroutine zflip ( q,im,jm,lm ) - implicit none - integer im,jm,lm,L - real*4 q(im,jm,lm),dum(im,jm,lm) - dum = q - do L=1,lm - q(:,:,L) = dum(:,:,lm+1-L) - enddo - return - end - - subroutine writit (q,im,jm,lm,ku) - real q (im,jm,lm) - real*4 q2(im,jm) - do L=lm,1,-1 - q2(:,:) = q(:,:,L) - write(ku) q2 - enddo - return - end - - subroutine qsat (tt,p,q,dqdt,ldqdt) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute Saturation Specific Humidity -C -C INPUT: -C ====== -C TT ......... Temperature (Kelvin) -C P .......... Pressure (mb) -C LDQDT ...... Logical Flag to compute QSAT Derivative -C -C OUTPUT: -C ======= -C Q .......... Saturation Specific Humidity -C DQDT ....... Saturation Specific Humidity Derivative wrt Temperature -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IMPLICIT NONE - REAL TT, P, Q, DQDT - LOGICAL LDQDT - REAL AIRMW, H2OMW - - PARAMETER ( AIRMW = 28.97 ) - PARAMETER ( H2OMW = 18.01 ) - - REAL ESFAC, ERFAC - PARAMETER ( ESFAC = H2OMW/AIRMW ) - PARAMETER ( ERFAC = (1.0-ESFAC)/ESFAC ) - - real aw0, aw1, aw2, aw3, aw4, aw5, aw6 - real bw0, bw1, bw2, bw3, bw4, bw5, bw6 - real ai0, ai1, ai2, ai3, ai4, ai5, ai6 - real bi0, bi1, bi2, bi3, bi4, bi5, bi6 - - real d0, d1, d2, d3, d4, d5, d6 - real e0, e1, e2, e3, e4, e5, e6 - real f0, f1, f2, f3, f4, f5, f6 - real g0, g1, g2, g3, g4, g5, g6 - -c ******************************************************** -c *** Polynomial Coefficients WRT Water (Lowe, 1977) **** -c *** (Valid +50 C to -50 C) **** -c ******************************************************** - - parameter ( aw0 = 6.107799961e+00 * esfac ) - parameter ( aw1 = 4.436518521e-01 * esfac ) - parameter ( aw2 = 1.428945805e-02 * esfac ) - parameter ( aw3 = 2.650648471e-04 * esfac ) - parameter ( aw4 = 3.031240396e-06 * esfac ) - parameter ( aw5 = 2.034080948e-08 * esfac ) - parameter ( aw6 = 6.136820929e-11 * esfac ) - - parameter ( bw0 = +4.438099984e-01 * esfac ) - parameter ( bw1 = +2.857002636e-02 * esfac ) - parameter ( bw2 = +7.938054040e-04 * esfac ) - parameter ( bw3 = +1.215215065e-05 * esfac ) - parameter ( bw4 = +1.036561403e-07 * esfac ) - parameter ( bw5 = +3.532421810e-10 * esfac ) - parameter ( bw6 = -7.090244804e-13 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice (Lowe, 1977) **** -c *** (Valid +0 C to -50 C) **** -c ******************************************************** - - parameter ( ai0 = +6.109177956e+00 * esfac ) - parameter ( ai1 = +5.034698970e-01 * esfac ) - parameter ( ai2 = +1.886013408e-02 * esfac ) - parameter ( ai3 = +4.176223716e-04 * esfac ) - parameter ( ai4 = +5.824720280e-06 * esfac ) - parameter ( ai5 = +4.838803174e-08 * esfac ) - parameter ( ai6 = +1.838826904e-10 * esfac ) - - parameter ( bi0 = +5.030305237e-01 * esfac ) - parameter ( bi1 = +3.773255020e-02 * esfac ) - parameter ( bi2 = +1.267995369e-03 * esfac ) - parameter ( bi3 = +2.477563108e-05 * esfac ) - parameter ( bi4 = +3.005693132e-07 * esfac ) - parameter ( bi5 = +2.158542548e-09 * esfac ) - parameter ( bi6 = +7.131097725e-12 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -40 C to -70 C) **** -c ******************************************************** - - - parameter ( d0 = 0.535098336e+01 * esfac ) - parameter ( d1 = 0.401390832e+00 * esfac ) - parameter ( d2 = 0.129690326e-01 * esfac ) - parameter ( d3 = 0.230325039e-03 * esfac ) - parameter ( d4 = 0.236279781e-05 * esfac ) - parameter ( d5 = 0.132243858e-07 * esfac ) - parameter ( d6 = 0.314296723e-10 * esfac ) - - parameter ( e0 = 0.469290530e+00 * esfac ) - parameter ( e1 = 0.333092511e-01 * esfac ) - parameter ( e2 = 0.102164528e-02 * esfac ) - parameter ( e3 = 0.172979242e-04 * esfac ) - parameter ( e4 = 0.170017544e-06 * esfac ) - parameter ( e5 = 0.916466531e-09 * esfac ) - parameter ( e6 = 0.210844486e-11 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -65 C to -95 C) **** -c ******************************************************** - - parameter ( f0 = 0.298152339e+01 * esfac ) - parameter ( f1 = 0.191372282e+00 * esfac ) - parameter ( f2 = 0.517609116e-02 * esfac ) - parameter ( f3 = 0.754129933e-04 * esfac ) - parameter ( f4 = 0.623439266e-06 * esfac ) - parameter ( f5 = 0.276961083e-08 * esfac ) - parameter ( f6 = 0.516000335e-11 * esfac ) - - parameter ( g0 = 0.312654072e+00 * esfac ) - parameter ( g1 = 0.195789002e-01 * esfac ) - parameter ( g2 = 0.517837908e-03 * esfac ) - parameter ( g3 = 0.739410547e-05 * esfac ) - parameter ( g4 = 0.600331350e-07 * esfac ) - parameter ( g5 = 0.262430726e-09 * esfac ) - parameter ( g6 = 0.481960676e-12 * esfac ) - - REAL TMAX, TICE - PARAMETER ( TMAX=323.15, TICE=273.16) - - REAL T, D, W, QX, DQX - T = MIN(TT,TMAX) - TICE - DQX = 0. - QX = 0. - -c Fitting for temperatures above 0 degrees centigrade -c --------------------------------------------------- - if(t.gt.0.) then - qx = aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6))))) - if (ldqdt) then - dqx = bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6))))) - endif - endif - -c Fitting for temperatures between 0 and -40 -c ------------------------------------------ - if( t.le.0. .and. t.gt.-40.0 ) then - w = (40.0 + t)/40.0 - qx = w *(aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6)))))) - . + (1.-w)*(ai0+T*(ai1+T*(ai2+T*(ai3+T*(ai4+T*(ai5+T*ai6)))))) - if (ldqdt) then - dqx = w *(bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6)))))) - . + (1.-w)*(bi0+T*(bi1+T*(bi2+T*(bi3+T*(bi4+T*(bi5+T*bi6)))))) - endif - endif - -c Fitting for temperatures between -40 and -70 -c -------------------------------------------- - if( t.le.-40.0 .and. t.ge.-70.0 ) then - qx = d0+T*(d1+T*(d2+T*(d3+T*(d4+T*(d5+T*d6))))) - if (ldqdt) then - dqx = e0+T*(e1+T*(e2+T*(e3+T*(e4+T*(e5+T*e6))))) - endif - endif - -c Fitting for temperatures less than -70 -c -------------------------------------- - if(t.lt.-70.0) then - qx = f0+t*(f1+t*(f2+t*(f3+t*(f4+t*(f5+t*f6))))) - if (ldqdt) then - dqx = g0+t*(g1+t*(g2+t*(g3+t*(g4+t*(g5+t*g6))))) - endif - endif - -c Compute Saturation Specific Humidity -c ------------------------------------ - D = (P-ERFAC*QX) - IF(D.LT.0.) THEN - Q = 1.0 - IF (LDQDT) DQDT = 0. - ELSE - D = 1.0 / D - Q = MIN(QX * D,1.0) - IF (LDQDT) DQDT = (1.0 + ERFAC*Q) * D * DQX - ENDIF - RETURN - END - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*abs(undef) - return - end - - subroutine getchar (name,num) - character*2 num2 - character*3 num3 - integer num - character*1 junk(256) - character*1 name(256) - data junk /256*' '/ - equivalence ( num2,junk ) - equivalence ( num3,junk ) - - num2 = ' ' - num3 = ' ' - - if( num.lt.100 ) then - write(num2,102) num - else if( num.lt.1000 ) then - write(num3,103) num - endif - - name = junk - - 102 format(i2.2) - 103 format(i3.3) - - return - end - - subroutine usage() - print *, "Usage: " - print * - print *, " ec_prs2eta.x -ecmwf ecmwf.data " - print *, " -phis phis.data " - print *, " [-tag tag]" - print *, " [-i0 i0 ]" - print *, " [-j0 i0 ]" - print *, " [-norecon ]" - print * - print *, "where:" - print * - print *, " -ecmwf ecmwf.data: Filename of ERA5 Pressure-Level Analysis Data" - print *, " -phis phis.data: Filename of ERA5 Surface Geopotential Data" - print *, " -tag tag: Optional Prefix tag for Output (Default: era5_ana.eta)" - print *, " -i0 i0: Optional Global I-Gridpoint for Diagnostics" - print *, " -j0 j0: Optional Global J-Gridpoint for Diagnostics" - print *, " -norecon Optional Flag to Turn OFF H for Diagnostics" - print * - error stop 7 - end - - subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef ) - implicit none - integer iin,jin, iout,jout, mlev - real qin(iin,jin,mlev), qout(iout,jout,mlev) - real undef,pi,dlin,dpin,dlout,dpout - real dlam(iin), lons(iout*jout), lon - real dphi(jin), lats(iout*jout), lat - integer i,j,loc - - pi = 4.0*atan(1.0) - dlin = 2*pi/iin - dpin = pi/(jin-1) - dlam(:) = dlin - dphi(:) = dpin - - dlout = 2*pi/ iout - dpout = pi/(jout-1) - - loc = 0 - do j=1,jout - do i=1,iout - loc = loc + 1 - lon = -pi + (i-1)*dlout - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jout - lat = -pi/2.0 + (j-1)*dpout - do i=1,iout - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call interp_h ( qin,iin,jin,mlev,dlam,dphi, - . qout,iout*jout,lons,lats,undef, -pi ) - - return - end - - subroutine interp_h ( q_cmp,im,jm,lm,dlam,dphi, - . q_geo,irun,lon_geo,lat_geo, undef, lon_min ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - - real :: lon_min - -c Local Variables -c --------------- - integer i,j,l - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real ap1, ap0, am1, am2 - real bp1, bp0, bm1, bm2 - - real lon_cmp(im) - real lat_cmp(jm) - real q_tmp(irun) - - real pi,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp - real lam_cmp - real phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = lon_min ! user supplied orign - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - do i=1,irun - lam_cmp = lon_geo(i) - phi_cmp = lat_geo(i) - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm1 = lat_cmp(jm1(i)) - - if( jm2(i).eq.0 ) then - phi_jm2 = phi_jm1 - dphi(1) - else - phi_jm2 = lat_cmp(jm2(i)) - endif - - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - else - phi_jp0 = lat_cmp(jp0(i)) - if( jp1(i).eq.jm+1 ) then - phi_jp1 = phi_jp0 + dphi(jm-1) - else - phi_jp1 = lat_cmp(jp1(i)) - endif - endif - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - -c Interpolate Computational-Grid Quantities to Geophysical Grid -c ------------------------------------------------------------- - do L=1,lm - do i=1,irun - - if( lat_geo(i).le.lat_cmp(2) .or. - . lat_geo(i).ge.lat_cmp(jm-1) ) then - -c 1st Order Interpolation at Poles -c -------------------------------- - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - else - -c Cubic Interpolation away from Poles -c ----------------------------------- - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jp1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp1(i),L ).ne.undef .and. - . q_cmp( im2(i),jp1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm2(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm2(i),L ).ne.undef .and. - . q_cmp( im1(i),jm2(i),L ).ne.undef .and. - . q_cmp( im2(i),jm2(i),L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) - . + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) - . + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) - . + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) - . + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) - . + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) - . + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - return - - end - - subroutine sigtopl ( qprs,q,logpl,logp,im,jm,lm,undef ) -C*********************************************************************** -C -C PURPOSE -C To interpolate an arbitrary quantity from Model Vertical Grid to Pressure -C -C INPUT -C Q ..... Q (im,jm,lm) Arbitrary Quantity on Model Grid -C PKZ ... PKZ (im,jm,lm) Pressure to the Kappa at Model Levels (From Phillips) -C PKSRF . PKSRF(im,jm) Surface Pressure to the Kappa -C PTOP .. Pressure at Model Top -C P ..... Output Pressure Level (mb) -C IM .... Longitude Dimension of Input -C JM .... Latitude Dimension of Input -C LM .... Vertical Dimension of Input -C -C OUTPUT -C QPRS .. QPRS (im,jm) Arbitrary Quantity at Pressure p -C -C NOTE -C Quantity is interpolated Linear in P**Kappa. -C Between PTOP**Kappa and PKZ(1), quantity is extrapolated. -C Between PKSRF**Kappa and PKZ(LM), quantity is extrapolated. -C Undefined Model-Level quantities are not used. -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** -C - implicit none - integer i,j,l,im,jm,lm - - real qprs(im,jm) - real q (im,jm,lm) - real logpl(im,jm,lm) - - real undef - real logp,temp - -c Initialize to UNDEFINED -c ----------------------- - do i=1,im*jm - qprs(i,1) = undef - enddo - -c Interpolate to Pressure Between Model Levels -c -------------------------------------------- - do L=1,lm-1 - if( all( logpl(:,:,L )>logp ) ) exit - if( all( logpl(:,:,L+1) 2 and km-1 => km -! ----------------------------------------------------------------- - else if( LM1.eq.1 .or. LP0.eq.km .or. 1.eq.1 ) then - q2(i,j,k) = q1(i,j,LP0) + ( q1(i,j,LM1)-q1(i,j,LP0) )*( logpl2(i,j,k )-logpl1(i,j,LP0) ) - . /( logpl1(i,j,LM1)-logpl1(i,j,LP0) ) - -! Interpolate Cubicly in LogP between other model levels -! ------------------------------------------------------ - else - LP1 = LP0+1 - LM2 = LM1-1 - P = logpl2(i,j,k) - PLP1 = logpl1(i,j,LP1) - PLP0 = logpl1(i,j,LP0) - PLM1 = logpl1(i,j,LM1) - PLM2 = logpl1(i,j,LM2) - DLP0 = dlogp1(i,j,LP0) - DLM1 = dlogp1(i,j,LM1) - DLM2 = dlogp1(i,j,LM2) - - ap1 = (P-PLP0)*(P-PLM1)*(P-PLM2)/( DLP0*(DLP0+DLM1)*(DLP0+DLM1+DLM2) ) - ap0 = (PLP1-P)*(P-PLM1)*(P-PLM2)/( DLP0* DLM1 *( DLM1+DLM2) ) - am1 = (PLP1-P)*(PLP0-P)*(P-PLM2)/( DLM1* DLM2 *(DLP0+DLM1 ) ) - am2 = (PLP1-P)*(PLP0-P)*(PLM1-P)/( DLM2*(DLM1+DLM2)*(DLP0+DLM1+DLM2) ) - - q2(i,j,k) = ap1*q1(i,j,LP1) + ap0*q1(i,j,LP0) + am1*q1(i,j,LM1) + am2*q1(i,j,LM2) - - endif - - enddo - enddo - enddo - - return - end - - subroutine remap ( ps1,dp1,u1,v1,thv1,q1,lm1, - . ps2,dp2,u2,v2,t2 ,q2,lm2,im,jm,nq ) - -C*********************************************************************** -C -C Purpose -C Driver for remapping input analysis (2) to output model levels (1) -C -C Argument Description -C ps1 ...... model surface pressure -C dp1 ...... model pressure thickness -C u1 ....... model zonal wind -C v1 ....... model meridional wind -C thv1 ..... model virtual potential temperature -C q1 ....... model specific humidity -C oz1 ...... model ozone -C lm1 ...... model vertical dimension -C -C ps2 ...... analysis surface pressure -C dp2 ...... analysis pressure thickness -C u2 ....... analysis zonal wind -C v2 ....... analysis meridional wind -C t2 . ..... analysis dry-bulb temperature -C q2 ....... analysis specific humidity -C oz2 ...... analysis ozone -C lm2 ...... analysis vertical dimension -C -C im ....... zonal dimension -C jm ....... meridional dimension -C nq ....... number of tracers -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - integer im,jm,lm1,lm2,nq - -c fv-DAS variables -c ---------------- - real dp1(im,jm,lm1) - real u1(im,jm,lm1) - real v1(im,jm,lm1) - real thv1(im,jm,lm1) - real q1(im,jm,lm1,nq) - real ps1(im,jm) - - real ak(lm1+1) - real bk(lm1+1) - -c Target analysis variables -c ------------------------- - real dp2(im,jm,lm2) - real u2(im,jm,lm2) - real v2(im,jm,lm2) - real t2(im,jm,lm2) - real thv2(im,jm,lm2) - real q2(im,jm,lm2,nq) - real ps2(im,jm) - -c Local variables -c --------------- - real pe1(im,jm,lm1+1) - real pe2(im,jm,lm2+1) - real pk2(im,jm,lm2 ) - real pke1(im,jm,lm1+1) - real pke2(im,jm,lm2+1) - - real kappa,cp,ptop,pl,alf,pint - real rgas,pref,tref,pkref,tstar,eps,rvap,grav - integer i,j,L,n,ks - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - -c Construct target analysis pressure variables -c -------------------------------------------- - do j=1,jm - do i=1,im - pe2(i,j,lm2+1) = ps2(i,j) - enddo - enddo - - do L=lm2,1,-1 - do j=1,jm - do i=1,im - pe2(i,j,L) = pe2(i,j,L+1) - dp2(i,j,L) - enddo - enddo - enddo - - do j=1,jm - do i=1,im - pe2(i,j,1) = max( pe2(i,j,1),1.0 ) ! Set ptop = 0.01 mb (rather than 0.0 mb from NCEP) - enddo - enddo - - do L=1,lm2+1 - do j=1,jm - do i=1,im - pke2(i,j,L) = pe2(i,j,L)**kappa - enddo - enddo - enddo - -c Construct target virtual potential temperature -c ---------------------------------------------- - do L=1,lm2 - do j=1,jm - do i=1,im - pk2(i,j,L) = ( pke2(i,j,L+1)-pke2(i,j,L) )/( kappa*log(pe2(i,j,L+1)/pe2(i,j,L)) ) - thv2(i,j,L) = t2(i,j,L)*( 1.0+eps*max(0.0,q2(i,j,L,1)) )/pk2(i,j,L) - enddo - enddo - enddo - -c Construct fv pressure variables using surface pressure and AK & BK -c ------------------------------------------------------------------ - call set_eta ( lm1,ks,ptop,pint,ak,bk ) - - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1(i,j,L) = ak(L) + bk(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -c Map Input Analysis onto fv grid -c ------------------------------- - call gmap ( im,jm,nq, kappa, - . lm2, pke2, pe2, u2, v2, thv2, q2, - . lm1, pke1, pe1, u1, v1, thv1, q1) - - return - end - - subroutine put_fveta ( ps,dp,u,v,thv,q,phis, - . im,jm,lm,nq,nymd,nhms,tag,ext,lats,lons, - . timeinc,precision,lattice ) - use MAPL_BaseMod, only: MAPL_UNDEF - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - integer im,jm,lm,nq,nymd,nhms - real phis(im,jm) - real ps(im,jm) - real dp(im,jm,lm) - real u(im,jm,lm) - real v(im,jm,lm) - real thv(im,jm,lm) - real q(im,jm,lm,nq) - integer timeinc - - real ple(im,jm,lm+1) - real pke(im,jm,lm+1) - real pk(im,jm,lm) - real tv(im,jm,lm) - real t(im,jm,lm) - - real lats(lattice%jmglobal) - real lons(lattice%imglobal) - real levs(lm) - real ak(lm+1) - real bk(lm+1) - - real rgas,rvap,eps,kappa,grav - real ptop,pref,dpref(lm),undef,lonbeg,pint - ! real dlon,dlat - integer i,j,L,m,n,rc,ks - character*256 tag,ext,filename, fname - integer nvars,fid,precision - - character*256 levunits - character*256 title - character*256 source - character*256 contact - character*256, allocatable, dimension(:) :: vname - character*256, allocatable, dimension(:) :: vtitle - character*256, allocatable, dimension(:) :: vunits - integer, allocatable, dimension(:) :: lmvar - - real, allocatable :: v_range(:,:) - real, allocatable :: p_range(:,:) - - character*2 cnhms - character*3 cLM - character*8 cnymd - - if( lattice%myid.eq.0 ) print *, im,jm,lm,nq,nymd,nhms,trim(ext) - - undef = MAPL_UNDEF - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - eps = rvap/rgas-1.0 - - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - write( cLM,400 ) lm - 200 format(i8.8) - 300 format(i2.2) - 400 format(i3.3) - fname = trim(tag) // 'era5_ana.eta_L' // trim(cLM) // '.' // trim(cnymd) // '_' // trim(cnhms) // 'z.' // trim(ext) - if( lattice%myid.eq.0 ) print *, 'Creating 32-bit eta file: ',trim(fname) - - call set_eta ( lm,ks,ptop,pint,ak,bk ) - -! Construct T, TV -! --------------- - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - tv = thv*pk - t(:,:,:) = tv(:,:,:)/(1+eps*q(:,:,:,1)) - -c String and vars settings -c ------------------------ - title = 'ERA5_PRS2ETA Data' - source = 'Goddard Modeling and Assimilation Office, NASA/GSFC' - contact = 'data@gmao.gsfc.nasa.gov' - levunits = 'hPa' - - nvars = 7 - - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - allocate ( v_range(2,nvars) ) - allocate ( p_range(2,nvars) ) - - n = 1 - vname(n) = 'phis' - vtitle(n) = 'Topography geopotential' - vunits(n) = 'meter2/sec2' - lmvar(n) = 0 - - n = n + 1 - vname(n) = 'ps' - vtitle(n) = 'Surface Pressure' - vunits(n) = 'Pa' - lmvar(n) = 0 - - n = n + 1 - vname(n) = 'dp' - vtitle(n) = 'Pressure Thickness' - vunits(n) = 'Pa' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'u' - vtitle(n) = 'eastward_wind' - vunits(n) = 'm/s' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'v' - vtitle(n) = 'northward_wind' - vunits(n) = 'm/s' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'tv' - vtitle(n) = 'air_virtual_temperature' - vunits(n) = 'K' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'qv' - vtitle(n) = 'Specific Humidity Vapor' - vunits(n) = 'kg/kg' - lmvar(n) = lm - - v_range(:,:) = undef - p_range(:,:) = undef - -c Compute grid -c ------------ - ! dlon = 360.0/ lattice%imglobal - ! dlat = 180.0/(lattice%jmglobal-1) - - ! do j=1,lattice%jmglobal - ! lats(j) = -90.0 + (j-1)*dlat - ! enddo - ! do i=1,lattice%imglobal - ! lons(i) = lonbeg + (i-1)*dlon - ! enddo - - do L=1,lm - dpref(L) = (ak(L+1)-ak(L)) + (bk(L+1)-bk(L))*98400.0 - enddo - pref = ptop + 0.5*dpref(1) - levs(1) = pref - do L=2,lm - pref = pref + 0.5*( dpref(L)+dpref(L-1) ) - levs(L) = pref - enddo - levs(:) = levs(:)/100 - -c Create GFIO file -c ---------------- - if( lattice%myid.eq.0 ) then - call GFIO_Create ( fname, title, source, contact, undef, - . lattice%imglobal, lattice%jmglobal, lm, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vname, vtitle, vunits, lmvar, - . v_range, p_range, precision, - . fid, rc ) - endif - -c Write GFIO data -c --------------- - n = 1 - call mpi_gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,0, 1,phis,rc,lattice ) ; n = n+1 - call mpi_gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,0, 1,ps ,rc,lattice ) ; n = n+1 - call mpi_gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,dp ,rc,lattice ) ; n = n+1 - call mpi_gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,u ,rc,lattice ) ; n = n+1 - call mpi_gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,v ,rc,lattice ) ; n = n+1 - call mpi_gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,tv ,rc,lattice ) ; n = n+1 - do m=1,nq - call mpi_gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,q(1,1,1,m),rc,lattice ) ; n = n+1 - enddo - -c Write GFIO global attributes -c ---------------------------- - if( lattice%myid.eq.0 ) then - call GFIO_PutRealAtt ( fid,'ak', lm+1,ak ,precision,rc ) - call GFIO_PutRealAtt ( fid,'bk', lm+1,bk ,precision,rc ) - call gfio_close ( fid,rc ) - endif - - return - end - subroutine gfio_get ( fname,id,im,jm,lm,ntime,nvars,nymdb,nhmsb,nymde,nhmse,ndt,rc ) - character (len=*), intent(IN) :: fname - integer , optional, intent(OUT) :: id - integer , optional, intent(OUT) :: im - integer , optional, intent(OUT) :: jm - integer , optional, intent(OUT) :: lm - integer , optional, intent(OUT) :: ntime - integer , optional, intent(OUT) :: nvars - integer , optional, intent(OUT) :: nymdb - integer , optional, intent(OUT) :: nhmsb - integer , optional, intent(OUT) :: nymde - integer , optional, intent(OUT) :: nhmse - integer , optional, intent(OUT) :: ndt - integer , optional, intent(OUT) :: rc - - integer idx - integer imx - integer jmx - integer lmx - integer ntimex - integer nvarsx - integer ngatts - integer ndtx - integer rcx - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - real , allocatable :: lat(:) - real , allocatable :: lon(:) - real , allocatable :: lev(:) - real , allocatable :: vrange(:,:) - real , allocatable :: prange(:,:) - integer , allocatable :: kmvar(:) - integer , allocatable :: yymmdd(:) - integer , allocatable :: hhmmss(:) - real :: undef - integer nsecf - - call gfio_open ( trim(fname),1,idx,rcx ) - ! print *, 'Checking file: ',trim(fname),' rc = ',rcx - - call gfio_diminquire ( idx,imx,jmx,lmx,ntimex,nvarsx,ngatts,rcx ) - ! print *, ' im: ',imx - ! print *, ' jm: ',jmx - ! print *, ' lm: ',lmx - ! print *, ' ntime: ',ntimex - ! print *, ' nvars: ',nvarsx - ! print *, ' rc: ',rcx - - allocate ( lon(imx) ) - allocate ( lat(jmx) ) - allocate ( lev(lmx) ) - allocate ( yymmdd( ntimex) ) - allocate ( hhmmss( ntimex) ) - allocate ( vname( nvarsx) ) - allocate ( vtitle( nvarsx) ) - allocate ( vunits( nvarsx) ) - allocate ( kmvar( nvarsx) ) - allocate ( vrange(2,nvarsx) ) - allocate ( prange(2,nvarsx) ) - - call gfio_inquire ( idx,imx,jmx,lmx,ntimex,nvarsx, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,ndtx, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rcx ) - ndtx = nsecf (ndtx) - ! print *, ' ndt: ',ndtx - - if(present(rc) ) rc = rcx - if(present(im) ) im = imx - if(present(jm) ) jm = jmx - if(present(lm) ) lm = lmx - if(present(ndt) ) ndt = ndtx - if(present(ntime)) ntime = ntimex - if(present(nvars)) nvars = nvarsx - if(present(nymdb)) nymdb = yymmdd(1) - if(present(nhmsb)) nhmsb = hhmmss(1) - if(present(nymde)) nymde = yymmdd(ntime) - if(present(nhmse)) nhmse = hhmmss(ntime) - - if( present(id) ) then - id = idx - else - call gfio_close ( idx,rcx ) - endif - - return - end - - function nsecf (nhms) -!*********************************************************************** -! Purpose -! Converts NHMS format to Total Seconds -!*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end function nsecf - diff --git a/GEOS_Util/post/eta2prs.F b/GEOS_Util/post/eta2prs.F deleted file mode 100644 index 6cde3469..00000000 --- a/GEOS_Util/post/eta2prs.F +++ /dev/null @@ -1,2790 +0,0 @@ - program main - - implicit none - include 'alias.com' - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to create prs output from an eta file **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm,nt - - integer nymd ,nhms - integer nymd0 ,nhms0 - integer nymdr ,nhmsr - integer nymdb ,nhmsb - integer nymdb0,nhmsb0 - - integer im_out, jm_out - - -c Generic Model Variables -c ----------------------- - real, allocatable :: ps(:,:) - real, allocatable :: dp(:,:,:) - real, allocatable :: q2d(:,:,:) - real, allocatable :: q3d(:,:,:,:) - - -c HDF and other Local Variables -c ----------------------------- - logical, pointer :: Lsurf (:) - real, pointer :: lon (:) - real, pointer :: lat (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - character*256, pointer :: unit2d(:), unit3d(:) - character*256, pointer :: namesp (:) - character*256, pointer :: name2dp(:), name3dp(:) - character*256, pointer :: titl2dp(:), titl3dp(:) - character*256, pointer :: unit2dp(:), unit3dp(:) - - integer id,rc,fid,nhmsf,n2d,n3d - integer idpr,n2dp,n3dp,nvarsp - integer nvars,ntime,ntimes,gfrc - - real, allocatable :: plevs(:) - character*256, allocatable :: arg(:) - character*256, allocatable :: fname(:) - character*256, allocatable :: prfname(:) - character*256 name - character*256 output, hdfile - character*256 ftype - character*256 ext - - character*8 date0 - character*4 time0 - character*2 hour0,mins0 - character*1 char - data output /'eta2prs'/ - - integer n,m,nargs,L,nfiles,npfiles,mlev - - real*8 lonbeg - real undef - - real, allocatable :: dum2d(:,:) - real, allocatable :: dum3d(:,:,:) - - integer ndt - logical hdf, quad - logical nopres - logical hdfcreate - logical edges - logical underg - real ptop - - interface - subroutine read_hdf_meta ( hdffile,im,jm,lm,n2d,n3d,lat,lon,lonbeg,undef,id, - . nymdb,nhmsb,ndt,ntimes, - . nvars,names,Lsurf,name2d,titl2d,unit2d,name3d,titl3d,unit3d ) - logical, pointer :: Lsurf (:) - real, pointer :: lat (:) - real, pointer :: lon (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - character*256, pointer :: unit2d(:), unit3d(:) - character*256 hdffile - integer id,im,jm,lm,n2d,n3d,nvars - integer nymdb,nhmsb,ndt,ntimes - real undef - real*8 lonbeg - end subroutine read_hdf_meta - end interface - -C ********************************************************************** -C **** Initialization **** -C ********************************************************************** - - call timebeg ('main') - ftype = 'xxx' - im_out = -999 - jm_out = -999 - nymd0 = -999 - nhms0 = -999 - nymdb0 = -999 - nhmsb0 = -999 - ptop = 1.0 - nt = 1 - ndt = 0 - hdf = .true. - quad = .true. - nopres = .false. - underg = .false. - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-ptop' ) read(arg(n+1),*) ptop - if( trim(arg(n)).eq.'-im' ) read(arg(n+1),*) im_out - if( trim(arg(n)).eq.'-jm' ) read(arg(n+1),*) jm_out - if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1),*) nymd0 - if( trim(arg(n)).eq.'-nhms' ) read(arg(n+1),*) nhms0 - if( trim(arg(n)).eq.'-nymdb' ) read(arg(n+1),*) nymdb0 - if( trim(arg(n)).eq.'-nhmsb' ) read(arg(n+1),*) nhmsb0 - if( trim(arg(n)).eq.'-ndt' ) read(arg(n+1),*) ndt - if( trim(arg(n)).eq.'-hdf' ) read(arg(n+1),*) hdf - if( trim(arg(n)).eq.'-noquad' ) quad = .false. - if( trim(arg(n)).eq.'-ana' ) ftype = 'ana' - if( trim(arg(n)).eq.'-underg' ) underg = .true. - if( trim(arg(n)).eq.'-tag' ) output = arg(n+1) - - if( trim(arg(n)).eq.'-levs' ) then - mlev = 1 - read(arg(n+mlev),fmt='(a1)') char - do while (char.ne.'-' .and. n+mlev.lt.nargs ) - mlev = mlev+1 - read(arg(n+mlev),fmt='(a1)') char - enddo - if( char.eq.'-' ) mlev = mlev-1 - allocate ( plevs(mlev) ) - do m=1,mlev - read(arg(n+m),*) plevs(m) - enddo - endif - - if( trim(arg(n)).eq.'-eta' ) then - nfiles = 1 - read(arg(n+nfiles),fmt='(a1)') char - do while (char.ne.'-' .and. n+nfiles.ne.nargs ) - nfiles = nfiles+1 - read(arg(n+nfiles),fmt='(a1)') char - enddo - if( char.eq.'-' ) nfiles = nfiles-1 - allocate ( fname(nfiles) ) - do m=1,nfiles - fname(m) = arg(n+m) - enddo - endif - - if( trim(arg(n)).eq.'-prs' ) then - nopres = .true. - npfiles = 1 - read(arg(n+npfiles),fmt='(a1)') char - do while (char.ne.'-' .and. n+npfiles.ne.nargs ) - npfiles = npfiles+1 - read(arg(n+npfiles),fmt='(a1)') char - enddo - if( char.eq.'-' ) npfiles = npfiles-1 - allocate ( prfname(npfiles) ) - do m=1,npfiles - prfname(m) = arg(n+m) - enddo - if( npfiles .ne. nfiles) then - print *,' need same number of pressure,diag files', - . ' nfiles= ',nfiles,' npfiles= ',npfiles - stop - endif - endif - - enddo - endif - -C ********************************************************************** -C **** Read HDF Meta Data **** -C ********************************************************************** - - if( nopres) then - call read_hdf_meta ( fname(1),im,jm,lm,n2d,n3d,lat,lon,lonbeg,undef,id, - . nymdb,nhmsb,ndt,ntimes, - . nvars,names,Lsurf,name2d,titl2d,unit2d,name3d,titl3d,unit3d ) - - call read_hdf_meta ( prfname(1),im,jm,lm,n2dp,n3dp,lat,lon,lonbeg,undef,idpr, - . nymdb,nhmsb,ndt,ntimes, - . nvarsp,namesp,Lsurf,name2dp,titl2dp,unit2dp,name3dp,titl3dp,unit3dp ) - - else - call read_hdf_meta ( fname(1),im,jm,lm,n2d,n3d,lat,lon,lonbeg,undef,id, - . nymdb,nhmsb,ndt,ntimes, - . nvars,names,Lsurf,name2d,titl2d,unit2d,name3d,titl3d,unit3d ) - - endif - -C ********************************************************************** -C **** Summarize Input Variables **** -C ********************************************************************** - - allocate ( ps(im,jm) ) - allocate ( dp(im,jm,lm) ) - allocate ( q2d(im,jm, n2d) ) - allocate ( q3d(im,jm,lm,n3d) ) - allocate ( dum2d(im,jm) ) - allocate ( dum3d(im,jm,lm) ) - - if( im_out.eq.-999 ) im_out = im - if( jm_out.eq.-999 ) jm_out = jm - - -c Define Beginning Date and Time to Read -c -------------------------------------- - if( nymdb0 /= -999 ) nymdb = nymdb0 - if( nhmsb0 /= -999 ) nhmsb = nhmsb0 - - -c Define Date and Time to Write in Output -c --------------------------------------- - if( nymd0 == -999 ) then - nymd = nymdb - else - nymd = nymd0 - endif - if( nhms0 == -999 ) then - nhms = nhmsb - else - nhms = nhms0 - endif - - print * - print *, ' Output Resolution im: ',im_out - print *, ' Output Resolution jm: ',jm_out - print * - print *, 'Beginning Date to Read: ',nymdb - print *, 'Beginning Time to Read: ',nhmsb - print * - print *, 'Beginning Date to Write: ',nymd - print *, 'Beginning Time to Write: ',nhms - print *, ' Time Increment: ',nhmsf(ndt),' (',ndt,' seconds)' - print * - print *, ' lm: ',lm - print *, ' plevs: ',(plevs(L),L=1,mlev) - print * - print *, '2-D Fields:' - do n=1,n2d - print *, trim(name2d(n)),' ',trim(unit2d(n)),' ',trim(titl2d(n)) - enddo - print * - print *, '3-D Fields:' - do n=1,n3d - print *, trim(name3d(n)),' ',trim(unit3d(n)),' ',trim(titl3d(n)) - enddo - print * - - if( nopres ) then - print *, 'Pressure Files (for ps,delp info): ' - do n=1,nfiles - print *, n,trim(prfname(n)) - enddo - print * - endif - - print *, 'Eta Files: ' - do n=1,nfiles - print *, n,trim(fname(n)) - enddo - print * - name = fname(1) - n = index(trim(name),'.',back=.true.) - ext = trim(name(n+1:)) - - plevs(1:mlev) = plevs(mlev:1:-1)*100 - -C ********************************************************************** -C **** Read and Interpolate Eta File **** -C ********************************************************************** - - edges = .false. - - do n=1,nfiles - if( nopres ) print *, 'Opening: ',trim(prfname(n)) - print *, 'Opening: ',trim( fname(n)) - - write(date0,1000) nymd - write(hour0,2000) nhms/10000 - write(mins0,2000) (nhms-(nhms/10000)*10000)/100 - 1000 format(i8.8) - 2000 format(i2.2) - time0 = trim(hour0)//trim(mins0) - - if(hdf) then - hdfile = trim(output) // "." // trim(date0) // "_" // trim(time0) // "z." // trim(ext) - else - hdfile = trim(output) // "." // trim(date0) // "_" // trim(time0) // "z.bin" - endif - - call gfio_close ( id,rc ) - call gfio_open ( trim(fname(n)),1,id,rc ) - if( nopres ) then - call gfio_close ( idpr,rc ) - call gfio_open ( trim(prfname(n)),1,idpr,rc ) - endif - - rc = 0 - ntime = 0 - hdfcreate = .true. - dowhile (rc.eq.0) - ntime = ntime + 1 - print * - - nymdr = nymd - nhmsr = nhms - - if( (nymd.eq.nymdb .or. nymd.eq.nymd0) .and. - . (nhms.eq.nhmsb .or. nhms.eq.nhms0) ) then - if( nymdb /= nymd ) nymdr = nymdb - if( nhmsb /= nhms ) nhmsr = nhmsb - endif - - print *, 'Reading nymd: ',nymdr,' nhms: ',nhmsr - if( nopres ) then - call read_hdf_data ( idpr,dp,ps,q2d,q3d,n2dp,n3dp,name2dp,name3dp,.true.,.false., - . im,jm,lm,nymdr,nhmsr,rc,ntime,ntimes,edges,ftype,ptop ) - call read_hdf_data ( id,dum3d,dum2d,q2d,q3d,n2d,n3d,name2d,name3d,.false.,.true., - . im,jm,lm,nymdr,nhmsr,rc,ntime,ntimes,edges,ftype,ptop ) - else - call read_hdf_data ( id,dp,ps,q2d,q3d,n2d,n3d,name2d,name3d,.true.,.true., - . im,jm,lm,nymdr,nhmsr,rc,ntime,ntimes,edges,ftype,ptop ) - endif - - if( rc.eq.0 ) then - print *, 'Writing nymd: ',nymd,' nhms: ',nhms - call timebeg (' Eta2Prs') - call eta2prs ( dp,ps,ptop,q2d,q3d,name2d,titl2d,unit2d,name3d,titl3d,unit3d,n2d,n3d,undef, - . im,jm,lm,plevs,mlev,im_out,jm_out,lat,lon,lonbeg,nymd,nhms,ndt, - . fid,hdf,hdfcreate,hdfile,quad,edges,ftype,underg ) - call timeend (' Eta2Prs') - call tick (nymd,nhms,ndt) - hdfcreate = .false. - else - if(hdf) then - call gfio_close ( fid,gfrc ) - else - close(55) - endif - print *, 'Created: ',trim(hdfile) - print * - print * - endif - enddo - enddo - -c Write Timing Information -c ------------------------ - call timeend ('main') - call timepri (6) - - deallocate ( dp,ps,arg ) - - stop - end - - subroutine read_hdf_meta ( hdffile,im,jm,lm,n2d,n3d,lat,lon,lonbeg,undef,id, - . nymdb,nhmsb,ndt,ntime, - . nvars,names,Lsurf,name2d,titl2d,unit2d,name3d,titl3d,unit3d ) - implicit none - - logical, pointer :: Lsurf (:) - real, pointer :: lat (:) - real, pointer :: lon (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - character*256, pointer :: unit2d(:), unit3d(:) - - character*256 hdffile - integer id,im,jm,lm,n2d,n3d,nvars,nsecf,timeId,ncvid - integer ntime,ngatts,rc,timinc,nymdb,nhmsb,ndt - real undef - real*8 lonbeg - integer n - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - -C ********************************************************************** -C **** Read HDF File for Meta Data **** -C ********************************************************************** - - call gfio_open ( trim(hdffile),1,id,rc ) - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( names(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - timinc = 0 - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - - if( timinc .eq. 0 ) then - timeId = ncvid (id, 'time', rc) - call ncagt (id, timeId, 'time_increment', timinc, rc) - if( timinc .eq. 0 ) then - print * - print *, 'Warning, GFIO Inquire states TIMINC = ',timinc - print *, ' This will be reset to 060000 ' - print *, ' Use -ndt NNNNNN (in seconds) to overide this' - timinc = 060000 - endif - endif - - if( ndt.eq.0 ) ndt = nsecf (timinc) - - nymdb = yymmdd(1) - nhmsb = hhmmss(1) - names = vname - lonbeg = lon(1) - - n2d = 0 - n3d = 0 - do n=1,nvars - if( kmvar(n).eq.0 ) then - n2d = n2d + 1 - else - n3d = n3d + 1 - endif - enddo - - allocate( Lsurf(nvars) ) - allocate( name2d(n2d) ) - allocate( titl2d(n2d) ) - allocate( unit2d(n2d) ) - allocate( name3d(n3d) ) - allocate( titl3d(n3d) ) - allocate( unit3d(n3d) ) - - n2d = 0 - n3d = 0 - do n=1,nvars - if( kmvar(n).eq.0 ) then - n2d = n2d + 1 - name2d(n2d) = vname (n) - titl2d(n2d) = vtitle(n) - unit2d(n2d) = vunits(n) - else - n3d = n3d + 1 - name3d(n3d) = vname (n) - titl3d(n3d) = vtitle(n) - unit3d(n3d) = vunits(n) - endif - enddo - - return - end subroutine read_hdf_meta - - subroutine read_hdf_data ( id,dp,ps,q2d,q3d,n2d,n3d,name2d,name3d,lprs,leta, - . im,jm,lm,nymd,nhms,rc,ntime,ntimes,edges,ftype,ptop ) - implicit none - include 'alias.com' - - integer im,jm,lm,nymd,nhms,id,rc - integer n2d,n3d,ntime,ntimes - real ptop - real ps(im,jm) - real dp(im,jm,lm) - real q2d(im,jm ,n2d) - real q3d(im,jm,lm,n3d) - character*256 name2d(n2d) - character*256 name3d(n3d) - character*256 ftype - logical edges - logical lprs,leta,zflip - integer i,j,L,n - logical match - - real, allocatable :: pl(:,:,:) - - ps = -999 - dp = -999 - zflip = .false. - - rc = 0 - if( ntime <= ntimes ) then - -c Search for Pressure Information -c ------------------------------- - if( lprs ) then - do n=1,n2d - if( match( c_ps,name2d(n) ) ) then - call timebeg (' GetVar') - call gfio_getvar ( id,trim(name2d(n)),nymd,nhms,im,jm,0, 1,ps,rc ) - call timeend (' GetVar') - if( rc.ne.0 ) then - rc = 1 ! No more time periods in file - return - endif - endif - enddo - - edges = .false. - -! First Priority: Check for DP within File -! ----------------------------------------- - do n=1,n3d - if( match( c_dp,name3d(n) ) ) then ! 1st-Priority - call timebeg (' GetVar') - call gfio_getvar ( id,trim(name3d(n)),nymd,nhms,im,jm,1,lm,dp,rc ) - call timeend (' GetVar') - if( dp(1,1,1).gt.dp(1,1,lm) ) then - dp(:,:,1:lm) = dp(:,:,lm:1:-1) - zflip = .true. - endif - if( ps(1,1).eq.-999 ) then - ps(:,:) = ptop - do L=1,LM - ps(:,:) = ps(:,:) + dp(:,:,L) - enddo - endif - endif - enddo - -! Second Priority: Check for PLE within File -! ------------------------------------------- - if( dp(1,1,1).eq.-999 ) then - do n=1,n3d - if( match( c_ple,name3d(n) ) ) then ! 2nd-Priority - edges = .true. - call timebeg (' GetVar') - call gfio_getvar ( id,trim(name3d(n)),nymd,nhms,im,jm,1,lm,dp,rc ) - if( dp(1,1,1).gt.dp(1,1,lm) ) then - dp(:,:,1:lm) = dp(:,:,lm:1:-1) - zflip = .true. - endif - call timeend (' GetVar') - ps(:,:) = dp(:,:,lm) - endif - enddo - endif - -! Third Priority: Check for PL within File -! ----------------------------------------- - if( dp(1,1,1).eq.-999 ) then - do n=1,n3d - if( match( c_pl,name3d(n) ) ) then ! 3rd-Priority - allocate( pl(im,jm,lm) ) - call timebeg (' GetVar') - call gfio_getvar ( id,trim(name3d(n)),nymd,nhms,im,jm,1,lm,pl,rc ) - call timeend (' GetVar') - if( pl(1,1,1).gt.pl(1,1,lm) ) then - pl(:,:,1:lm) = pl(:,:,lm:1:-1) - zflip = .true. - endif - dp(:,:,lm) = 2*( ps(:,:)-pl(:,:,lm) ) - do L=lm-1,1,-1 - dp(:,:,L) = 2*( pl(:,:,L+1)-0.5*dp(:,:,L+1)-pl(:,:,L) ) - enddo - deallocate( pl ) - endif - enddo - endif - - do L=1,lm - do j=1,jm - do i=1,im - if( ps(i,j).eq.-999 .or. dp(i,j,L).eq.-999 ) then - print *, 'PS and DelP were not created!' - stop - endif - enddo - enddo - enddo - endif - -c Collect Eta Data -c ---------------- - if( leta ) then - call timebeg (' GetVar') - do n=1,n2d - call gfio_getvar ( id,trim(name2d(n)),nymd,nhms,im,jm,0,1,q2d(1,1,n),rc ) - if( rc.ne.0 ) then - rc = 1 ! No more time periods in file - return - endif - enddo - do n=1,n3d - call gfio_getvar ( id,trim(name3d(n)),nymd,nhms,im,jm,1,lm,q3d(1,1,1,n),rc ) - if( zflip ) then - q3d(:,:,1:lm,n) = q3d(:,:,lm:1:-1,n) - endif - if( trim(name3d(n)).eq.'uwnd' .and. trim(ftype).eq.'ana' ) then - call dtoa ( q3d(1,1,1,n),q3d(1,1,1,n),im,jm,lm,2 ) - endif - if( trim(name3d(n)).eq.'vwnd' .and. trim(ftype).eq.'ana' ) then - call dtoa ( q3d(1,1,1,n),q3d(1,1,1,n),im,jm,lm,1 ) - endif - enddo - call timeend (' GetVar') - endif - - else - rc = 1 ! No more time periods in file - endif - - return - end subroutine read_hdf_data - - subroutine eta2prs ( dp,ps,ptop,q2d,q3d,name2d,titl2d,unit2d,mame3d,titl3d,unit3d,n2d,n3d,undef, - . im,jm,lm,plev,mlev,im_out,jm_out,latin,lonin,lonbeg,nymd,nhms,ninc, - . id,hdf,create,filename,quad,edges,ftype,underg ) - use MAPL_ConstantsMod - use GEOS_UtilsMod, only: GEOS_Qsat - implicit none - include 'alias.com' - -c Input Variables -c --------------- - integer im,jm,lm,mlev,im_out,jm_out,nymd,nhms,ninc,n2d,n3d - - real dp(im,jm,lm) - real ps(im,jm) - real q2d(im,jm, n2d) - real q3d(im,jm,lm,n3d) - - character*256 name2d(n2d), titl2d(n2d), unit2d(n2d) - character*256 name3d(n3d), titl3d(n3d), unit3d(n3d) - character*256 mame3d(n3d) - character*256 filename - character*256 ftype - - real plev(mlev) ! Target Pressures for Output - real ptop ! Model Top Pressure - real*8 lonbeg, dlon, dlat - real*8 lat(jm_out),lon(im_out) - real latin(jm),lonin(im) - logical hdf, create, quad, edges, underg - logical match - -c Local Variables -c --------------- - integer i,j,L,n,m - real logpe(im,jm,lm+1) - real logpl(im,jm,lm) - real logps(im,jm) - real logpt(im,jm) - - real, allocatable :: pk (:,:,:) ! Model pressure at edge-levels - real, allocatable :: pke(:,:,:) ! Model pressure at edge-levels - real, allocatable :: pe(:,:,:) ! Model pressure at edge-levels - real, allocatable :: qprs(:,:,:) ! Interpolated Quantity - - real lats(jm_out),lons(im_out),levs(mlev) - real undef,eps,grav,cp,rgas,rvap - integer precision,id,timeinc,rc,nhmsf - - character*256 levunits - character*256 title - character*256 source - character*256 contact - - integer nvars - integer i_u, i_v, i_t, i_tv, i_q, i_th, i_thv, i_phis, i_slp - - character*256, allocatable :: vname(:) , vname2(:) - character*256, allocatable :: vtitle(:) , vtitle2(:) - character*256, allocatable :: vunits(:) , vunits2(:) - integer, allocatable :: lmvar(:) , lmvar2(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - - real dum,kappa - - -c Value-Added Products -c -------------------- - real, allocatable :: up(:,:,:), uprime(:,:,:) - real, allocatable :: vp(:,:,:), vprime(:,:,:) - real, allocatable :: tp(:,:,:), tprime(:,:,:) - real, allocatable :: qp(:,:,:) - real, allocatable :: hp(:,:,:) - real, allocatable :: sphu(:,:,:) - real, allocatable :: qstar(:,:,:) - real, allocatable :: tmpu(:,:,:) - real, allocatable :: rh(:,:,:) - real, allocatable :: th(:,:,:) - real, allocatable :: tv(:,:,:) - real, allocatable :: thv(:,:,:) - real, allocatable :: phi(:,:,:) - real, allocatable :: phis(:,:) - real, allocatable :: slp(:,:) - real, allocatable :: tpw(:,:) - - integer nuu, nvv, ntt, nqq, nuv, nut, nuq, nqs, nrh - integer nvt, nvq, nupvp, nvptp, nh, ntp, nslp, ntpw - -C ********************************************************************** -C **** Initialize Constants And Local Arrays **** -C ********************************************************************** - - call timebeg (' Setup*') - - nvars = n2d + n3d - kappa = MAPL_KAPPA - grav = MAPL_GRAV - cp = MAPL_CP - rgas = MAPL_RGAS - rvap = MAPL_RVAP - eps = rvap/rgas-1.0 - - allocate ( qstar(im,jm,mlev) ) - allocate ( qprs(im,jm,mlev) ) - allocate ( rh(im,jm,mlev) ) - allocate ( qp(im,jm,mlev) ) - - allocate ( pe(im,jm,lm+1) ) - allocate ( pk(im,jm,lm) ) - allocate ( pke(im,jm,lm+1) ) - -c Load Variable Names into Local Temporary due to Analysis's Non-Conventional Notation -c ------------------------------------------------------------------------------------ - name3d = mame3d - -C ********************************************************************** -C **** Initialize GFIO File **** -C ********************************************************************** - - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - - timeinc = nhmsf(ninc) - precision = 1 ! 64-bit - precision = 0 ! 32-bit - - title = 'GEOS-5 GCM (Pressure Coordinates)' - source = 'Goddard Modeling and Assimilation Office, NASA/GSFC' - contact = 'data@gmao.gsfc.nasa.gov' - levunits = 'mb' - -c Defined Fields -c -------------- - do m=1,n2d - n = m - vname(n) = name2d(m) - vtitle(n) = trim(titl2d(m)) - vunits(n) = trim(unit2d(m)) - lmvar(n) = 0 - enddo - - do m=1,n3d - -c Fix Analysis Non-Conventional Names -c ----------------------------------- - if( trim(ftype).eq.'ana' .and. trim(name3d(m)).eq.'theta' ) then - name3d(m) = 'thetav' - titl3d(m) = 'Scaled Virtual Potential Temperature' - endif - n = n2d+m - vname(n) = name3d(m) - vtitle(n) = trim(titl3d(m)) - vunits(n) = trim(unit3d(m)) - lmvar(n) = mlev - enddo - -C ********************************************************************** -C **** Value Added Products **** -C ********************************************************************** - - i_phis = 0 - i_u = 0 - i_v = 0 - i_t = 0 - i_q = 0 - i_th = 0 - i_tv = 0 - i_thv = 0 - i_slp = 0 - nqs = 0 - ntp = 0 - nrh = 0 - nslp = 0 - ntpw = 0 - - do n=1,n2d - if( match( c_phis,name2d(n) ) ) i_phis = n - if( match( c_slp ,name2d(n) ) ) i_slp = n - enddo - do n=1,n3d - if( match( c_u ,name3d(n) ) ) i_u = n - if( match( c_v ,name3d(n) ) ) i_v = n - if( match( c_t ,name3d(n) ) ) i_t = n - if( match( c_q ,name3d(n) ) ) i_q = n - if( match( c_th ,name3d(n) ) ) i_th = n - if( match( c_tv ,name3d(n) ) ) i_tv = n - if( match( c_thv ,name3d(n) ) ) i_thv = n - enddo - -c Create Temperature (if possible) -c -------------------------------- - if( i_t .eq.0 .and. - . ( i_th.ne.0 .or. i_thv.ne.0 .or. i_tv.ne.0) ) then - allocate ( tp(im,jm,mlev), tmpu(im,jm,lm) ) - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - ntp = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'tmpu' - if( i_th.ne.0 .or. ( i_thv.ne.0 .and. i_q.ne.0 ) .or. ( i_tv.ne.0 .and. i_q.ne.0 ) ) then - vtitle( nvars ) = 'Temperature' - else - vtitle( nvars ) = 'Virtual Temperature' - endif - vunits( nvars ) = 'K' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c Create QSAT (if possible) -c ------------------------- - if( i_t .ne.0 .or. ntp.ne.0 ) then - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nqs = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'qsat' - vtitle( nvars ) = 'Saturation Specific Humidity' - vunits( nvars ) = 'g/g' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c Create Relative Humidity (if possible) -c -------------------------------------- - if( nqs.ne.0 .and. i_q.ne.0 ) then - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nrh = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'rh' - vtitle( nvars ) = 'Relative Humidity' - vunits( nvars ) = 'nondim' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - - -c uwnd*uwnd -c --------- - if( quad .and. i_u.ne.0 ) then - allocate ( up(im,jm,mlev), uprime(im,jm,mlev) ) - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nuu = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'uu' - vtitle( nvars ) = 'Quadratic UWND*UWND' - vunits( nvars ) = 'm**2/s**2' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c vwnd*vwnd -c --------- - if( quad .and. i_v.ne.0 ) then - allocate ( vp(im,jm,mlev), vprime(im,jm,mlev) ) - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nvv = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'vv' - vtitle( nvars ) = 'Quadratic VWND*VWND' - vunits( nvars ) = 'm**2/s**2' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c tmpu*tmpu -c --------- - if( quad .and. ( i_t.ne.0 .or. ntp.ne.0) ) then - if( .not. allocated(tp) ) allocate ( tp(im,jm,mlev) ) - allocate ( tprime(im,jm,mlev) ) - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - ntt = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'tt' - vtitle( nvars ) = 'Quadratic TMPU*TMPU' - vunits( nvars ) = 'K**2' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c sphu*sphu -c --------- - if( quad .and. i_q.ne.0 ) then - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nqq = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'qq' - vtitle( nvars ) = 'Quadratic SPHU*SPHU' - vunits( nvars ) = 'nondim' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c uwnd*vwnd -c --------- - if( quad .and. i_u.ne.0 .and. i_v.ne.0 ) then - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nuv = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'uv' - vtitle( nvars ) = 'Quadratic UWND*VWND' - vunits( nvars ) = 'm**2/sec**2' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c uwnd*tmpu -c --------- - if( quad .and. i_u.ne.0 .and. ( i_t.ne.0 .or. ntp.ne.0) ) then - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nut = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'ut' - vtitle( nvars ) = 'Quadratic UWND*TMPU' - vunits( nvars ) = 'K m/sec' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c uwnd*sphu -c --------- - if( quad .and. i_u.ne.0 .and. i_q.ne.0 ) then - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nuq = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'uq' - vtitle( nvars ) = 'Quadratic UWND*SPHU' - vunits( nvars ) = 'm/sec' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c vwnd*tmpu -c --------- - if( quad .and. i_v.ne.0 .and. ( i_t.ne.0 .or. ntp.ne.0 ) ) then - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nvt = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'vt' - vtitle( nvars ) = 'Quadratic VWND*TMPU' - vunits( nvars ) = 'K m/sec' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c vwnd*sphu -c --------- - if( quad .and. i_v.ne.0 .and. i_q.ne.0 ) then - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nvq = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'vq' - vtitle( nvars ) = 'Quadratic VWND*SPHU' - vunits( nvars ) = 'm/sec' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c uprime*vprime -c ------------- - if( quad .and. i_u.ne.0 .and. i_v.ne.0 ) then - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nupvp = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'upvp' - vtitle( nvars ) = 'Quadratic UPRIME*VPRIME (Departure from zonal mean)' - vunits( nvars ) = 'm**2/sec**2' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c vprime*tprime -c ------------- - if( quad .and. i_v.ne.0 .and. ( i_t.ne.0 .or. ntp.ne.0 ) ) then - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nvptp = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'vptp' - vtitle( nvars ) = 'Quadratic VPRIME*TPRIME (Departure from zonal mean)' - vunits( nvars ) = 'K m/sec' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c heights -c ------- - if( i_phis.ne.0 .and. - . ( (i_t .ne.0 .and. i_q.ne.0) .or. - . (i_tv.ne.0 .and. i_q.ne.0) .or. - . (i_th.ne.0 .and. i_q.ne.0) .or. i_thv.ne.0 ) ) then - allocate ( phis(im,jm), hp(im,jm,mlev) ) - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nh = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'hght' - vtitle( nvars ) = 'Heights' - vunits( nvars ) = 'm' - lmvar( nvars ) = mlev - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - - if( i_slp.eq.0 ) then - allocate ( slp(im,jm) ) - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - nslp = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'slp' - vtitle( nvars ) = 'Sea-Level Pressure' - vunits( nvars ) = 'Pa' - lmvar( nvars ) = 0 - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - - endif - -c tpw -c --- - if( i_q.ne.0 ) then - allocate ( tpw(im,jm) ) - allocate ( vname2(nvars), vtitle2(nvars), vunits2(nvars), lmvar2(nvars) ) - vname2 = vname - vtitle2 = vtitle - vunits2 = vunits - lmvar2 = lmvar - nvars = nvars + 1 - ntpw = nvars - deallocate ( vname, vtitle, vunits, lmvar ) - allocate ( vname(nvars), vtitle(nvars), vunits(nvars), lmvar(nvars) ) - vname(1:nvars-1) = vname2 - vtitle(1:nvars-1) = vtitle2 - vunits(1:nvars-1) = vunits2 - lmvar(1:nvars-1) = lmvar2 - vname( nvars ) = 'tpw' - vtitle( nvars ) = 'Total Precipitable Water Vapor' - vunits( nvars ) = 'kg m-2' - lmvar( nvars ) = 0 - deallocate ( vname2, vtitle2, vunits2, lmvar2 ) - endif - -c Compute grid -c ------------ - if( im.eq.im_out .and. jm.eq.jm_out ) then - lat = latin - lon = lonin - else - dlon = 360.0/ im_out - dlat = 180.0/(jm_out-1) - - do j=1,jm_out - lat(j) = -90.0 + (j-1)*dlat - enddo - do i=1,im_out - lon(i) = lonbeg + (i-1)*dlon - enddo - endif - - lons = lon - lats = lat - levs(:) = plev(:)/100 - -c Create GFIO file -c ---------------- - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - vrange(:,:) = undef - prange(:,:) = undef - - if (create) then - if (hdf) then - call GFIO_Create ( trim(filename), title, source, contact, undef, - . im_out, jm_out, mlev, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vname, vtitle, vunits, lmvar, - . vrange, prange, precision, - . id, rc ) - else - open (55,file=trim(filename),form='unformatted',access='sequential') - endif - endif - - call timeend (' Setup*') - -C ********************************************************************** -C **** Compute edge-level pressures **** -C ********************************************************************** - - call timebeg (' Pkappa*') - if( .not.edges) then - if( ps(1,1).ne.0.0 ) then - pe(:,:,1) = ptop - do L=1,lm-1 - pe(:,:,L+1) = pe(:,:,L) + dp(:,:,L) - enddo - pe(:,:,lm+1) = ps(:,:) - - logpe = log(pe) - pke = pe**kappa - -c Compute mid-level pressures to KAPPA -c ------------------------------------ - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) )/( kappa*log(pe(:,:,L+1)/pe(:,:,L)) ) - enddo - endif - endif - call timeend (' Pkappa*') - -c Compute Temperature (if needed) -c ------------------------------- - if( ntp.ne.0 ) then - call timebeg (' TMPU*') - allocate( tv(im,jm,lm) ) - allocate( th(im,jm,lm) ) - allocate( thv(im,jm,lm) ) - allocate( sphu(im,jm,lm) ) - sphu = 0 - do n=1,n3d - if( n.eq.i_q ) sphu = q3d(:,:,:,n) - if( n.eq.i_th ) th = q3d(:,:,:,n) - if( n.eq.i_tv ) tv = q3d(:,:,:,n) - if( n.eq.i_thv ) thv = q3d(:,:,:,n) - enddo - if( i_thv.ne.0 ) then - tmpu = thv*pk/(1+eps*sphu) - else if ( i_th.ne.0 ) then - tmpu = th*pk - else if ( i_tv.ne.0 ) then - tmpu = tv/(1+eps*sphu) - endif - - deallocate( tv,th,thv,sphu ) - call timeend (' TMPU*') - endif - -C ********************************************************************** -C **** Write Defined Fields **** -C ********************************************************************** - - call timebeg (' Logs*') - if( n3d.ne.0 ) then - if( edges ) then - logpl(:,:,:) = log( dp(:,:,: ) ) - logps(:,:) = log( dp(:,:,lm) ) - logpt(:,:) = log( dp(:,:,1 ) ) - else - do L=1,lm - do j=1,jm - do i=1,im - logpl(i,j,L) = log( 0.5*( pe(i,j,L+1)+pe(i,j,L) ) ) - enddo - enddo - enddo - logps(:,:) = log( pe(:,:,lm+1) ) - logpt(:,:) = log( pe(:,:,1) ) - endif - endif - call timeend (' Logs*') - - call timebeg (' Q2D*') - do n=1,n2d - call writit( q2d(1,1,n),im,jm,im_out,jm_out,1,id,name2d(n),nymd,nhms,undef,hdf ) - if( n.eq.i_phis .and. allocated(phis) ) phis = q2d(:,:,n) - enddo - call timeend (' Q2D*') - - call timebeg (' Q3D*') - do n=1,n3d - do L=1,mlev - call sigtopl( qprs(1,1,L),q3d(1,1,1,n),logpl,logps,logpt,log(plev(L)),im,jm,lm,undef,underg,0 ) - enddo - call writit( qprs,im,jm,im_out,jm_out,mlev,id,name3d(n),nymd,nhms,undef,hdf ) - if( n.eq.i_u ) then - if( .not. allocated(up) ) allocate ( up(im,jm,mlev) ) - up = qprs - endif - if( n.eq.i_v ) then - if( .not. allocated(vp) ) allocate ( vp(im,jm,mlev) ) - vp = qprs - endif - if( n.eq.i_t ) then - if( .not. allocated(tp) ) allocate ( tp(im,jm,mlev) ) - tp = qprs - endif - if( n.eq.i_q ) then - if( .not. allocated(qp) ) allocate ( qp(im,jm,mlev) ) - qp = qprs - endif - enddo - call timeend (' Q3D*') - - if( ntp.ne.0 ) then - call timebeg (' TMPU*') - do L=1,mlev - call sigtopl( tp(1,1,L),tmpu(1,1,1),logpl,logps,logpt,log(plev(L)),im,jm,lm,undef,underg,0 ) - enddo - call writit( tp,im,jm,im_out,jm_out,mlev,id,vname(ntp),nymd,nhms,undef,hdf ) - call timeend (' TMPU*') - endif - -C ********************************************************************** -C **** Compute RH and QSAT **** -C ********************************************************************** - - if( nqs.ne.0 ) then - call timebeg (' QSAT*') - do L=1,mlev - do j=1,jm - do i=1,im - if( tp(i,j,L).ne.undef ) then - qstar(i,j,L) = GEOS_Qsat(tp(i,j,L), plev(L)*0.01) - else - qstar(i,j,L) = undef - endif - enddo - enddo - enddo - call writit( qstar,im,jm,im_out,jm_out,mlev,id,vname(nqs),nymd,nhms,undef,hdf ) - - if( nrh.ne.0 ) then - do L=1,mlev - do j=1,jm - do i=1,im - if( qp(i,j,L).ne.undef .and. qstar(i,j,L).ne.undef ) then - rh(i,j,L) = MAX(MIN( qp(i,j,L)/qstar(i,j,L), 1.00 ),0.0) ! note: GEOS uses 1.02 instead of 1.0 - else - rh(i,j,L) = undef - endif - enddo - enddo - enddo - call writit( rh,im,jm,im_out,jm_out,mlev,id,vname(nrh),nymd,nhms,undef,hdf ) - endif - - call timeend (' QSAT*') - endif - -C ********************************************************************** -C **** Compute Heights **** -C ********************************************************************** - - call timebeg (' HGHTs*') - do n=1,n3d - if( n.eq.i_t ) then - allocate( tmpu(im,jm,lm) ) - tmpu = q3d(:,:,:,n) - endif - if( n.eq.i_q ) then - allocate( sphu(im,jm,lm) ) - sphu = q3d(:,:,:,n) - endif - if( n.eq.i_th ) then - allocate( th(im,jm,lm) ) - th = q3d(:,:,:,n) - endif - if( n.eq.i_tv ) then - allocate( tv(im,jm,lm) ) - tv = q3d(:,:,:,n) - endif - if( n.eq.i_thv ) then - allocate( thv(im,jm,lm) ) - thv = q3d(:,:,:,n) - endif - enddo - - if( allocated(hp) ) then - allocate( phi(im,jm,lm+1) ) - phi(:,:,lm+1) = phis(:,:) - if( allocated(thv) ) then - print *, ' Method 1 for Heights: Cp*THV' - do L=lm,1,-1 - phi(:,:,L) = phi(:,:,L+1) + cp*thv(:,:,L)*( pke(:,:,L+1)-pke(:,:,L) ) - enddo - phi(:,:,:) = phi(:,:,:)/grav - do L=1,mlev -c call intgeop ( hp(1,1,L),thv,pke(1,1,2),pk,phis,plev(L),undef,im,jm,lm ) - call sigtopl ( hp(1,1,L),phi,logpe,logps,logpt,log(plev(L)),im,jm,lm+1,undef,underg,1 ) - enddo - else if( allocated(th) .and. allocated(sphu) ) then - print *, ' Method 2 for Heights: Cp*TH*(1+eps*QV)' - allocate( thv(im,jm,lm) ) - thv = th*(1+eps*sphu) - do L=lm,1,-1 - phi(:,:,L) = phi(:,:,L+1) + cp*thv(:,:,L)*( pke(:,:,L+1)-pke(:,:,L) ) - enddo - phi(:,:,:) = phi(:,:,:)/grav - do L=1,mlev -c call intgeop ( hp(1,1,L),thv,pke(1,1,2),pk,phis,plev(L),undef,im,jm,lm ) - call sigtopl ( hp(1,1,L),phi,logpe,logps,logpt,log(plev(L)),im,jm,lm+1,undef,underg,1 ) - enddo - else if( allocated(tmpu) .and. allocated(sphu) ) then - print *, ' Method 3 for Heights: Cp*T*(1+eps*QV)/PK' - allocate( thv(im,jm,lm) ) - thv = tmpu*(1+eps*sphu)/pk - do L=lm,1,-1 - phi(:,:,L) = phi(:,:,L+1) + cp*thv(:,:,L)*( pke(:,:,L+1)-pke(:,:,L) ) - enddo - phi(:,:,:) = phi(:,:,:)/grav - do L=1,mlev -c call intgeop ( hp(1,1,L),thv,pke(1,1,2),pk,phis,plev(L),undef,im,jm,lm ) - call sigtopl ( hp(1,1,L),phi,logpe,logps,logpt,log(plev(L)),im,jm,lm+1,undef,underg,1 ) - enddo - else if( allocated(tv) .and. allocated(sphu) ) then - print *, ' Method 4 for Heights: Cp*Tv*/PK' - allocate( thv(im,jm,lm) ) - thv = tv/pk - do L=lm,1,-1 - phi(:,:,L) = phi(:,:,L+1) + cp*thv(:,:,L)*( pke(:,:,L+1)-pke(:,:,L) ) - enddo - phi(:,:,:) = phi(:,:,:)/grav - do L=1,mlev -c call intgeop ( hp(1,1,L),thv,pke(1,1,2),pk,phis,plev(L),undef,im,jm,lm ) - call sigtopl ( hp(1,1,L),phi,logpe,logps,logpt,log(plev(L)),im,jm,lm+1,undef,underg,1 ) - enddo - endif - deallocate( phi ) - - if( nslp.ne.0 ) then - call get_slp ( ps,phis,slp,pe,pk,thv,rgas,grav,im,jm,lm ) - endif - - endif - call timeend (' HGHTs*') - - -C ********************************************************************** -C **** Write value Added Products **** -C ********************************************************************** - - call timebeg (' QUAD*') - if( quad .and. allocated(up) ) call zprime ( up,uprime,im,jm,mlev,undef ) - if( quad .and. allocated(vp) ) call zprime ( vp,vprime,im,jm,mlev,undef ) - if( quad .and. allocated(tp) ) call zprime ( tp,tprime,im,jm,mlev,undef ) - - if( quad .and. allocated(up) ) - . call writit2( up, up, im,jm,im_out,jm_out,mlev,id,vname(nuu ),nymd,nhms,undef,hdf ) - if( quad .and. allocated(vp) ) - . call writit2( vp, vp, im,jm,im_out,jm_out,mlev,id,vname(nvv ),nymd,nhms,undef,hdf ) - if( quad .and. allocated(tp) ) - . call writit2( tp, tp, im,jm,im_out,jm_out,mlev,id,vname(ntt ),nymd,nhms,undef,hdf ) - if( quad .and. allocated(qp) ) - . call writit2( qp, qp, im,jm,im_out,jm_out,mlev,id,vname(nqq ),nymd,nhms,undef,hdf ) - if( quad .and. allocated(up) .and. - . allocated(vp) ) - . call writit2( up, vp, im,jm,im_out,jm_out,mlev,id,vname(nuv ),nymd,nhms,undef,hdf ) - if( quad .and. allocated(up) .and. - . allocated(tp) ) - . call writit2( up, tp, im,jm,im_out,jm_out,mlev,id,vname(nut ),nymd,nhms,undef,hdf ) - if( quad .and. allocated(up) .and. - . allocated(qp) ) - . call writit2( up, qp, im,jm,im_out,jm_out,mlev,id,vname(nuq ),nymd,nhms,undef,hdf ) - if( quad .and. allocated(vp) .and. - . allocated(tp) ) - . call writit2( vp, tp, im,jm,im_out,jm_out,mlev,id,vname(nvt ),nymd,nhms,undef,hdf ) - if( quad .and. allocated(vp) .and. - . allocated(qp) ) - . call writit2( vp, qp, im,jm,im_out,jm_out,mlev,id,vname(nvq ),nymd,nhms,undef,hdf ) - if( quad .and. allocated(up) .and. - . allocated(vp) ) - . call writit2( uprime,vprime,im,jm,im_out,jm_out,mlev,id,vname(nupvp),nymd,nhms,undef,hdf ) - if( quad .and. allocated(vp) .and. - . allocated(tp) ) - . call writit2( vprime,tprime,im,jm,im_out,jm_out,mlev,id,vname(nvptp),nymd,nhms,undef,hdf ) - - if( allocated(hp) ) call writit ( hp,im,jm,im_out,jm_out,mlev,id,vname(nh) ,nymd,nhms,undef,hdf ) - if( allocated(slp) ) call writit( slp,im,jm,im_out,jm_out,1 ,id,vname(nslp),nymd,nhms,undef,hdf ) - - if( allocated(tpw) ) then - tpw = 0 - do L=1,lm - tpw = tpw + q3d(:,:,L,i_q)*dp(:,:,L) - enddo - tpw = tpw / grav - call writit( tpw,im,jm,im_out,jm_out,1,id,vname(ntpw),nymd,nhms,undef,hdf ) - endif - - call timeend (' QUAD*') - -C ********************************************************************** -C **** De-Allocate Dynamics Arrays **** -C ********************************************************************** - - if( allocated(up) ) deallocate (up) - if( allocated(vp) ) deallocate (vp) - if( allocated(tp) ) deallocate (tp) - if( allocated(hp) ) deallocate (hp) - if( allocated(qp) ) deallocate (qp) - - if( allocated(uprime) ) deallocate (uprime) - if( allocated(vprime) ) deallocate (vprime) - if( allocated(tprime) ) deallocate (tprime) - - if( allocated(phis) ) deallocate (phis ) - if( allocated(tmpu) ) deallocate (tmpu ) - if( allocated(sphu) ) deallocate (sphu ) - if( allocated(th ) ) deallocate (th ) - if( allocated(tv ) ) deallocate (tv ) - if( allocated(thv ) ) deallocate (thv ) - if( allocated(slp ) ) deallocate (slp ) - if( allocated(tpw ) ) deallocate (tpw ) - - deallocate (pk,pe,pke) - deallocate ( qprs ) - deallocate ( qstar ) - deallocate ( rh ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( lmvar ) - deallocate ( vrange ) - deallocate ( prange ) - return - end subroutine eta2prs - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*undef - return - end function defined - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end function nsecf - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end function nhmsf - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - end subroutine tick - - function incymd (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - RETURN - end function incymd - - subroutine sigtopl ( qprs,q,logpl,logps,logpt,logp,im,jm,lm,undef,underg,flag ) -C*********************************************************************** -C -C PURPOSE -C To interpolate an arbitrary quantity from Model Vertical Grid to Pressure -C -C INPUT -C Q ..... Q (im,jm,lm) Arbitrary Quantity on Model Grid -C PKZ ... PKZ (im,jm,lm) Pressure to the Kappa at Model Levels (From Phillips) -C PKSRF . PKSRF(im,jm) Surface Pressure to the Kappa -C PTOP .. Pressure at Model Top -C P ..... Output Pressure Level (mb) -C IM .... Longitude Dimension of Input -C JM .... Latitude Dimension of Input -C LM .... Vertical Dimension of Input -C -C OUTPUT -C QPRS .. QPRS (im,jm) Arbitrary Quantity at Pressure p -C -C NOTE -C Quantity is interpolated Linear in P**Kappa. -C Between PTOP**Kappa and PKZ(1), quantity is extrapolated. -C Between PKSRF**Kappa and PKZ(LM), quantity is extrapolated. -C Undefined Model-Level quantities are not used. -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** -C - use MAPL_ConstantsMod - implicit none - integer i,j,l,im,jm,lm,flag - - real qprs(im,jm) - real q (im,jm,lm) - real logpl(im,jm,lm) - real logps(im,jm) - real logpt(im,jm) - - real undef,kappa - real logp,temp - logical underg - - kappa = MAPL_KAPPA - - call timebeg (' SigToP') -c Initialize to UNDEFINED -c ----------------------- - do j=1,jm - do i=1,im - qprs(i,j) = undef - enddo - enddo - -c Interpolate to Pressure Between Model Levels -c -------------------------------------------- - do L=1,lm-1 - if( all( logpl(:,:,L )>logp ) ) exit - if( all( logpl(:,:,L+1)2 ) then - call usage() - end if - - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - - read(arg(1),'(a)') filename1 - - if( nargs.eq.2 ) then - read(arg(2),'(a)') filename2 - endif - - -! READ first file -! --------------- - call gfio_open ( trim(filename1),0,id1,rc ) - if( rc.ne.0 ) then - print *, 'File: ',trim(filename1),' not found!' - error stop 1 - endif - call gfio_diminquire ( id1,im,jm,lm,ntimes,nvars,ngatts,rc ) - if( rc.ne.0 ) then - print *, 'Failed GFIO_DIMINQUIRE on File: ',trim(filename1) - error stop 1 - endif - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntimes) ) - allocate ( hhmmss(ntimes) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id1,im,jm,lm,ntimes,nvars, & - title,source,contact,undef, & - lon,lat,lev,levunits, & - yymmdd,hhmmss,timinc, & - vname,vtitle,vunits,kmvar, & - vrange,prange,rc ) - if( rc.ne.0 ) then - print *, 'Failed GFIO_INQUIRE on File: ',trim(filename1) - error stop 1 - endif - - if( lev(lm).gt.lev(1) ) then - print *, 'Error!' - print *, 'File: ',trim(filename1) - print *, 'contains Levels ordered top -> bottom (Eta?)' - print *, 'LEVS: ',lev - print * - error stop 1 - endif - - found_ps = .FALSE. - do n=1,nvars - if( match( c_ps,vname(n) ) ) then - PSNAME = vname(n) - found_ps = .TRUE. - endif - enddo - -! READ second file -! ---------------- - if( nargs.eq.2 ) then - call gfio_open ( trim(filename2),2,id2,rc ) - if( rc.ne.0 ) then - print *, 'File: ',trim(filename2),' not found!' - error stop 1 - endif - call gfio_diminquire ( id2,im2,jm2,lm2,ntimes2,nvars2,ngatts2,rc ) - if( rc.ne.0 ) then - print *, 'Failed GFIO_DIMINQUIRE on File: ',trim(filename2) - error stop 1 - endif - if( im2.ne.im .or. jm2.ne.jm ) then - print *, 'File Horizontal Dimensions do not match!' - print *, 'File: ',trim(filename1),' IM: ',im, ' JM: ',jm - print *, 'File: ',trim(filename2),' IM: ',im2,' JM: ',jm2 - error stop 1 - endif - - allocate ( lon2(im2) ) - allocate ( lat2(jm2) ) - allocate ( lev2(lm2) ) - allocate ( yymmdd2(ntimes2) ) - allocate ( hhmmss2(ntimes2) ) - allocate ( vname2(nvars2) ) - allocate ( vtitle2(nvars2) ) - allocate ( vunits2(nvars2) ) - allocate ( kmvar2(nvars2) ) - allocate ( vrange2(2,nvars2) ) - allocate ( prange2(2,nvars2) ) - - call gfio_inquire ( id2,im2,jm2,lm2,ntimes2,nvars2, & - title2,source2,contact2,undef2, & - lon2,lat2,lev2,levunits2, & - yymmdd2,hhmmss2,timinc2, & - vname2,vtitle2,vunits2,kmvar2, & - vrange2,prange2,rc ) - - if( timinc2.ne.timinc ) then - print *, 'File Time Frequencies do not match!' - print *, 'File: ',trim(filename1),' TIMINC: ',timinc - print *, 'File: ',trim(filename2),' TIMINC: ',timinc2 - error stop 1 - endif - - found_ps2 = .FALSE. - do n=1,nvars2 - if( match( c_ps,vname2(n) ) ) then - PSNAME = vname2(n) - found_ps2 = .TRUE. - endif - enddo - endif - -! ************************************************************************* - - if( nargs.eq.1 .and. .not.found_ps ) then - print *, 'Cannot find PS in File: ',trim(filename1) - error stop 1 - endif - if( nargs.eq.2 .and. .not.found_ps .and. .not.found_ps2 ) then - print *, 'Cannot find PS in File: ',trim(filename1),' or ',trim(filename2) - error stop 1 - endif - -! ************************************************************************* - -! Fix UNDEF data -! -------------- - - allocate( ps (im,jm) ) - allocate( ps2(im,jm) ) - allocate( q(im,jm) ) - - allocate( checkps(lm) ) - - print * - do n=1,ntimes - nymd = yymmdd(n) - nhms = hhmmss(n) - write(6,100) trim(filename1),nymd,nhms - 100 format(1x,'Processing: ',a,' for: ',i8.8,2x,i6.6) - - ! Find PS - ! ------- - if( found_ps ) then - call gfio_getvar ( id1,trim(PSNAME),nymd,nhms,im,jm,0, 1,ps,rc ) - if( rc.ne.0 ) then - print *, 'Failed to get PS from ',trim(filename1),' for: ',nymd,nhms - error stop 1 - endif - endif - - if( nargs.eq.2 ) then - if( found_ps2 ) then - call gfio_getvar ( id2,trim(PSNAME),nymd,nhms,im,jm,0, 1,ps2,rc ) - if( rc.ne.0 ) then - print *, 'Failed to get PS from ',trim(filename1),' for: ',nymd,nhms - error stop 1 - endif - if( found_ps ) then - checkps(1) = count( ps.ne.ps2 ) - if( checkps(1).ne.0 ) then - print *, 'PS from ',trim(filename1),' and ',trim(filename2),' do not match!' - error stop 1 - endif - else - ps = ps2 - endif - endif - endif - - ! Loop over 3D-Variables - ! ---------------------- - do L=1,lm - plev = lev(L)*100 - checkps(L) = count( ps.lt.plev ) - enddo - - do k=1,nvars - if( kmvar(k).eq.lm ) then - do L=1,lm - if( checkps(L).ne.0 ) then - call gfio_getvar ( id1,trim(vname(k)),nymd,nhms,im,jm,L,1,q,rc ) - if( rc.ne.0 ) then - print *, 'Failed to get ',trim(vname(k)),' for: ',nymd,nhms,' at Level: ',L - error stop 1 - endif - plev = lev(L)*100 - where( ps.lt.plev ) q = undef - call gfio_putvar ( id1,trim(vname(k)),nymd,nhms,im,jm,L,1,q,rc ) - if( rc.ne.0 ) then - print *, 'Failed to write ',trim(vname(k)),' for: ',nymd,nhms,' at Level: ',L - error stop 1 - endif - endif - enddo - endif - enddo - - enddo - print * - call gfio_close ( id1,rc ) - if( nargs.eq.2 ) call gfio_close ( id2,rc ) - - stop - end - - subroutine usage() - write(6,100) - 100 format( "Usage: " ,/ & - ,/ & - " fix_undef.x PRS_filename [PS_filename]" ,/ & - ,/ & - "where:" ,/ & - ,/ & - " PRS_filename (required) is the name of the PRS file which is to be fixed" ,/ & - " PS_filename (optional) is the name of the file containing PS (if not present in PRS_filename)" ,/ ) - error stop 1 - end subroutine usage - diff --git a/GEOS_Util/post/flat2hdf.F b/GEOS_Util/post/flat2hdf.F deleted file mode 100644 index 05cf4f17..00000000 --- a/GEOS_Util/post/flat2hdf.F +++ /dev/null @@ -1,1055 +0,0 @@ - program main - - implicit none - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to create HDF output from a flat binary file **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm,nt - - integer nymd,nhms - integer nymd0,nhms0 - integer nymdb,nhmsb - integer lrec - data lrec /0/ - - -c Generic Model Variables -c ----------------------- - real, allocatable :: q2d(:,:,:) - real, allocatable :: q3d(:,:,:,:) - - -c HDF and other Local Variables -c ----------------------------- - logical, pointer :: Lsurf (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - real, pointer :: levs(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - - integer rc,fid,nhmsf,n2d,n3d - integer nvars,ntime,gfrc - - character*256, allocatable :: arg(:) - character*256, allocatable :: fname(:) - character*256 tag, endian - character*256 hdfile, ctlfile - - character*8 date0 - character*2 time0 - character*1 char - - integer n,m,nargs,L,nfiles - - real undef - - integer ndt - logical hdfcreate - logical ctl_exists - logical yrev - - logical ecmwf - - interface - subroutine read_ctl ( ctlfile,im,jm,lm,n2d,n3d,undef,lrec, - . nvars,names,Lsurf,name2d,titl2d,name3d,titl3d, - . lats,lons,levs,yrev,endian ) - logical, pointer :: Lsurf (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - character*256 ctlfile - character*256 endian - real, pointer :: lats(:) - real, pointer :: lons(:) - real, pointer :: levs(:) - integer im,jm,lm,n2d,n3d,nvars,lrec - real undef - logical yrev - end subroutine read_ctl - end interface - -C ********************************************************************** -C **** Initialization **** -C ********************************************************************** - - tag = 'xxx' - ctlfile = 'xxx' - nymd0 = -999 - nhms0 = -999 - nt = 1 - ndt = 0 - yrev = .false. - ecmwf = .false. - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1),*) nymd0 - if( trim(arg(n)).eq.'-nhms' ) read(arg(n+1),*) nhms0 - if( trim(arg(n)).eq.'-ndt' ) read(arg(n+1),*) ndt - if( trim(arg(n)).eq.'-ctl' ) ctlfile = arg(n+1) - if( trim(arg(n)).eq.'-tag' ) tag = arg(n+1) - if( trim(arg(n)).eq.'-ecmwf') ecmwf = .true. - - if( trim(arg(n)).eq.'-flat' ) then - nfiles = 1 - read(arg(n+nfiles),fmt='(a1)') char - do while (char.ne.'-' .and. n+nfiles.ne.nargs ) - nfiles = nfiles+1 - read(arg(n+nfiles),fmt='(a1)') char - enddo - if( char.eq.'-' ) nfiles = nfiles-1 - allocate ( fname(nfiles) ) - do m=1,nfiles - fname(m) = arg(n+m) - enddo - endif - enddo - endif - -C ********************************************************************** -C **** Read Grads CLT File **** -C ********************************************************************** - -! Check whether ctl file exists -! ----------------------------- - inquire ( file=trim(ctlfile), exist=ctl_exists ) - - if( ctl_exists ) then - call read_ctl ( ctlfile,im,jm,lm,n2d,n3d,undef,lrec, - . nvars,names,Lsurf,name2d,titl2d,name3d,titl3d, - . lats,lons,levs,yrev,endian ) - - else - print *, 'No CTL file provided!' - stop - endif - -C ********************************************************************** -C **** Summarize Input Variables **** -C ********************************************************************** - - allocate ( q2d(im,jm, n2d) ) - allocate ( q3d(im,jm,lm,n3d) ) - - if( nymd0 == -999 ) nymd0 = nymdb - if( nhms0 == -999 ) nhms0 = nhmsb - - print * - print *, ' im: ',im - print *, ' jm: ',jm - print *, ' lm: ',lm - print *, 'Beginning Date: ',nymd0 - print *, 'Beginning Time: ',nhms0 - print *, 'Time Increment: ',nhmsf(ndt),' (',ndt,' seconds)' - print *, ' yrev: ',yrev - print * - print *, 'Levels: ',(levs(L),L=1,lm) - print * - print *, '2-D Fields:' - do n=1,n2d - print *, trim(name2d(n)),' ',trim(titl2d(n)) - enddo - print * - print *, '3-D Fields:' - do n=1,n3d - print *, trim(name3d(n)),' ',trim(titl3d(n)) - enddo - print * - - print *, 'Files: ' - do n=1,nfiles - print *, n,trim(fname(n)) - enddo - print * - -C ********************************************************************** -C **** Read and Interpolate Eta File **** -C ********************************************************************** - - nymd = nymd0 - nhms = nhms0 - - do n=1,nfiles - write(date0,1000) nymd - write(time0,2000) nhms/10000 - 1000 format(i8.8) - 2000 format(i2.2) - - if( trim(tag).eq.'xxx' ) then - hdfile = trim(fname(n)) // ".nc4" - else - hdfile = trim(tag) // ".nc4" - endif - - close(10) - if( lrec.eq.-1 ) then - print *, 'Opening ',trim(fname(n)),' access = sequential, endian: ',trim(endian) - if( trim(endian).eq.'big_endian' ) then - open (10,file=trim(fname(n)),form='unformatted',access='sequential',convert='big_endian') - else - open (10,file=trim(fname(n)),form='unformatted',access='sequential') - endif - else - print *, 'Opening ',trim(fname(n)),' access = direct, endian: ',trim(endian) - if( trim(endian).eq.'big_endian' ) then - open (10,file=trim(fname(n)),form='unformatted',access='direct',recl=im*jm*4,convert='big_endian') - else - open (10,file=trim(fname(n)),form='unformatted',access='direct',recl=im*jm*4) - endif - endif - - rc = 0 - ntime = 0 - hdfcreate = .true. - print * - dowhile (rc.eq.0) - ntime = ntime + 1 - print *, 'nymd: ',nymd,' nhms: ',nhms - - call read_flat_data ( 10,q2d,q3d,nvars,Lsurf,im,jm,lm, - . lrec,rc ) - - if( rc.eq.0 ) then - call flat2hdf ( q2d,q3d,name2d,name3d,titl2d,titl3d,n2d,n3d,undef, - . im,jm,lm,lats,lons,levs,nymd,nhms,ndt, - . fid,hdfcreate,hdfile,yrev,ecmwf ) - call tick (nymd,nhms,ndt) - hdfcreate = .false. - else - call gfio_close ( fid,gfrc ) - lrec = 0 - print * - print *, 'Created: ',trim(hdfile) - print * - endif - enddo - enddo - - deallocate ( arg ) - - stop - end - - subroutine read_flat_data ( ku,q2d,q3d,nvars, - . Lsurf,im,jm,lm,lrec,rc ) - implicit none - - integer im,jm,lm,ku,lrec,rc - integer nvars - real q2d(im,jm ,1) - real q3d(im,jm,lm,1) - real dummy - logical Lsurf(nvars) - - integer k,m,n - -c Test for End of File -c -------------------- - rc = 0 - if( lrec.eq.-1 ) then - print *, 'Testing for EOF on sequential file ...' - read(ku,err=999,end=999) - backspace(ku) - else - print *, 'Testing for EOF on direct access file, lrec = ',lrec+1 -c read(ku,err=999,rec=lrec+1) - read(ku,err=999,rec=lrec+1) dummy - endif - goto 1000 - 999 continue - print *, 'End of File reached' - rc = -1 - return - - 1000 continue - -C ********************************************************************** -C **** Read Diagnostic Data **** -C ********************************************************************** - - m = 0 - n = 0 - do k=1,nvars - if( Lsurf(k) ) then - m = m+1 - call readit (q2d(1,1,m),im,jm,1,ku,lrec) - else - n = n+1 - call readit (q3d(1,1,1,n),im,jm,lm,ku,lrec) - endif - enddo - - return - end subroutine read_flat_data - - subroutine readit (q,im,jm,lm,ku,lrec) - implicit none - integer im,jm,lm,ku,L,lrec - real q(im,jm,lm) - real*4 dum(im,jm) - do L=1,lm - if( lrec.eq.-1 ) then - read(ku) dum - else - read(ku,rec=lrec+1) dum - lrec=lrec+1 - endif - q(:,:,L) = dum(:,:) - enddo - return - end subroutine readit - - subroutine flat2hdf ( q2d,q3d,name2d,name3d,titl2d,titl3d,n2d,n3d,undef, - . im,jm,lm,lats,lons,levs,nymd,nhms,ninc, - . id,create,filename,yrev,ecmwf ) - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,nymd,nhms,ninc,n2d,n3d - logical ecmwf - - real q2d(im,jm, n2d) - real q3d(im,jm,lm,n3d) - - character*256 name2d(n2d), titl2d(n2d) - character*256 name3d(n3d), titl3d(n3d) - character*256 filename - - logical create - logical yrev - -c Local Variables -c --------------- - integer n,m,n3dEC - - real lats(jm),lons(im),levs(lm) - real undef, dum - integer precision,id,timeinc,rc,nhmsf - integer i,j,L - - character*256 levunits - character*256 title - character*256 source - character*256 contact - - integer nvars,idx - - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - integer, allocatable :: lmvar(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - real, allocatable :: tmpu(:,:,:) - real, allocatable :: sphu(:,:,:) - real, allocatable :: rh(:,:,:) - -C ********************************************************************** -C **** Initialize Constants And Local Arrays **** -C ********************************************************************** - - if( ecmwf ) then ! add SPHU for ECMWF (Note: UNDEF above 100-mb) - n3dEC = 1 - else - n3dEC = 0 - endif - - nvars = n2d + n3d + n3dEC - -C ********************************************************************** -C **** Initialize GFIO File **** -C ********************************************************************** - - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - allocate ( tmpu(im,jm,lm) ) - allocate ( sphu(im,jm,lm) ) - allocate ( rh(im,jm,lm) ) - - timeinc = nhmsf(ninc) - precision = 1 ! 64-bit - precision = 0 ! 32-bit - - title = 'Flat to HDF Format Conversion' - source = 'Goddard Modeling and Assimilation Office, NASA/GSFC' - contact = 'data@gmao.gsfc.nasa.gov' - levunits = 'level' - -c Defined Fields -c -------------- - do m=1,n2d - n = m - idx=index(name2d(m),'=') - if(idx>0) then - vname(n) = name2d(m)(1:idx-1) - name2d(m) = trim(vname(n)) - else - vname(n) = name2d(m) - endif - vtitle(n) = trim(titl2d(m)) - vunits(n) = 'unknown' - lmvar(n) = 0 - enddo - - do m=1,n3d - n = n2d+m - idx=index(name3d(m),'=') - if(idx>0) then - vname(n) = name3d(m)(1:idx-1) - name3d(m) = trim(vname(n)) - else - vname(n) = name3d(m) - endif - vtitle(n) = trim(titl3d(m)) - vunits(n) = 'unknown' - lmvar(n) = lm - enddo - - if( ecmwf ) then - n = n2d+n3d+n3dEC - vname(n) = 'sphu' - vtitle(n) = 'Specific_Humidity_from_RH_x_QSAT' - vunits(n) = 'kg/kg' - lmvar(n) = lm - endif - -C ********************************************************************** -C **** Value Added Products **** -C ********************************************************************** - -c Create GFIO file -c ---------------- - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - vrange(:,:) = undef - prange(:,:) = undef - - if (create) then - call GFIO_Create ( trim(filename), title, source, contact, undef, - . im, jm, lm, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vname, vtitle, vunits, lmvar, - . vrange, prange, precision, - . id, rc ) - endif - -C ********************************************************************** -C **** Write Defined Fields **** -C ********************************************************************** - - do n=1,n2d - call writit( q2d(1,1,n) ,im,jm,0,1,id,name2d(n),nymd,nhms,yrev ) - enddo - - do n=1,n3d - call writit( q3d(1,1,1,n),im,jm,1,lm,id,name3d(n),nymd,nhms,yrev ) - if( name3d(n).eq.'Temperature' ) tmpu = q3d(:,:,:,n) - if( name3d(n).eq.'Relative_humidity' ) rh = q3d(:,:,:,n) - enddo - - if( ecmwf ) then - do L=1,lm - do j=1,jm - do i=1,im - if( levs(L).ge.100.0 ) then - call qsat (tmpu(i,j,L),levs(L),sphu(i,j,L),dum,.false.) - sphu(i,j,L) = rh(i,j,L)*sphu(i,j,L)*0.01 - else - sphu(i,j,L) = undef - endif - enddo - enddo - enddo - call writit( sphu,im,jm,1,lm,id,vname(nvars),nymd,nhms,yrev ) - endif - -C ********************************************************************** -C **** De-Allocate Dynamics Arrays **** -C ********************************************************************** - - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( lmvar ) - deallocate ( vrange ) - deallocate ( prange ) - deallocate ( tmpu ) - deallocate ( sphu ) - deallocate ( rh ) - return - end subroutine flat2hdf - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end function nsecf - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end function nhmsf - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - end subroutine tick - - function incymd (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - RETURN - end function incymd - - subroutine read_ctl ( ctlfile,im,jm,lm,n2d,n3d,undef,lrec, - . nvars,names,Lsurf,name2d,titl2d,name3d,titl3d, - . lats,lons,levs,yrev,endian ) - implicit none - - logical, pointer :: Lsurf (:) - character*256, pointer :: names (:) - character*256, pointer :: name2d(:), name3d(:) - character*256, pointer :: titl2d(:), titl3d(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - real, pointer :: levs(:) - - character*256 ctlfile - integer im,jm,lm,n2d,n3d,nvars,lrec - real undef,dx,dy,dz - integer i,j,L,n,ndum - character*256 dummy,name,endian,dimstring - character*256, allocatable :: dum(:) - logical yrev - - endian = 'NULL' - -C ********************************************************************** -C **** Read Grads CLT File for Meta Data **** -C ********************************************************************** - - open (10,file=trim(ctlfile),form='formatted') - n2d = 0 - n3d = 0 - do - read(10,*,end=500) dummy - -c OPTIONS -c ------- - if( trim(dummy).eq.'options' ) then - ndum = 1 - do - backspace(10) - allocate ( dum(ndum) ) - read(10,*,err=101) dummy - if( trim(dummy).eq.'options' ) then - backspace(10) - read(10,*,end=101) dummy,( dum(n),n=1,ndum ) - else - goto 101 - endif - if( trim(dum(ndum)).eq.'sequential' ) lrec = -1 - if( trim(dum(ndum)).eq.'yrev' ) yrev = .true. - if( trim(dum(ndum)).eq.'big_endian' ) endian = 'big_endian' - if( trim(dum(ndum)).eq.'little_endian' ) endian = 'little_endian' - deallocate ( dum ) - ndum = ndum + 1 - enddo - 100 format(a5) - 101 continue - deallocate ( dum ) - endif - -c XDEF -c ---- - if( trim(dummy).eq.'xdef' ) then - backspace(10) - read(10,*) dummy,im - allocate( lons(im) ) - backspace(10) - read(10,*) dummy,im,dummy,lons(1),dx - if( trim(dummy).eq.'linear' ) then - do i=2,im - lons(i) = lons(i-1) + dx - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lons(i),i=1,im) - endif - endif - -c YDEF -c ---- - if( trim(dummy).eq.'ydef' ) then - backspace(10) - read(10,*) dummy,jm - allocate( lats(jm) ) - backspace(10) - read(10,*) dummy,jm,dummy,lats(1),dy - if( trim(dummy).eq.'linear' ) then - do j=2,jm - lats(j) = lats(j-1) + dy - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lats(j),j=1,jm) - endif - endif - -c ZDEF -c ---- - if( trim(dummy).eq.'zdef' ) then - backspace(10) - read(10,*) dummy,lm - allocate( levs(lm) ) - backspace(10) - if( lm.eq.1 ) then - read(10,*) dummy,lm,dummy,levs(1) - else - read(10,*) dummy,lm,dummy,levs(1),dz - endif - if( trim(dummy).eq.'linear' ) then - do L=2,lm - levs(L) = levs(L-1) + dz - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(levs(L),L=1,lm) - endif - endif - -c UNDEF -c ----- - if( trim(dummy).eq.'undef' ) then - backspace(10) - read(10,*) dummy,undef - endif - - if( trim(dummy).eq.'vars' ) then - backspace(10) - read(10,*) dummy,nvars - allocate( names(nvars) ) - do n=1,nvars - read(10,*) names(n),L - if( L.eq.0 ) then - n2d = n2d + 1 - else - n3d = n3d + 1 - endif - enddo - endif - enddo - 500 continue - rewind(10) - - if( n2d.eq.0 .and. n3d.eq.0 ) then - print *, 'Warning, n2d = n3d = 0!' - stop - endif - - allocate( Lsurf(nvars) ) - allocate( name2d(n2d) ) - allocate( titl2d(n2d) ) - allocate( name3d(n3d) ) - allocate( titl3d(n3d) ) - - n2d = 0 - n3d = 0 - do - read(10,*,end=501) dummy - if( trim(dummy).eq.'vars' ) then - backspace(10) - read(10,*) dummy,nvars - do n=1,nvars - read(10,*) name,L - backspace(10) - if( L.eq.0 ) then - Lsurf(n) = .true. - n2d = n2d + 1 - read(10,*) name2d(n2d),L,dimstring,titl2d(n2d) - else - Lsurf(n) = .false. - n3d = n3d + 1 - read(10,*) name3d(n3d),L,dimstring,titl3d(n3d) - endif - enddo - endif - enddo - 501 continue - - return - end subroutine read_ctl - - subroutine writit (q,im,jm,lbeg,lm,id,name,nymd,nhms,yrev) - integer im,jm,lm,L - integer id,nymd,nhms,rc,lbeg - character*256 name - logical yrev - real q (im,jm,lm),qdum(jm) - - if( yrev ) then - do L=1,lm - do i=1,im - do j=1,jm - qdum(jm-j+1) = q(i,j,L) - enddo - do j=1,jm - q(i,j,L) = qdum(j) - enddo - enddo - enddo - endif - call Gfio_putVar ( id,trim(name),nymd,nhms,im,jm,lbeg,lm,q,rc ) - print *, ' Writing variable: ',trim(name) - return - end subroutine writit - - subroutine usage() - print *, "Usage: " - print * - print *, " flat2hdf_$ARCH.x -flat fname(s)" - print *, " -ctl ctl_fname" - print *, " -nymd nymd" - print *, " -nhms nhms" - print *, " -ndt ndt" - print * - print *, "where:" - print * - print *, " -flat fname(s): Filename(s) in flat real*4 binary format" - print *, " -ctl ctl_fname: CTL Filename for flat binary files" - print *, " -nymd nymd: Beginning YYYYMMDD" - print *, " -nhms nhms: Beginning HHMMSS" - print *, " -ndt ndt: Time Increment (secs)" - print * - print *, "Note:" - print *, " ALL Grads Keywords MUST BE lowercase (eg: xdef, options, sequential, etc.)" - print * - print * - error stop 7 - end subroutine usage - - subroutine qsat (tt,p,q,dqdt,ldqdt) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute Saturation Specific Humidity -C -C INPUT: -C ====== -C TT ......... Temperature (Kelvin) -C P .......... Pressure (mb) -C LDQDT ...... Logical Flag to compute QSAT Derivative -C -C OUTPUT: -C ======= -C Q .......... Saturation Specific Humidity -C DQDT ....... Saturation Specific Humidity Derivative wrt Temperature -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IMPLICIT NONE - REAL TT, P, Q, DQDT - LOGICAL LDQDT - REAL AIRMW, H2OMW - - PARAMETER ( AIRMW = 28.97 ) - PARAMETER ( H2OMW = 18.01 ) - - REAL ESFAC, ERFAC - PARAMETER ( ESFAC = H2OMW/AIRMW ) - PARAMETER ( ERFAC = (1.0-ESFAC)/ESFAC ) - - real aw0, aw1, aw2, aw3, aw4, aw5, aw6 - real bw0, bw1, bw2, bw3, bw4, bw5, bw6 - real ai0, ai1, ai2, ai3, ai4, ai5, ai6 - real bi0, bi1, bi2, bi3, bi4, bi5, bi6 - - real d0, d1, d2, d3, d4, d5, d6 - real e0, e1, e2, e3, e4, e5, e6 - real f0, f1, f2, f3, f4, f5, f6 - real g0, g1, g2, g3, g4, g5, g6 - -c ******************************************************** -c *** Polynomial Coefficients WRT Water (Lowe, 1977) **** -c *** (Valid +50 C to -50 C) **** -c ******************************************************** - - parameter ( aw0 = 6.107799961e+00 * esfac ) - parameter ( aw1 = 4.436518521e-01 * esfac ) - parameter ( aw2 = 1.428945805e-02 * esfac ) - parameter ( aw3 = 2.650648471e-04 * esfac ) - parameter ( aw4 = 3.031240396e-06 * esfac ) - parameter ( aw5 = 2.034080948e-08 * esfac ) - parameter ( aw6 = 6.136820929e-11 * esfac ) - - parameter ( bw0 = +4.438099984e-01 * esfac ) - parameter ( bw1 = +2.857002636e-02 * esfac ) - parameter ( bw2 = +7.938054040e-04 * esfac ) - parameter ( bw3 = +1.215215065e-05 * esfac ) - parameter ( bw4 = +1.036561403e-07 * esfac ) - parameter ( bw5 = +3.532421810e-10 * esfac ) - parameter ( bw6 = -7.090244804e-13 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice (Lowe, 1977) **** -c *** (Valid +0 C to -50 C) **** -c ******************************************************** - - parameter ( ai0 = +6.109177956e+00 * esfac ) - parameter ( ai1 = +5.034698970e-01 * esfac ) - parameter ( ai2 = +1.886013408e-02 * esfac ) - parameter ( ai3 = +4.176223716e-04 * esfac ) - parameter ( ai4 = +5.824720280e-06 * esfac ) - parameter ( ai5 = +4.838803174e-08 * esfac ) - parameter ( ai6 = +1.838826904e-10 * esfac ) - - parameter ( bi0 = +5.030305237e-01 * esfac ) - parameter ( bi1 = +3.773255020e-02 * esfac ) - parameter ( bi2 = +1.267995369e-03 * esfac ) - parameter ( bi3 = +2.477563108e-05 * esfac ) - parameter ( bi4 = +3.005693132e-07 * esfac ) - parameter ( bi5 = +2.158542548e-09 * esfac ) - parameter ( bi6 = +7.131097725e-12 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -40 C to -70 C) **** -c ******************************************************** - - - parameter ( d0 = 0.535098336e+01 * esfac ) - parameter ( d1 = 0.401390832e+00 * esfac ) - parameter ( d2 = 0.129690326e-01 * esfac ) - parameter ( d3 = 0.230325039e-03 * esfac ) - parameter ( d4 = 0.236279781e-05 * esfac ) - parameter ( d5 = 0.132243858e-07 * esfac ) - parameter ( d6 = 0.314296723e-10 * esfac ) - - parameter ( e0 = 0.469290530e+00 * esfac ) - parameter ( e1 = 0.333092511e-01 * esfac ) - parameter ( e2 = 0.102164528e-02 * esfac ) - parameter ( e3 = 0.172979242e-04 * esfac ) - parameter ( e4 = 0.170017544e-06 * esfac ) - parameter ( e5 = 0.916466531e-09 * esfac ) - parameter ( e6 = 0.210844486e-11 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -65 C to -95 C) **** -c ******************************************************** - - parameter ( f0 = 0.298152339e+01 * esfac ) - parameter ( f1 = 0.191372282e+00 * esfac ) - parameter ( f2 = 0.517609116e-02 * esfac ) - parameter ( f3 = 0.754129933e-04 * esfac ) - parameter ( f4 = 0.623439266e-06 * esfac ) - parameter ( f5 = 0.276961083e-08 * esfac ) - parameter ( f6 = 0.516000335e-11 * esfac ) - - parameter ( g0 = 0.312654072e+00 * esfac ) - parameter ( g1 = 0.195789002e-01 * esfac ) - parameter ( g2 = 0.517837908e-03 * esfac ) - parameter ( g3 = 0.739410547e-05 * esfac ) - parameter ( g4 = 0.600331350e-07 * esfac ) - parameter ( g5 = 0.262430726e-09 * esfac ) - parameter ( g6 = 0.481960676e-12 * esfac ) - - REAL TMAX, TICE - PARAMETER ( TMAX=323.15, TICE=273.16) - - REAL T, D, W, QX, DQX - T = MIN(TT,TMAX) - TICE - DQX = 0. - QX = 0. - -c Fitting for temperatures above 0 degrees centigrade -c --------------------------------------------------- - if(t.gt.0.) then - qx = aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6))))) - if (ldqdt) then - dqx = bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6))))) - endif - endif - -c Fitting for temperatures between 0 and -40 -c ------------------------------------------ - if( t.le.0. .and. t.gt.-40.0 ) then - w = (40.0 + t)/40.0 - qx = w *(aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6)))))) - . + (1.-w)*(ai0+T*(ai1+T*(ai2+T*(ai3+T*(ai4+T*(ai5+T*ai6)))))) - if (ldqdt) then - dqx = w *(bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6)))))) - . + (1.-w)*(bi0+T*(bi1+T*(bi2+T*(bi3+T*(bi4+T*(bi5+T*bi6)))))) - endif - endif - -c Fitting for temperatures between -40 and -70 -c -------------------------------------------- - if( t.le.-40.0 .and. t.ge.-70.0 ) then - qx = d0+T*(d1+T*(d2+T*(d3+T*(d4+T*(d5+T*d6))))) - if (ldqdt) then - dqx = e0+T*(e1+T*(e2+T*(e3+T*(e4+T*(e5+T*e6))))) - endif - endif - -c Fitting for temperatures less than -70 -c -------------------------------------- - if(t.lt.-70.0) then - qx = f0+t*(f1+t*(f2+t*(f3+t*(f4+t*(f5+t*f6))))) - if (ldqdt) then - dqx = g0+t*(g1+t*(g2+t*(g3+t*(g4+t*(g5+t*g6))))) - endif - endif - -c Compute Saturation Specific Humidity -c ------------------------------------ - D = (P-ERFAC*QX) - IF(D.LT.0.) THEN - Q = 1.0 - IF (LDQDT) DQDT = 0. - ELSE - D = 1.0 / D - Q = MIN(QX * D,1.0) - IF (LDQDT) DQDT = (1.0 + ERFAC*Q) * D * DQX - ENDIF - RETURN - END diff --git a/GEOS_Util/post/fvrst.F b/GEOS_Util/post/fvrst.F deleted file mode 100644 index 1e6d72a1..00000000 --- a/GEOS_Util/post/fvrst.F +++ /dev/null @@ -1,285 +0,0 @@ - program main - - use MAPL - - implicit none - - integer headr1(6) - integer headr2(5) - integer im,jm,lm,L - integer nymd,nhms - - real*8, allocatable :: ak(:) - real*8, allocatable :: bk(:) - real*8, allocatable :: dum(:,:) - real*4, allocatable :: u(:,:,:) - real*4, allocatable :: v(:,:,:) - real*4, allocatable :: th(:,:,:) - real*4, allocatable :: ple(:,:,:) - real*4, allocatable :: pk(:,:,:) - real*4, allocatable :: ak4(:) - real*4, allocatable :: bk4(:) - - character*512 dynrst - character*512, allocatable :: arg(:) - integer nargs,n - logical HEADER - integer :: filetype,rc - type(Netcdf4_fileformatter) :: fmt - type(FileMetadata) :: cfg - - HEADER = .false. - - nargs = command_argument_count() - if( nargs.eq.0 ) stop - - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-h' ) HEADER = .true. - if( trim(arg(n)).ne.'-h' ) dynrst = trim(arg(n)) - enddo - -! ********************************************************************** -! **** Read dycore internal Restart for RSLV, Date and Time **** -! ********************************************************************** - - call MAPL_NCIOGetFileType(dynrst,filetype) - if (filetype ==0) then - if (header) then - call fmt%open(dynrst,pFIO_READ,rc=rc) - cfg = fmt%read(rc=rc) - im = cfg%get_dimension('lon',rc=rc) - jm = cfg%get_dimension('lat',rc=rc) - lm = cfg%get_dimension('lev',rc=rc) - call MAPL_IOGetTime(cfg,nymd,nhms) - - print *, im,jm,lm,nymd,nhms - stop - else - write(*,*)"fvrst can not make gfio file from nc4 restart yet" - stop - end if - end if - - open (10,file=trim(dynrst),form='unformatted',access='sequential') - read (10) headr1 - read (10) headr2 - - im = headr2(1) - jm = headr2(2) - lm = headr2(3) - - nymd = headr1(1)*10000 - . + headr1(2)*100 - . + headr1(3) - nhms = headr1(4)*10000 - . + headr1(5)*100 - . + headr1(6) - - if( HEADER ) then - print *, im,jm,lm,nymd,nhms - stop - endif - - allocate ( ak(lm+1) ) - allocate ( bk(lm+1) ) - allocate ( ak4(lm+1) ) - allocate ( bk4(lm+1) ) - allocate ( dum(im,jm) ) - allocate ( u(im,jm,lm) ) - allocate ( v(im,jm,lm) ) - allocate ( th(im,jm,lm) ) - allocate ( pk(im,jm,lm) ) - allocate ( ple(im,jm,lm+1) ) - -! ********************************************************************** -! **** Read dycore internal Restart **** -! ********************************************************************** - - read (10) ak ; ak4 = ak - read (10) bk ; bk4 = bk - - do L=1,lm - read(10) dum ; u(:,:,L) = dum - enddo - do L=1,lm - read(10) dum ; v(:,:,L) = dum - enddo - do L=1,lm - read(10) dum ; th(:,:,L) = dum - enddo - do L=1,lm+1 - read(10) dum ; ple(:,:,L) = dum - enddo - do L=1,lm - read(10) dum ; pk(:,:,L) = dum - enddo - close (10) - - call writit ( u,v,th,ple,pk,ak4,bk4,im,jm,lm,nymd,nhms,dynrst ) - stop - end - - subroutine writit ( u,v,th,ple,pk,ak,bk,im,jm,lm,nymd,nhms,dynrsti ) - implicit none - integer im,jm,lm,nymd,nhms - real*4 u(im,jm,lm) - real*4 v(im,jm,lm) - real*4 th(im,jm,lm) - real*4 pk(im,jm,lm) - real*4 ple(im,jm,lm+1) - real*4 ak(lm+1) - real*4 bk(lm+1) - - real lats(jm) - real lons(im) - real levs(lm) - real*8 latsd(jm) - real*8 lonsd(im) - - real ptop,dlon,dlat,undef,pint - integer i,j,L,timeinc,rc,ks - character*512 dynrsti,dynrsto - integer nvars,fid,precision - - character*256 levunits - character*256 title - character*256 source - character*256 contact - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - integer, allocatable :: lmvar(:) - real, allocatable :: v_range(:,:) - real, allocatable :: p_range(:,:) - - real, allocatable :: dum1(:) - real, allocatable :: dum2(:,:) - real, allocatable :: dum3(:,:,:) - - real dpref - dpref(L) = ( ak(L+1)-ak(L) ) + ( bk(L+1)-bk(L) ) * 98400.0 - - undef = 1.0e15 - timeinc = 060000 - - precision = 1 ! 64-bit - precision = 0 ! 32-bit - -! String and vars settings -! ------------------------ - dynrsto = trim(dynrsti) // ".nc4" - title = 'GEOS5 Dynamics State Vector (Hybrid Coordinates)' - source = 'Goddard Modeling and Assimilation Office, NASA/GSFC' - contact = 'data@gmao.gsfc.nasa.gov' - levunits = 'hPa' - - nvars = 06 - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - allocate ( v_range(2,nvars) ) - allocate ( p_range(2,nvars) ) - - vname(01) = 'u' - vtitle(01) = 'Zonal Wind' - vunits(01) = 'm/s' - lmvar(01) = lm - - vname(02) = 'v' - vtitle(02) = 'Meridional Wind' - vunits(02) = 'm/s' - lmvar(02) = lm - - vname(03) = 'th' - vtitle(03) = 'Scaled Potential Temperature' - vunits(03) = 'K/Pa^kappa' - lmvar(03) = lm - - vname(04) = 'ple' - vtitle(04) = 'Edge Pressures' - vunits(04) = 'Pa' - lmvar(04) = lm - - vname(05) = 'ps' - vtitle(05) = 'Surface Pressure' - vunits(05) = 'Pa' - lmvar(05) = 0 - - vname(06) = 'pk' - vtitle(06) = 'P**kappa' - vunits(06) = 'Pa^kappa' - lmvar(06) = lm - - v_range(:,:) = undef - p_range(:,:) = undef - -! Compute grid -! ------------ - if( jm.eq.6*im ) then - do j=1,jm - latsd(j) = j - enddo - do i=1,im - lonsd(i) = i - enddo - else - dlon = 360.0/ im - dlat = 180.0/(jm-1) - do j=1,jm - latsd(j) = -90.0 + (j-1)*dlat - enddo - do i=1,im - lonsd(i) = -180.0 + (i-1)*dlon - enddo - endif - - lats = latsd - lons = lonsd - do L=1,lm - levs(L) = L - enddo - - ptop = ak(1) - levs(1) = ptop + 0.5 * dpref(1) - do L = 2, lm - levs(L) = levs(L-1) + 0.5 * ( dpref(L-1) + dpref(L) ) - enddo - levs(1:lm) = levs(1:lm) / 100.0 - -! Create GFIO file -! ---------------- - call GFIO_Create ( dynrsto, title, source, contact, undef, - . im, jm, lm, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vname, vtitle, vunits, lmvar, - . v_range, p_range, precision, - . fid, rc ) -! Write GFIO data -! --------------- - allocate( dum1(lm+1) ) - allocate( dum2(im,jm) ) - allocate( dum3(im,jm,lm) ) - - dum3 = u ; call Gfio_putVar ( fid,vname(01),nymd,nhms,im,jm,1,lm,dum3,rc ) - dum3 = v ; call Gfio_putVar ( fid,vname(02),nymd,nhms,im,jm,1,lm,dum3,rc ) - dum3 = th ; call Gfio_putVar ( fid,vname(03),nymd,nhms,im,jm,1,lm,dum3,rc ) - dum3 = ple(:,:,1:lm) ; call Gfio_putVar ( fid,vname(04),nymd,nhms,im,jm,1,lm,dum3,rc ) - dum2 = ple(:,:,lm+1) ; call Gfio_putVar ( fid,vname(05),nymd,nhms,im,jm,0,1 ,dum2,rc ) - dum3 = pk ; call Gfio_putVar ( fid,vname(06),nymd,nhms,im,jm,1,lm,dum3,rc ) - -! Write GFIO global attributes -! ---------------------------- - ks = 0 - pint = ak(ks+1) - dum1 = ak ; call GFIO_PutRealAtt ( fid,'ak', lm+1,dum1 ,precision,rc ) - dum1 = bk ; call GFIO_PutRealAtt ( fid,'bk', lm+1,dum1 ,precision,rc ) - - - call gfio_close ( fid,rc ) - return - end diff --git a/GEOS_Util/post/gg2eta.F b/GEOS_Util/post/gg2eta.F deleted file mode 100644 index 1b7bf7a2..00000000 --- a/GEOS_Util/post/gg2eta.F +++ /dev/null @@ -1,901 +0,0 @@ - program main - implicit none - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to create ETA.ANA file from NCEP sigma files **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm - integer :: lm = 72 - integer :: nq = 3 ! 1:qv, 2:oz, 3:ql - -c Set analysis, fvdas, date and time -c ---------------------------------- - character*2 cnhms - character*8 cnymd - - character*256 ana_data, tag, ext - - integer nymd,nhms - -c fv restart variables and topography -c ----------------------------------- - real, allocatable :: dp(:,:,:) - real, allocatable :: u(:,:,:) - real, allocatable :: v(:,:,:) - real, allocatable :: thv(:,:,:) - real, allocatable :: q(:,:,:,:) - real, allocatable :: phis(:,:) - real, allocatable :: ps(:,:) - - integer :: timinc = 21600 - -c Analysis variables -c ------------------ - real, allocatable :: phis_ana(:,:) - real, allocatable :: ps_ana(:,:) - real, allocatable :: u_ana(:,:,:) - real, allocatable :: v_ana(:,:,:) - real, allocatable :: q_ana(:,:,:,:) - real, allocatable :: dp_ana(:,:,:) - real, allocatable :: t_ana(:,:,:) - integer mlev - - character*120, allocatable :: arg(:) - - integer precision - integer n,nargs - -c NCEP Grads CTL File Variables -c ----------------------------- - character*256 ctlfile,format - integer imncep,jmncep,lmncep,nvncep - real uncep - - character*256, pointer :: names (:) - character*256, pointer :: descs (:) - integer, pointer :: lmvars(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - - interface - subroutine read_ctl ( ctlfile,imncep,jmncep,lmncep,uncep,format, - . nvncep,names,descs,lmvars, - . lats,lons,nymd,nhms ) - character*256 ctlfile, format - character*256, pointer :: names (:) - character*256, pointer :: descs (:) - integer, pointer :: lmvars(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - integer imncep,jmncep,lmncep,nvncep - integer nymd,nhms - real uncep - end subroutine read_ctl - end interface - -C ********************************************************************** -C **** Initialize Filenames, Methods, etc. **** -C ********************************************************************** - - precision = 0 ! 32-bit - ext = 'nc4' - tag = '' - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-ncep' ) ana_data = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ctl' ) ctlfile = trim(arg(n+1)) - if( trim(arg(n)).eq.'-tag' ) tag = trim(arg(n+1)) - enddo - endif - - if( trim(tag).ne.'' ) tag = trim(tag) // '.' - -C ********************************************************************** -C **** Read NCEP Grads CTL File **** -C ********************************************************************** - - call read_ctl ( ctlfile,imncep,jmncep,lmncep,uncep,format, - . nvncep,names,descs,lmvars, - . lats,lons,nymd,nhms ) - - print * - print *, ' NCEP filename: ',trim(ana_data) - print *, ' NCEP CTL File: ',trim(ctlfile) - print *, ' Format: ',trim(format) - print *, ' Date & Time: ',nymd,nhms - print *, ' rslv: ',imncep,jmncep,lmncep - print *, ' undef: ',uncep - print * - print *, 'Number of Variables: ',nvncep - print * - do n=1,nvncep - write(6,1001) trim(names(n)),trim(descs(n)),lmvars(n) - enddo - 1001 format(1x,a8,2x,a20,2x,i3) - print * - - im = imncep - jm = jmncep - mlev = lmncep - - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - 200 format(i8.8) - 300 format(i2.2) - 400 format('dset ^',a) - 600 format(a1,i2.2) - -C ********************************************************************** -C **** Get NCEP Analysis **** -C ********************************************************************** - - print *, 'Reading NCEP Analysis for Date: ',nymd,' Time: ',nhms - - allocate ( dp_ana(im,jm,mlev) ) - allocate ( u_ana(im,jm,mlev) ) - allocate ( v_ana(im,jm,mlev) ) - allocate ( t_ana(im,jm,mlev) ) - allocate ( q_ana(im,jm,mlev,nq) ) - allocate ( ps_ana(im,jm) ) - allocate (phis_ana(im,jm) ) - - call get_ncep_map ( ana_data,format,ps_ana,dp_ana,u_ana,v_ana,t_ana,q_ana,phis_ana, - . im,jm,mlev,nq,nvncep,names,lmvars ) - -C ********************************************************************** -C **** Check for Negative Humidity **** -C ********************************************************************** - - do n=1,nq - call QFILL ( q_ana(1,1,1,n),dp_ana,im,jm,mlev ) - enddo - -C ********************************************************************** -C **** Adjust fv Restart **** -C ********************************************************************** - - print *, 'Calling Remap' - - allocate ( dp(im,jm,lm) ) - allocate ( u(im,jm,lm) ) - allocate ( v(im,jm,lm) ) - allocate ( thv(im,jm,lm) ) - allocate ( q(im,jm,lm,nq) ) - allocate ( ps(im,jm) ) - allocate (phis(im,jm) ) - - phis = phis_ana - ps = ps_ana - - call remap ( ps,dp,u,v,thv,q,lm, - . ps_ana,dp_ana,u_ana,v_ana,t_ana,q_ana,mlev,im,jm,nq ) - - -C ********************************************************************** -C **** Write NCEP ANA.ETA File **** -C ********************************************************************** - - call put_fveta ( ps,dp,u,v,thv,q,phis, - . im,jm,lm,nq,nymd,nhms,tag,ext,lons(1), - . timinc,precision ) - - stop - end - - subroutine QFILL ( Q,DP,IM,JM,LM ) - implicit none - integer IM,JM,LM,L - real Q(IM,JM,LM) - real DP(IM,JM,LM) - real*8, allocatable, dimension(:,:) :: QTEMP1 - real*8, allocatable, dimension(:,:) :: QTEMP2 - allocate(QTEMP1(IM,JM)) - allocate(QTEMP2(IM,JM)) - - QTEMP1 = 0.0 - do L=1,LM - QTEMP1(:,:) = QTEMP1(:,:) + Q(:,:,L)*DP(:,:,L) - enddo - - where( Q < 0.0 ) Q = 0.0 - - QTEMP2 = 0.0 - do L=1,LM - QTEMP2(:,:) = QTEMP2(:,:) + Q(:,:,L)*DP(:,:,L) - enddo - - where( qtemp2.ne.0.0 ) - qtemp2 = max( qtemp1/qtemp2, 0.0 ) - end where - - do L=1,LM - Q(:,:,L) = Q(:,:,L)*qtemp2(:,:) - enddo - - deallocate(QTEMP1) - deallocate(QTEMP2) - return - end - - subroutine put_fveta ( ps,dp,u,v,thv,q,phis, - . im,jm,lm,nq,nymd,nhms,tag,ext,lonbeg, - . timeinc,precision ) - use MAPL_BaseMod, only: MAPL_UNDEF - use m_set_eta, only: set_eta - implicit none - - integer im,jm,lm,nq,nymd,nhms - real phis(im,jm) - real ps(im,jm) - real dp(im,jm,lm) - real u(im,jm,lm) - real v(im,jm,lm) - real thv(im,jm,lm) - real q(im,jm,lm,nq) - integer timeinc - - real ple(im,jm,lm+1) - real pke(im,jm,lm+1) - real pk(im,jm,lm) - real tv(im,jm,lm) - real t(im,jm,lm) - - real lats(jm) - real lons(im) - real levs(lm) - real ak(lm+1) - real bk(lm+1) - - real rgas,rvap,eps,kappa,grav - real ptop,dlon,dlat,pref,dpref(lm),undef,lonbeg,pint - integer i,j,L,m,n,rc,ks - character*256 tag,ext,filename, fname - integer nvars,fid,precision - - character*256 levunits - character*256 title - character*256 source - character*256 contact - character*256, allocatable, dimension(:) :: vname - character*256, allocatable, dimension(:) :: vtitle - character*256, allocatable, dimension(:) :: vunits - integer, allocatable, dimension(:) :: lmvar - - real, allocatable :: v_range(:,:) - real, allocatable :: p_range(:,:) - - character*2 cnhms - character*8 cnymd - - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - kappa = 2.0/7.0 - grav = 9.80 - - undef = MAPL_UNDEF - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - 200 format(i8.8) - 300 format(i2.2) - fname = trim(tag) // 'gg2eta.' // trim(cnymd) // '_' // trim(cnhms) // 'z.' // trim(ext) - print *, 'Creating 32-bit eta file: ',trim(fname) - - call set_eta ( lm,ks,ptop,pint,ak,bk ) - -! Construct T, TV -! --------------- - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - tv = thv*pk - t(:,:,:) = tv(:,:,:)/(1+eps*q(:,:,:,1)) - -c String and vars settings -c ------------------------ - title = 'FVGCM Dynamics State Vector (Hybrid Coordinates)' - source = 'Goddard Modeling and Assimilation Office, NASA/GSFC' - contact = 'data@gmao.gsfc.nasa.gov' - levunits = 'hPa' - - nvars = 9 - - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - allocate ( v_range(2,nvars) ) - allocate ( p_range(2,nvars) ) - - n = 1 - vname(n) = 'phis' - vtitle(n) = 'Topography geopotential' - vunits(n) = 'meter2/sec2' - lmvar(n) = 0 - - n = n + 1 - vname(n) = 'ps' - vtitle(n) = 'Surface Pressure' - vunits(n) = 'Pa' - lmvar(n) = 0 - - n = n + 1 - vname(n) = 'dp' - vtitle(n) = 'Pressure Thickness' - vunits(n) = 'Pa' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'u' - vtitle(n) = 'eastward_wind' - vunits(n) = 'm/s' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'v' - vtitle(n) = 'northward_wind' - vunits(n) = 'm/s' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'tv' - vtitle(n) = 'air_virtual_temperature' - vunits(n) = 'K' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'qv' - vtitle(n) = 'Specific Humidity Vapor' - vunits(n) = 'kg/kg' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'ozone' - vtitle(n) = 'Ozone' - vunits(n) = 'ppmv' - lmvar(n) = lm - - n = n + 1 - vname(n) = 'ql' - vtitle(n) = 'Mass Fraction Cloud Liquid Water' - vunits(n) = 'kg/kg' - lmvar(n) = lm - - v_range(:,:) = undef - p_range(:,:) = undef - -c Compute grid -c ------------ - dlon = 360.0/ im - dlat = 180.0/(jm-1) - - do j=1,jm - lats(j) = -90.0 + (j-1)*dlat - enddo - do i=1,im - lons(i) = lonbeg + (i-1)*dlon - enddo - do L=1,lm - dpref(L) = (ak(L+1)-ak(L)) + (bk(L+1)-bk(L))*98400.0 - enddo - pref = ptop + 0.5*dpref(1) - levs(1) = pref - do L=2,lm - pref = pref + 0.5*( dpref(L)+dpref(L-1) ) - levs(L) = pref - enddo - levs(:) = levs(:)/100 - -c Create GFIO file -c ---------------- - call GFIO_Create ( fname, title, source, contact, undef, - . im, jm, lm, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vname, vtitle, vunits, lmvar, - . v_range, p_range, precision, - . fid, rc ) -c Write GFIO data -c --------------- - n = 1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,0, 1,phis,rc ) ; n = n+1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,0, 1,ps ,rc ) ; n = n+1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,dp ,rc ) ; n = n+1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,u ,rc ) ; n = n+1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,v ,rc ) ; n = n+1 - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,tv ,rc ) ; n = n+1 - do m=1,nq - call Gfio_putVar ( fid,vname(n),nymd,nhms,im,jm,1,lm,q(1,1,1,m),rc ) ; n = n+1 - enddo - -c Write GFIO global attributes -c ---------------------------- - call GFIO_PutRealAtt ( fid,'ak', lm+1,ak ,precision,rc ) - call GFIO_PutRealAtt ( fid,'bk', lm+1,bk ,precision,rc ) - - call gfio_close ( fid,rc ) - return - end - - subroutine getfile ( ku,filename,irec ) - implicit none - character(len=*) filename - integer ku,irec - - if ( irec>0 ) then - - open (ku,file=trim(filename),form='unformatted',access='direct',recl=irec) - return - - else - - open (ku,file=trim(filename),form='unformatted',access='sequential',convert='big_endian') - read (ku, err=1001) ! Check for BIG_ENDIAN - - 5000 backspace(ku) - return - - 1001 close(ku) - print *, 'File: ',trim(filename) - print *, 'Failed to OPEN using BIG_ENDIAN, will try LITTLE_ENDIAN' - open (ku,file=trim(filename),form='unformatted',access='sequential',convert='little_endian') - read (ku, err=1002) ! Check for LITTLE_ENDIAN - goto 5000 - - 1002 continue - print *, 'ERROR!! File: ',trim(filename) - print *, 'ERROR!! is neither BIG nor LITTLE ENDIAN' - error stop 7 - - endif - end - - subroutine get_ncep_map ( filename,format,ps,dp,u,v,t,q,phis,im,jm,mlev,nq, - . nvars,names,lmvars ) - use MAPL_ConstantsMod - implicit none - integer im,jm,mlev,nq - integer nvars - integer lmvars(nvars) - character*256 names(nvars) - character*256 filename, format - - real ps(im,jm) - real dp(im,jm,mlev) - real u(im,jm,mlev) - real v(im,jm,mlev) - real t(im,jm,mlev) - real q(im,jm,mlev,nq) - real phis(im,jm) - - real*4, allocatable :: qncep(:,:,:,:) - - real, parameter :: voltomas = 1.655E-6 - real*4, parameter :: undef4 = -9.99E+33 - real undef,kappa,grav - integer L,i,j,n,irec,mrec - - inquire(iolength=irec) undef4 - irec = im*jm*irec - - if( trim(format).eq.'direct' ) then - call getfile ( 30,trim(filename),irec ) - else - call getfile ( 30,trim(filename),0 ) - endif - - allocate ( qncep(im,jm,mlev,nvars) ) - - undef = undef4 - kappa = MAPL_KAPPA - grav = MAPL_GRAV - qncep = 0.0 ! Initialize all NCEP variables to zero - -c Read NCEP Variables -c ------------------- - mrec = 1 - do n=1,nvars - if( trim(format).eq.'direct' ) then - do L=1,lmvars(n) - read(30,rec=mrec) ((qncep(i,j,mlev-L+1,n),i=1,im),j=jm,1,-1) - mrec=mrec+1 - enddo - else - do L=1,lmvars(n) - read(30) ((qncep(i,j,mlev-L+1,n),i=1,im),j=jm,1,-1) - enddo - endif - enddo - - -c Load GMAO Variables -c ------------------- - do n=1,nvars - if( trim(names(n)).eq.'HS' ) phis = qncep(:,:,mlev,n) ! Surface Geopotential - if( trim(names(n)).eq.'PS' ) ps = qncep(:,:,mlev,n) ! Surface Pressure - if( trim(names(n)).eq.'DP' ) dp = qncep(:,:,:, n) ! Surface Pressure Thickness - if( trim(names(n)).eq.'T' ) t = qncep(:,:,:, n) ! Sensible/Dry-bulb Temperature - if( trim(names(n)).eq.'U' ) u = qncep(:,:,:, n) ! U-Wind - if( trim(names(n)).eq.'V' ) v = qncep(:,:,:, n) ! V-Wind - if( trim(names(n)).eq.'Q' ) q(:,:,:,1) = qncep(:,:,:,n) ! Specific Humidity - if( trim(names(n)).eq.'Q2' ) q(:,:,:,2) = qncep(:,:,:,n) ! Ozone - if( trim(names(n)).eq.'Q3' ) q(:,:,:,3) = qncep(:,:,:,n) ! Cloud Liquid Water - enddo - -c Scale GMAO Variables -c -------------------- - phis = phis*grav - q(:,:,:,2) = q(:,:,:,2)/voltomas - - deallocate ( qncep ) - close (30) - return - end - - subroutine usage() - print *, "Usage: " - print * - print *, " gg2fv.x [-ncep ncep.data]" - print *, " [-ctl ncep.ctl]" - print *, " [-tag tag]" - print * - print *, "where:" - print * - print *, " -ncep ncep.data: Filename of NCEP sigma-level analysis data (from ss2gg)" - print *, " -ctl ncep.ctl : Filename of NCEP sigma-level analysis ctl (from ss2gg)" - print *, " -tag tag : Optional Prefix tag for output files" - print * - error stop 7 - end - - subroutine read_ctl ( ctlfile,im,jm,lm,undef,format, - . nvars,names,descs,lmvars, - . lats,lons,nymd,nhms ) -C ********************************************************************** -C **** Read Grads CTL File for Meta Data **** -C ********************************************************************** - - implicit none - - character*256, pointer :: names(:) - character*256, pointer :: descs(:) - integer, pointer :: lmvars(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - - character*256 ctlfile, format - integer im,jm,lm,nvars - real undef,dx,dy - integer i,j,m,n,ndum,len - integer nymd,nhms - character*1 c - character*256 dummy,udummy - character*256 cyear,chour,cmonth,cday,cnymd,cnhms - character*256, allocatable :: dum(:) - - open (10,file=trim(ctlfile),form='formatted') - format = 'direct' - do - read(10,*,end=500) dummy - -c OPTIONS -c ------- - if( trim(dummy).eq.'options' ) then - ndum = 1 - do - backspace(10) - allocate ( dum(ndum) ) - read(10,*,err=101) dummy - if( trim(dummy).eq.'options' ) then - backspace(10) - read(10,*,end=101) dummy,( dum(n),n=1,ndum ) - else - goto 101 - endif - if( trim(dum(ndum)).eq.'sequential' ) format = 'sequential' - deallocate ( dum ) - ndum = ndum + 1 - enddo - 100 format(a5) - 101 continue - deallocate ( dum ) - endif - -c XDEF -c ---- - if( trim(dummy).eq.'xdef' ) then - backspace(10) - read(10,*) dummy,im - allocate( lons(im) ) - backspace(10) - read(10,*) dummy,im,dummy,lons(1),dx - if( trim(dummy).eq.'linear' ) then - do i=2,im - lons(i) = lons(i-1) + dx - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lons(i),i=1,im) - endif - endif - -c YDEF -c ---- - if( trim(dummy).eq.'ydef' ) then - backspace(10) - read(10,*) dummy,jm - allocate( lats(jm) ) - backspace(10) - read(10,*) dummy,jm,dummy,lats(1),dy - if( trim(dummy).eq.'linear' ) then - do j=2,jm - lats(j) = lats(j-1) + dy - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lats(j),j=1,jm) - endif - endif - -c TDEF -c ---- - if( trim(dummy).eq.'tdef' ) then - backspace(10) - read(10,*) dummy,j,dummy,dummy - len = len_trim(dummy) - udummy = '' - do i=1,len - c = dummy(i:i) - if( ichar(c).ge.97 .and. ichar(c).le.122 ) then - c = achar( ichar(c)-32 ) - endif - udummy = trim(udummy) // c - enddo - dummy = udummy - chour = dummy(1:2) - cday = dummy(4:5) - cmonth = dummy(6:8) - cyear = dummy(9:12) - if( cmonth == 'JAN' ) cmonth = '01' - if( cmonth == 'FEB' ) cmonth = '02' - if( cmonth == 'MAR' ) cmonth = '03' - if( cmonth == 'APR' ) cmonth = '04' - if( cmonth == 'MAY' ) cmonth = '05' - if( cmonth == 'JUN' ) cmonth = '06' - if( cmonth == 'JUL' ) cmonth = '07' - if( cmonth == 'AUG' ) cmonth = '08' - if( cmonth == 'SEP' ) cmonth = '09' - if( cmonth == 'OCT' ) cmonth = '10' - if( cmonth == 'NOV' ) cmonth = '11' - if( cmonth == 'DEC' ) cmonth = '12' - - cnymd = trim(cyear) // trim(cmonth) // trim(cday) - cnhms = trim(chour) // '0000' - read( cnymd,* ) nymd - read( cnhms,* ) nhms - endif - -c ZDEF -c ---- - if( trim(dummy).eq.'zdef' ) then - backspace(10) - read(10,*) dummy,lm -#if 0 - allocate( levs(lm) ) - backspace(10) - if( lm.eq.1 ) then - read(10,*) dummy,lm,dummy,levs(1) - else - read(10,*) dummy,lm,dummy,levs(1),dz - endif - if( trim(dummy).eq.'linear' ) then - do L=2,lm - levs(L) = levs(L-1) + dz - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(levs(L),L=1,lm) - endif -#endif - endif - -c UNDEF -c ----- - if( trim(dummy).eq.'undef' ) then - backspace(10) - read(10,*) dummy,undef - endif - - if( trim(dummy).eq.'vars' ) then - backspace(10) - read(10,*) dummy,nvars - allocate( names(nvars) ) - allocate( descs(nvars) ) - allocate( lmvars(nvars) ) - - do n=1,nvars - read(10,*) names(n),lmvars(n),m,descs(n) - if( lmvars(n).eq.0 ) lmvars(n) = 1 - enddo - - endif - enddo - 500 continue - rewind(10) - - if( nvars.eq.0 ) then - print *, 'Warning, nvars = 0!' - stop - endif - - return - end subroutine read_ctl - - subroutine remap ( ps1,dp1,u1,v1,thv1,q1,lm1, - . ps2,dp2,u2,v2,t2 ,q2,lm2,im,jm,nq ) - -C*********************************************************************** -C -C Purpose -C Driver for remapping input analysis (2) to output model levels (1) -C -C Argument Description -C ps1 ...... model surface pressure -C dp1 ...... model pressure thickness -C u1 ....... model zonal wind -C v1 ....... model meridional wind -C thv1 ..... model virtual potential temperature -C q1 ....... model specific humidity -C oz1 ...... model ozone -C lm1 ...... model vertical dimension -C -C ps2 ...... analysis surface pressure -C dp2 ...... analysis pressure thickness -C u2 ....... analysis zonal wind -C v2 ....... analysis meridional wind -C t2 . ..... analysis dry-bulb temperature -C q2 ....... analysis specific humidity -C oz2 ...... analysis ozone -C lm2 ...... analysis vertical dimension -C -C im ....... zonal dimension -C jm ....... meridional dimension -C nq ....... number of tracers -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - integer im,jm,lm1,lm2,nq - -c fv-DAS variables -c ---------------- - real dp1(im,jm,lm1) - real u1(im,jm,lm1) - real v1(im,jm,lm1) - real thv1(im,jm,lm1) - real q1(im,jm,lm1,nq) - real ps1(im,jm) - - real ak(lm1+1) - real bk(lm1+1) - -c Target analysis variables -c ------------------------- - real dp2(im,jm,lm2) - real u2(im,jm,lm2) - real v2(im,jm,lm2) - real t2(im,jm,lm2) - real thv2(im,jm,lm2) - real q2(im,jm,lm2,nq) - real ps2(im,jm) - -c Local variables -c --------------- - real pe1(im,jm,lm1+1) - real pe2(im,jm,lm2+1) - real pk2(im,jm,lm2 ) - real pke1(im,jm,lm1+1) - real pke2(im,jm,lm2+1) - - real kappa,cp,ptop,pl,alf,pint - real rgas,pref,tref,pkref,tstar,eps,rvap,grav - integer i,j,L,n,ks - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - -c Construct target analysis pressure variables -c -------------------------------------------- - do j=1,jm - do i=1,im - pe2(i,j,lm2+1) = ps2(i,j) - enddo - enddo - - do L=lm2,1,-1 - do j=1,jm - do i=1,im - pe2(i,j,L) = pe2(i,j,L+1) - dp2(i,j,L) - enddo - enddo - enddo - - do j=1,jm - do i=1,im - pe2(i,j,1) = max( pe2(i,j,1),1.0 ) ! Set ptop = 0.01 mb (rather than 0.0 mb from NCEP) - enddo - enddo - - do L=1,lm2+1 - do j=1,jm - do i=1,im - pke2(i,j,L) = pe2(i,j,L)**kappa - enddo - enddo - enddo - -c Construct target virtual potential temperature -c ---------------------------------------------- - do L=1,lm2 - do j=1,jm - do i=1,im - pk2(i,j,L) = ( pke2(i,j,L+1)-pke2(i,j,L) )/( kappa*log(pe2(i,j,L+1)/pe2(i,j,L)) ) - thv2(i,j,L) = t2(i,j,L)*( 1.0+eps*max(0.0,q2(i,j,L,1)) )/pk2(i,j,L) - enddo - enddo - enddo - -c Construct fv pressure variables using surface pressure and AK & BK -c ------------------------------------------------------------------ - call set_eta ( lm1,ks,ptop,pint,ak,bk ) - - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1(i,j,L) = ak(L) + bk(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -c Map Input Analysis onto fv grid -c ------------------------------- - call gmap ( im,jm,nq, kappa, - . lm2, pke2, pe2, u2, v2, thv2, q2, - . lm1, pke1, pe1, u1, v1, thv1, q1) - - return - end diff --git a/GEOS_Util/post/gg2fv.F b/GEOS_Util/post/gg2fv.F deleted file mode 100644 index 44d7438a..00000000 --- a/GEOS_Util/post/gg2fv.F +++ /dev/null @@ -1,3368 +0,0 @@ - program main - use m_set_eta, only: set_eta - implicit none - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to create fv restarts from NCEP sigma files **** -c **** **** -c **** !REVISION HISTORY: **** -c **** **** -c **** 22Jun2007 Todling Updated to handle newer NCEP files **** -c **** 12Jan2009 Todling Updated to handle A-grid/Tv **** -c **** 06Feb2009 Todling When tv/agridw present use qctot **** -c **** 25Jul2009 Todling Revisited for 540 tag **** -c **** 05Aug2009 Takacs Fixed bug for TV remapping. **** -c **** Generalized filename extension. **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm,nq - real pbelow,pabove,ptop,pint - -c Set analysis, fvdas, date and time -c ---------------------------------- - character*1 hres - character*1 string(256), blank(256) - character*2 cnhms - character*8 cnymd - - character*256 ana_data, fv_data, fv_rst, ts_data, lwi_data, tag, ext - data fv_rst /'gg2fv.rst.lcv.yyyymmdd_hhz.bin'/ - data blank /256*' '/ - - equivalence ( blank (01),tag ) - equivalence ( string(01),fv_rst) - equivalence ( string(15),cnymd ) - equivalence ( string(24),cnhms ) - - real :: kappa = 2.0/7.0 - logical :: lts = .false. - logical :: llwi = .false. - logical :: ctl_exists = .false. - logical :: add_ozone = .false. - - integer nymd,nhms - -c fv restart variables and topography -c ----------------------------------- - real, allocatable :: dp(:,:,:) - real, allocatable :: pl(:,:,:) - real, allocatable :: ple(:,:,:) - real, allocatable :: u(:,:,:) - real, allocatable :: v(:,:,:) - real, allocatable :: tv(:,:,:) - real, allocatable :: thv(:,:,:) - real, allocatable :: pke(:,:,:) - real, allocatable :: pk (:,:,:) - real, allocatable :: q(:,:,:,:) - real, allocatable :: phis(:,:) - real, allocatable :: std(:,:) - real, allocatable :: lwi(:,:) - real, allocatable :: ts(:,:) - real, allocatable :: ps(:,:) - real, allocatable :: frland (:,:) - real, allocatable :: frlandice(:,:) - real, allocatable :: frlake (:,:) - real, allocatable :: frocean (:,:) - real, allocatable :: frseaice (:,:) - - real, allocatable :: ak(:) - real, allocatable :: bk(:) - - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - integer timinc - real undef - -c Analysis variables -c ------------------ - real, allocatable :: phis_ana(:,:) - real, allocatable :: ps_ana(:,:) - real, allocatable :: u_ana(:,:,:) - real, allocatable :: v_ana(:,:,:) - real, allocatable :: q_ana(:,:,:,:) - real, allocatable :: dp_ana(:,:,:) - real, allocatable :: t_ana(:,:,:) - integer ID,mlev,rc - integer ntime,nvars,ngatts - - character*120, allocatable :: arg(:) - - logical :: agrid = .false. - logical :: dgrid = .false. - logical :: u_agrid = .false. - logical :: v_agrid = .false. - logical :: u_dgrid = .false. - logical :: v_dgrid = .false. - logical :: tvflag = .false. - logical :: thvflag = .false. - logical :: lwiflag = .false. - - integer precision - integer L,n,nargs,ks - -c NCEP Grads CTL File Variables -c ----------------------------- - character*256 ctlfile,format - integer imncep,jmncep,lmncep,nvncep - real uncep - - character*256, pointer :: names (:) - character*256, pointer :: descs (:) - integer, pointer :: lmvars(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - - interface - subroutine read_ctl ( ctlfile,imncep,jmncep,lmncep,uncep,format, - . nvncep,names,descs,lmvars, - . lats,lons ) - character*256 ctlfile, format - character*256, pointer :: names (:) - character*256, pointer :: descs (:) - integer, pointer :: lmvars(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - integer imncep,jmncep,lmncep,nvncep - real uncep - end subroutine read_ctl - end interface - -c Default NCEP Names (Based on New NCEP format) -c --------------------------------------------- - character*256, ncep_names(16) - data ncep_names /'HS','PS','P','DP','TV','T','Q','RH','U','V','DIV','VOR','VP','SF','Q2','Q3'/ - -C ********************************************************************** -C **** Initialize Filenames, Methods, etc. **** -C ********************************************************************** - - nq = 4 ! 1:qv, 2:oz, 3:ql, 4:qi - mlev = -999 - pabove = 10.00 ! 10 mb - pbelow = 30.00 ! 30 mb - precision = 0 ! 32-bit - ctlfile = 'xxx' - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-rslv' ) read(arg(n+1),600) hres,lm - if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1), * ) nymd - if( trim(arg(n)).eq.'-nhms' ) read(arg(n+1), * ) nhms - if( trim(arg(n)).eq.'-date' ) read(arg(n+1), * ) nymd - if( trim(arg(n)).eq.'-time' ) read(arg(n+1), * ) nhms - if( trim(arg(n)).eq.'-mlev' ) read(arg(n+1), * ) mlev - if( trim(arg(n)).eq.'-tag' ) tag = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ncep' ) ana_data = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ana' ) fv_data = trim(arg(n+1)) - if( trim(arg(n)).eq.'-eta' ) fv_data = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ctl' ) ctlfile = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ozone') add_ozone = .true. - if( trim(arg(n)).eq.'-plow ') read(arg(n+1), * ) pbelow - if( trim(arg(n)).eq.'-phigh') read(arg(n+1), * ) pabove - if( trim(arg(n)).eq.'-ts' ) then - ts_data = trim(arg(n+1)) - lts = .true. - endif - if( trim(arg(n)).eq.'-lwi' ) then - lwi_data = trim(arg(n+1)) - llwi = .true. - endif - enddo - print * - print *, ' NCEP filename: ',trim(ana_data) - print *, 'Background filename: ',trim( fv_data) - print *, ' Output Tag: ',trim( tag ) - if( lts ) print *, ' ts filename: ',trim( ts_data) - if( llwi ) print *, ' lwi filename: ',trim( lwi_data) - print *, ' nymd: ',nymd - print *, ' nhms: ',nhms - if( mlev.ne.-999 ) print *, ' mlev: ',mlev - print * - print *, 'Blending between ',pbelow,' and ',pabove,' mb' - print * - endif - pabove = pabove*100 - pbelow = pbelow*100 - - if( trim(tag).ne.'' ) tag = trim(tag) // '.' - n = index(trim(fv_data),'.',back=.true.) - ext = trim(fv_data(n+1:)) - -C ********************************************************************** -C **** Read ETA File MetaData **** -C ********************************************************************** - - call gfio_open ( trim(fv_data),1,ID,rc ) - call gfio_diminquire ( ID,im,jm,lm,ntime,nvars,ngatts,rc ) - -C ********************************************************************** -C **** Read NCEP Grads CTL File **** -C ********************************************************************** - -! Check whether ctl file exists -! ----------------------------- - inquire ( file=trim(ctlfile), exist=ctl_exists ) - - if( ctl_exists ) then - call read_ctl ( ctlfile,imncep,jmncep,lmncep,uncep,format, - . nvncep,names,descs,lmvars, - . lats,lons ) - - if( mlev.eq.-999 ) mlev = lmncep - print * - print *, 'NCEP Grads CTL File: ',trim(ctlfile) - print *, ' Format: ',trim(format) - print *, ' rslv: ',imncep,jmncep,lmncep - print *, ' undef: ',uncep - print * - print *, 'Number of Variables: ',nvncep - print * - do n=1,nvncep - write(6,1001) trim(names(n)),trim(descs(n)),lmvars(n) - enddo - 1001 format(1x,a8,2x,a20,2x,i3) - print * - - else - print *, 'No NCEP Grads CTL file provided, New NCEP format will be assumed!' - nvncep = 16 - imncep = im - jmncep = jm - lmncep = mlev - allocate( names (nvncep) ) - allocate( descs (nvncep) ) - allocate( lmvars(nvncep) ) - names = ncep_names - lmvars(1:2)=1 - do n=3,nvncep - lmvars(n)=mlev - enddo - format = 'direct' - endif - - if( im.ne.imncep .or. jm.ne.jmncep ) then - print * - print *, 'Horizontal Resolution Mis-Match!' - print *, 'NCEP Gridded Data: ',imncep,jmncep - print *, ' BKG Gridded Data: ',im,jm - print * - error stop 7 - endif - if( mlev.ne.lmncep ) then - print * - print *, 'Vertical Resolution Mis-Match!' - print *, 'LMNCEP: ',lmncep - print *, ' MLEV: ',mlev - print * - error stop 7 - endif - -C ********************************************************************** -C **** Read Background/Analysis ETA File **** -C ********************************************************************** - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - -c Check FVETA Variable Names -c -------------------------- - do n=1,nvars - if( trim(vname(n)).eq.'u' ) u_agrid = .true. - if( trim(vname(n)).eq.'v' ) v_agrid = .true. - if( trim(vname(n)).eq.'uwnd' ) u_dgrid = .true. - if( trim(vname(n)).eq.'vwnd' ) v_dgrid = .true. - if( trim(vname(n)).eq.'tv' ) tvflag = .true. - if( trim(vname(n)).eq.'theta' ) thvflag = .true. - if( trim(vname(n)).eq.'lwi' ) lwiflag = .true. - enddo - agrid = u_agrid .and. v_agrid - dgrid = u_dgrid .and. v_dgrid - -c Allocate Space -c -------------- - allocate ( phis(im,jm) ) - allocate ( std(im,jm) ) - allocate ( ts(im,jm) ) - - allocate ( ps(im,jm) ) - allocate ( dp(im,jm,lm) ) - allocate ( u(im,jm,lm) ) - allocate ( v(im,jm,lm) ) - allocate ( tv(im,jm,lm) ) - allocate ( thv(im,jm,lm) ) - allocate ( q(im,jm,lm,nq) ) - - allocate ( lwi (im,jm) ) - allocate ( frland (im,jm) ) - allocate ( frlandice(im,jm) ) - allocate ( frlake (im,jm) ) - allocate ( frocean (im,jm) ) - allocate ( frseaice (im,jm) ) - -c Read Variables -c -------------- - call gfio_getvar ( id,'phis' ,nymd,nhms,im,jm,0,1,phis,rc ) - call gfio_getvar ( id,'hs_stdv',nymd,nhms,im,jm,0,1,std ,rc ) - call gfio_getvar ( id,'ts' ,nymd,nhms,im,jm,0,1,ts ,rc ) - - if( lwiflag ) then - call gfio_getvar ( id,'lwi',nymd,nhms,im,jm,0,1,lwi ,rc ) - frland = undef - frlandice = undef - frlake = undef - frocean = undef - frseaice = undef - else - call gfio_getvar ( id,'frland' ,nymd,nhms,im,jm,0,1,frland ,n ) ; rc = n - call gfio_getvar ( id,'frlandice' ,nymd,nhms,im,jm,0,1,frlandice ,n ) ; rc = n + rc - call gfio_getvar ( id,'frlake' ,nymd,nhms,im,jm,0,1,frlake ,n ) ; rc = n + rc - call gfio_getvar ( id,'frocean' ,nymd,nhms,im,jm,0,1,frocean ,n ) ; rc = n + rc - call gfio_getvar ( id,'frseaice' ,nymd,nhms,im,jm,0,1,frseaice ,n ) ; rc = n + rc - if( rc.ne.0 ) then - print *, 'Reading: ',trim(fv_data) - print *, 'Surface Land Fractions not Available!' - error stop 7 - endif - lwi = 1 ! Land - where ( frocean+frlake >= 0.6 ) lwi = 0 ! Water - where ( lwi==0 .and. frseaice > 0.5 ) lwi = 2 ! Ice - where ( lwi==0 .and. ts < 271.4 ) lwi = 2 ! Ice - endif - - call gfio_getvar ( id,'ps' ,nymd,nhms,im,jm,0,1 ,ps,rc ) - call gfio_getvar ( id,'delp' ,nymd,nhms,im,jm,1,lm,dp,rc ) - - if( agrid ) then - call gfio_getvar ( id,'u',nymd,nhms,im,jm,1,lm,u,rc ) - call gfio_getvar ( id,'v',nymd,nhms,im,jm,1,lm,v,rc ) - endif - - if( dgrid ) then - call gfio_getvar ( id,'uwnd',nymd,nhms,im,jm,1,lm,u,rc ) - call gfio_getvar ( id,'vwnd',nymd,nhms,im,jm,1,lm,v,rc ) - call dtoa ( u,u,im,jm,lm,2 ) - call dtoa ( v,v,im,jm,lm,1 ) - endif - - if( tvflag ) then - call gfio_getvar ( id,'tv',nymd,nhms,im,jm,1,lm,tv,rc ) - endif - - if( thvflag ) then - call gfio_getvar ( id,'theta',nymd,nhms,im,jm,1,lm,thv,rc ) - endif - - call gfio_getvar ( id,'sphu' ,nymd,nhms,im,jm,1,lm,q(1,1,1,1),rc ) - call gfio_getvar ( id,'ozone' ,nymd,nhms,im,jm,1,lm,q(1,1,1,2),rc ) - call gfio_getvar ( id,'qltot' ,nymd,nhms,im,jm,1,lm,q(1,1,1,3),rc ) - call gfio_getvar ( id,'qitot' ,nymd,nhms,im,jm,1,lm,q(1,1,1,4),rc ) - - call gfio_close ( id,rc ) - -! Construct Pressure Variables -! ---------------------------- - allocate ( ak(lm+1) ) - allocate ( bk(lm+1) ) - allocate ( ple(im,jm,lm+1) ) - - call set_eta ( lm,ks,ptop,pint,ak,bk ) - - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - -! Construct THV (if necessary) for REMAPPING -! ------------------------------------------ - if( tvflag .and. .not.thvflag ) then - allocate ( pk(im,jm,lm ) ) - allocate ( pke(im,jm,lm+1) ) - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - thv = tv/pk - endif - - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - 200 format(i8.8) - 300 format(i2.2) - 400 format('dset ^',a) - 600 format(a1,i2.2) - -c Check for ts and lwi -c -------------------- - if ( lts ) then - print *, 'Reading NCEP Surface Analysis for Date: ',nymd,' Time: ',nhms - call get_ncep_tsx( ts_data,ts,im,jm,nhms ) - endif - if ( llwi ) then - print *, 'Reading fv LWI dataset' - call getfile ( 20,trim(lwi_data),0 ) - read ( 20 ) lwi - close( 20 ) - endif - -C ********************************************************************** -C **** Add Climatological Ozone **** -C ********************************************************************** - -c Construct 3-D Ozone on FV Levels -c -------------------------------- - if( add_ozone ) then - allocate ( pl(im,jm,lm) ) - do L=lm,1,-1 - pl(:,:,L) = (ple(:,:,L+1)+ple(:,:,L))*0.5 - enddo - call get_ozone ( q(1,1,1,2),pl,im,jm,lm,nymd,nhms ) - deallocate ( pl ) - endif - -C ********************************************************************** -C **** Get NCEP Analysis **** -C ********************************************************************** - - print *, 'Reading NCEP Analysis for Date: ',nymd,' Time: ',nhms - allocate ( dp_ana(im,jm,mlev) ) - allocate ( u_ana(im,jm,mlev) ) - allocate ( v_ana(im,jm,mlev) ) - allocate ( t_ana(im,jm,mlev) ) - allocate ( q_ana(im,jm,mlev,nq) ) - allocate ( ps_ana(im,jm) ) - allocate (phis_ana(im,jm) ) - call get_ncep_map ( ana_data,format,ps_ana,dp_ana,u_ana,v_ana,t_ana,q_ana,phis_ana, - . im,jm,mlev,nq,lon(1),nvncep,names,lmvars ) - -C ********************************************************************** -C **** Adjust fv Restart **** -C ********************************************************************** - - print *, 'Calling Remap' - call remap ( ps,dp,u,v,thv,q,phis,lm, - . ps_ana,dp_ana,u_ana,v_ana,t_ana,q_ana,phis_ana,mlev,im,jm,nq,pbelow,pabove ) - -C ********************************************************************** -C **** Check for Negative Humidity **** -C ********************************************************************** - - call QFILL ( q(1,1,1,1),dp,im,jm,lm ) - -C ********************************************************************** -C **** Write HDF Eta File **** -C ********************************************************************** - - call put_fvrst ( ps,dp,u,v,thv,q,phis,std,lwi, - . frland,frlandice,frlake,frocean,frseaice, - . ts,im,jm,lm,nq,nymd,nhms,tag,ext,lon(1), - . timinc,precision,dgrid,tvflag ) - - stop - end - - subroutine QFILL ( Q,DP,IM,JM,LM ) - implicit none - integer IM,JM,LM,L - real Q(IM,JM,LM) - real DP(IM,JM,LM) - real*8, allocatable, dimension(:,:) :: QTEMP1 - real*8, allocatable, dimension(:,:) :: QTEMP2 - allocate(QTEMP1(IM,JM)) - allocate(QTEMP2(IM,JM)) - - QTEMP1 = 0.0 - do L=1,LM - QTEMP1(:,:) = QTEMP1(:,:) + Q(:,:,L)*DP(:,:,L) - enddo - - where( Q < 0.0 ) Q = 0.0 - - QTEMP2 = 0.0 - do L=1,LM - QTEMP2(:,:) = QTEMP2(:,:) + Q(:,:,L)*DP(:,:,L) - enddo - - where( qtemp2.ne.0.0 ) - qtemp2 = max( qtemp1/qtemp2, 0.0 ) - end where - - do L=1,LM - Q(:,:,L) = Q(:,:,L)*qtemp2(:,:) - enddo - - deallocate(QTEMP1) - deallocate(QTEMP2) - return - end - - subroutine put_fvrst ( ps,dp,u,v,thv,q,phis,std,lwi, - . frland,frlandice,frlake,frocean,frseaice, - . ts,im,jm,lm,nq,nymd,nhms,tag,ext,lonbeg, - . timeinc,precision,dgrid,tvflag ) - use MAPL_BaseMod, only: MAPL_UNDEF - use m_set_eta, only: set_eta - implicit none - - integer im,jm,lm,nq,nymd,nhms - real phis(im,jm) - real std(im,jm) - real lwi(im,jm) - real ts(im,jm) - real ps(im,jm) - real dp(im,jm,lm) - real u(im,jm,lm) - real v(im,jm,lm) - real thv(im,jm,lm) - real q(im,jm,lm,nq) - real frland(im,jm) - real frlandice(im,jm) - real frlake(im,jm) - real frocean(im,jm) - real frseaice(im,jm) - logical dgrid,tvflag - integer timeinc - - real ple(im,jm,lm+1) - real pke(im,jm,lm+1) - real pk(im,jm,lm) - real tv(im,jm,lm) - real t(im,jm,lm) - real slp(im,jm) - - real lats(jm) - real lons(im) - real levs(lm) - real ak(lm+1) - real bk(lm+1) - - real rgas,rvap,eps,kappa,grav - real ptop,pint,dlon,dlat,pref,dpref(lm),undef,lonbeg - integer i,j,L,n,ks,rc - character*256 tag,ext,filename, fname - integer nvars,fid,precision,nstep - - character*256 levunits - character*256 title - character*256 source - character*256 contact - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - integer, allocatable :: lmvar(:) - real, allocatable :: v_range(:,:) - real, allocatable :: p_range(:,:) - integer nqwrite - - character*1 string(256) - character*2 cnhms - character*8 cnymd - equivalence ( string(01),filename ) - data filename /'gg2fv.eta.yyyymmdd_hhz'/ - equivalence ( string(11),cnymd ) - equivalence ( string(20),cnhms ) - - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - kappa = 2.0/7.0 - grav = 9.81 - nstep = 100 - - undef = MAPL_UNDEF - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - 200 format(i8.8) - 300 format(i2.2) - fname = trim(tag) // trim(filename) // '.' // trim(ext) - print *, 'Creating 32-bit eta file: ',trim(fname) - - call set_eta ( lm,ks,ptop,pint,ak,bk ) - -! Construct D-Grid Winds (if necessary) -! ------------------------------------- - if (dgrid) then - call atod ( u,u,im,jm,lm,2 ) - call atod ( v,v,im,jm,lm,1 ) - endif - -! Construct T, TV, and SLP -! ------------------------ - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - tv = thv*pk - - call get_slp ( ps,phis,slp,ple,pk,tv,rgas,grav,im,jm,lm ) - - t(:,:,:) = tv(:,:,:)/(1+eps*q(:,:,:,1)) - -c String and vars settings -c ------------------------ - title = 'FVGCM Dynamics State Vector (Hybrid Coordinates)' - source = 'Data Assimilation Office, NASA/GSFC' - contact = 'data@dao.gsfc.nasa.gov' - levunits = 'hPa' - - nqwrite = nq - nvars = 16+nqwrite - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - allocate ( v_range(2,nvars) ) - allocate ( p_range(2,nvars) ) - - vname(01) = 'phis' - vtitle(01) = 'Topography geopotential' - vunits(01) = 'meter2/sec2' - lmvar(01) = 0 - - vname(02) = 'hs_stdv' - vtitle(02) = 'Topography Height Standard Deviation' - vunits(02) = 'meter' - lmvar(02) = 0 - - vname(03) = 'ts' - vtitle(03) = 'Surface temperature' - vunits(03) = 'K' - lmvar(03) = 0 - - vname(04) = 'lwi' - vtitle(04) = 'Land-water-ice mask' - vunits(04) = 'non-dimensional' - lmvar(04) = 0 - - vname(05) = 'frland' - vtitle(05) = 'Land fraction' - vunits(05) = '1' - lmvar(05) = 0 - - vname(06) = 'frlandice' - vtitle(06) = 'Land-ice fraction' - vunits(06) = '1' - lmvar(06) = 0 - - vname(07) = 'frlake' - vtitle(07) = 'Lake fraction' - vunits(07) = '1' - lmvar(07) = 0 - - vname(08) = 'frocean' - vtitle(08) = 'Ocean fraction' - vunits(08) = '1' - lmvar(08) = 0 - - vname(09) = 'frseaice' - vtitle(09) = 'Sea-ice fraction' - vunits(09) = '1' - lmvar(09) = 0 - - vname(10) = 'ps' - vtitle(10) = 'Surface Pressure' - vunits(10) = 'Pa' - lmvar(10) = 0 - - vname(11) = 'slp' - vtitle(11) = 'Sea Level Pressure' - vunits(11) = 'Pa' - lmvar(11) = 0 - - vname(12) = 'delp' - vtitle(12) = 'Pressure Thickness' - vunits(12) = 'Pa' - lmvar(12) = lm - - if(dgrid)then - vname(13) = 'uwnd' - vtitle(13) = 'eastward_wind_on_native_D-Grid' - else - vname(13) = 'u' - vtitle(13) = 'eastward_wind' - endif - vunits(13) = 'm/s' - lmvar(13) = lm - - if(dgrid)then - vname(14) = 'vwnd' - vtitle(14) = 'northward_wind_on_native_D-Grid' - else - vname(14) = 'v' - vtitle(14) = 'northward_wind' - endif - vunits(14) = 'm/s' - lmvar(14) = lm - - vname(15) = 'tmpu' - vtitle(15) = 'Temperature' - vunits(15) = 'K' - lmvar(15) = lm - - if (tvflag) then - vname(16) = 'tv' - vtitle(16) = 'air_virtual_temperature' - vunits(16) = 'K' - lmvar(16) = lm - else - vname(16) = 'theta' - vtitle(16) = 'Scaled Virtual Potential Temperature' - vunits(16) = 'K/Pa^kappa' - lmvar(16) = lm - endif - - vname(17) = 'sphu' - vtitle(17) = 'Specific Humidity' - vunits(17) = 'kg/kg' - lmvar(17) = lm - - vname(18) = 'ozone' - vtitle(18) = 'Ozone' - vunits(18) = 'ppmv' - lmvar(18) = lm - - vname(19) = 'qltot' - vtitle(19) = 'Mass Fraction Cloud Liquid Water' - vunits(19) = 'kg/kg' - lmvar(19) = lm - - vname(20) = 'qitot' - vtitle(20) = 'Mass Fraction Cloud Ice Water' - vunits(20) = 'kg/kg' - lmvar(20) = lm - - v_range(:,:) = undef - p_range(:,:) = undef - -c Compute grid -c ------------ - dlon = 360.0/ im - dlat = 180.0/(jm-1) - - do j=1,jm - lats(j) = -90.0 + (j-1)*dlat - enddo - do i=1,im - lons(i) = lonbeg + (i-1)*dlon - enddo - do L=1,lm - dpref(L) = (ak(L+1)-ak(L)) + (bk(L+1)-bk(L))*98400.0 - enddo - pref = ptop + 0.5*dpref(1) - levs(1) = pref - do L=2,lm - pref = pref + 0.5*( dpref(L)+dpref(L-1) ) - levs(L) = pref - enddo - levs(:) = levs(:)/100 - -c Create GFIO file -c ---------------- - call GFIO_Create ( fname, title, source, contact, undef, - . im, jm, lm, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vname, vtitle, vunits, lmvar, - . v_range, p_range, precision, - . fid, rc ) -c Write GFIO data -c --------------- - call Gfio_putVar ( fid,vname(01),nymd,nhms,im,jm,0, 1,phis ,rc ) - call Gfio_putVar ( fid,vname(02),nymd,nhms,im,jm,0, 1,std ,rc ) - call Gfio_putVar ( fid,vname(03),nymd,nhms,im,jm,0, 1,ts ,rc ) - call Gfio_putVar ( fid,vname(04),nymd,nhms,im,jm,0, 1,lwi ,rc ) - call Gfio_putVar ( fid,vname(05),nymd,nhms,im,jm,0, 1,frland ,rc ) - call Gfio_putVar ( fid,vname(06),nymd,nhms,im,jm,0, 1,frlandice ,rc ) - call Gfio_putVar ( fid,vname(07),nymd,nhms,im,jm,0, 1,frlake ,rc ) - call Gfio_putVar ( fid,vname(08),nymd,nhms,im,jm,0, 1,frocean ,rc ) - call Gfio_putVar ( fid,vname(09),nymd,nhms,im,jm,0, 1,frseaice ,rc ) - call Gfio_putVar ( fid,vname(10),nymd,nhms,im,jm,0, 1,ps ,rc ) - call Gfio_putVar ( fid,vname(11),nymd,nhms,im,jm,0, 1,slp ,rc ) - call Gfio_putVar ( fid,vname(12),nymd,nhms,im,jm,1,lm,dp ,rc ) - call Gfio_putVar ( fid,vname(13),nymd,nhms,im,jm,1,lm,u ,rc ) - call Gfio_putVar ( fid,vname(14),nymd,nhms,im,jm,1,lm,v ,rc ) - call Gfio_putVar ( fid,vname(15),nymd,nhms,im,jm,1,lm,t ,rc ) - - if( tvflag ) then - call Gfio_putVar ( fid,vname(16),nymd,nhms,im,jm,1,lm,tv ,rc ) - else - call Gfio_putVar ( fid,vname(16),nymd,nhms,im,jm,1,lm,thv ,rc ) - endif - - do n=1,nqwrite - call Gfio_putVar ( fid,vname(16+n),nymd,nhms,im,jm,1,lm,q(1,1,1,n),rc ) - enddo - -c Write GFIO global attributes -c ---------------------------- - call GFIO_PutRealAtt ( fid,'ptop', 1,ptop ,precision,rc ) - call GFIO_PutRealAtt ( fid,'pint', 1,pint ,precision,rc ) - call GFIO_PutIntAtt ( fid,'ks', 1,ks ,0 ,rc ) - call GFIO_PutRealAtt ( fid,'ak', lm+1,ak ,precision,rc ) - call GFIO_PutRealAtt ( fid,'bk', lm+1,bk ,precision,rc ) - call GFIO_PutIntAtt ( fid,'nstep', 1,nstep,0 ,rc ) - - call gfio_close ( fid,rc ) - return - end - - subroutine getfile ( ku,filename,irec ) - implicit none - character(len=*) filename - integer ku,irec - - if ( irec>0 ) then - - open (ku,file=trim(filename),form='unformatted',access='direct',recl=irec) - return - - else - - open (ku,file=trim(filename),form='unformatted',access='sequential',convert='big_endian') - read (ku, err=1001) ! Check for BIG_ENDIAN - - 5000 backspace(ku) - return - - 1001 close(ku) - print *, 'File: ',trim(filename) - print *, 'Failed to OPEN using BIG_ENDIAN, will try LITTLE_ENDIAN' - open (ku,file=trim(filename),form='unformatted',access='sequential',convert='little_endian') - read (ku, err=1002) ! Check for LITTLE_ENDIAN - goto 5000 - - 1002 continue - print *, 'ERROR!! File: ',trim(filename) - print *, 'ERROR!! is neither BIG nor LITTLE ENDIAN' - error stop 7 - - endif - end - - subroutine get_ncep_map ( filename,format,ps,dp,u,v,t,q,phis,im,jm,mlev,nq,lonbeg, - . nvars,names,lmvars ) - use MAPL_ConstantsMod - implicit none - integer im,jm,mlev,nq - integer nvars - integer lmvars(nvars) - character*256 names(nvars) - character*256 filename, format - - real lonbeg - real ps(im,jm) - real dp(im,jm,mlev) - real u(im,jm,mlev) - real v(im,jm,mlev) - real t(im,jm,mlev) - real q(im,jm,mlev,nq) - real phis(im,jm) - - real*4, allocatable :: qncep(:,:,:,:) - - real, parameter :: voltomas = 1.655E-6 - real*4, parameter :: undef4 = -9.99E+33 - real undef,kappa,grav - integer L,i,j,n,irec,mrec - - inquire(iolength=irec) undef4 - irec = im*jm*irec - - if( trim(format).eq.'direct' ) then - call getfile ( 30,trim(filename),irec ) - else - call getfile ( 30,trim(filename),0 ) - endif - - allocate ( qncep(im,jm,mlev,nvars) ) - - undef = undef4 - kappa = MAPL_KAPPA - grav = MAPL_GRAV - qncep = 0.0 ! Initialize all NCEP variables to zero - -c Read NCEP Variables -c ------------------- - mrec = 1 - do n=1,nvars - if( trim(format).eq.'direct' ) then - do L=1,lmvars(n) - read(30,rec=mrec) ((qncep(i,j,mlev-L+1,n),i=1,im),j=jm,1,-1) - mrec=mrec+1 - enddo - else - do L=1,lmvars(n) - read(30) ((qncep(i,j,mlev-L+1,n),i=1,im),j=jm,1,-1) - enddo - endif - if( lonbeg.lt.0.0 ) call hflip( qncep(1,1,1,n),im,jm,mlev ) - enddo - - -c Load GMAO Variables -c ------------------- - do n=1,nvars - if( trim(names(n)).eq.'HS' ) phis = qncep(:,:,mlev,n) ! Surface Geopotential - if( trim(names(n)).eq.'PS' ) ps = qncep(:,:,mlev,n) ! Surface Pressure - if( trim(names(n)).eq.'DP' ) dp = qncep(:,:,:, n) ! Surface Pressure Thickness - if( trim(names(n)).eq.'T' ) t = qncep(:,:,:, n) ! Sensible/Dry-bulb Temperature - if( trim(names(n)).eq.'U' ) u = qncep(:,:,:, n) ! U-Wind - if( trim(names(n)).eq.'V' ) v = qncep(:,:,:, n) ! V-Wind - if( trim(names(n)).eq.'Q' ) q(:,:,:,1) = qncep(:,:,:,n) ! Specific Humidity - if( trim(names(n)).eq.'Q2' ) q(:,:,:,2) = qncep(:,:,:,n) ! Ozone - if( trim(names(n)).eq.'Q3' ) q(:,:,:,3) = qncep(:,:,:,n) ! Cloud Liquid Water - enddo - q(:,:,:,4) = 0.0 ! Cloud Ice Water - -c Scale GMAO Variables -c -------------------- - phis = phis*grav - q(:,:,:,2) = q(:,:,:,2)/voltomas - - deallocate ( qncep ) - close (30) - return - end - - subroutine hflip ( q,im,jm,lm ) - implicit none - integer im,jm,lm,i,j,L - real*4 q(im,jm,lm),dum(im) - do L=1,lm - do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j,L) - dum(i+im/2) = q(i,j,L) - enddo - q(:,j,L) = dum(:) - enddo - enddo - return - end - - subroutine get_ncep_ts ( filename,ts,im,jm,nymd,nhms ) -c program to read ts from ncep surface analysis file -c -------------------------------------------------- - use MAPL_BaseMod, only: MAPL_UNDEF - implicit none - integer im,jm,nymd,nhms - real ts(im,jm) - character*256 filename - - real, allocatable :: glat(:) - real, allocatable :: lat2(:) - real, allocatable :: dlam(:) - real, allocatable :: dphi(:) - - real, allocatable :: lons(:) - real, allocatable :: lats(:) - real, allocatable :: dum(:,:) - real*4, allocatable :: bum(:,:) - - character*32 title - integer idate(4),mymd,mhms - real*4 fhour - real undef,pi,dl,dp,tnp,tsp - real lon,lat - integer i,j,m,n,loc,ndt,imax,jmax - - call getfile ( 30,trim(filename),0 ) - - read (30) title - read (30) fhour,idate,imax,jmax - - mymd = idate(4)*10000 + idate(2)*100 + idate(3) - mhms = idate(1)*10000 - ndt = fhour*3600 - - call tick (mymd,mhms,ndt) - - if( nymd.ne.mymd .or. mhms.ne.nhms ) then - print *, ' NCEP surface dataset date and time: ',mymd,mhms - print *, 'does not match upper-air date and time: ',nymd,nhms - stop 101 - endif - undef = MAPL_UNDEF - -c compute guassian latitudes -c ---------------------------------- - allocate ( glat(jmax) ) - allocate ( lat2(jmax+2) ) - allocate ( dphi(jmax+2) ) - allocate ( dlam(imax) ) - - call gauss_lat_nmc (glat,jmax) - - print * - print *, 'Guassian Latitudes:' - print *, '-------------------' - do j=1,jmax,8 - m=j - n=j+7 - if(n.gt.jmax) n=jmax - write(*,100) (glat(i),i=m,n) - enddo - print * - 100 format(8f10.5) - -c create lats array with pole points -c ---------------------------------- - lat2(1) = -90.0 - do j=2,jmax+1 - lat2(j) = glat(j-1) - enddo - lat2(jmax+2) = 90.0 - -c compute dlam and dphi array -c --------------------------- - pi = 4.0*atan(1.0) - dl = 2.0*pi/imax - dlam(:) = dl - - do j=1,jmax+1 - dphi(j) = ( lat2(j+1)-lat2(j) )*pi/180.0 - enddo - dphi(jmax+2) = undef - -c read surface temperature -c ------------------------ - allocate ( bum(imax,jmax+2) ) - allocate ( dum(imax,jmax+2) ) - - read (30) ( (bum(i,jmax-j+2),i=1,imax),j=1,jmax ) - dum(:,:) = bum(:,:) - -c create pole values -c ------------------ - tnp = 0.0 - tsp = 0.0 - do i=1,imax - tnp = tnp + dum(i,jmax+1) - tsp = tsp + dum(i,2) - enddo - tnp = tnp / imax - tsp = tsp / imax - do i=1,imax - dum(i,jmax+2) = tnp - dum(i,1) = tsp - enddo - -c create output lons and lats and interpolate ts -c ---------------------------------------------- - dl = 2*pi/im - dp = pi/( jm-1 ) - - allocate ( lons(im*jm) ) - allocate ( lats(im*jm) ) - - loc = 0 - do j=1,jm - do i=1,im - loc = loc + 1 - lon = -pi + (i-1)*dl - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jm - lat = -pi/2.0 + (j-1)*dp - do i=1,im - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call interp_h ( dum,imax,jmax+2,1, - . dlam,dphi,0.0,90.0,0.0, - . ts,im*jm,lons,lats, - . 1,3,.false.,undef ) - - deallocate ( dum,bum,lons,lats ) - deallocate ( glat,lat2,dlam,dphi ) - - rewind(30) - close (30) - return - end - - subroutine get_ncep_tsx( filename,ts,im,jm,nhms ) -c program to read ts from ncep pressure level analysis file -c --------------------------------------------------------- - implicit none - integer im,jm,nhms - real ts(im,jm) - character*256 filename - - real, allocatable :: dum(:,:) - real*4, allocatable :: bum(:,:) - - integer, parameter :: nrec = 17+5*26 ! 17 surface fields + 5 upper air fields - - real*4, parameter :: undef4 = 9.999E+20 - real undef - integer i,j,m,imax,jmax - - imax = im - jmax = jm - allocate ( bum(imax,jmax) ) - allocate ( dum(imax,jmax) ) - - open (30,file=trim(filename),form='unformatted',access='direct',recl=imax*jmax*4) - - undef = undef4 - -c surface temperature -c ------------------- - m = nhms/60000 - read(30,rec=11+m*nrec) ((bum(i,j),i=1,imax),j=1,jmax) - ts(:,:) = bum(:,:) - - deallocate ( dum,bum ) - - close (30) - return - end - - subroutine writit (q,im,jm,lm,ku) - real q (im,jm,lm) - real*4 q2(im,jm) - do L=lm,1,-1 - q2(:,:) = q(:,:,L) - write(ku) q2 - enddo - return - end - - subroutine qsat (tt,p,q,dqdt,ldqdt) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute Saturation Specific Humidity -C -C INPUT: -C ====== -C TT ......... Temperature (Kelvin) -C P .......... Pressure (mb) -C LDQDT ...... Logical Flag to compute QSAT Derivative -C -C OUTPUT: -C ======= -C Q .......... Saturation Specific Humidity -C DQDT ....... Saturation Specific Humidity Derivative wrt Temperature -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IMPLICIT NONE - REAL TT, P, Q, DQDT - LOGICAL LDQDT - REAL AIRMW, H2OMW - - PARAMETER ( AIRMW = 28.97 ) - PARAMETER ( H2OMW = 18.01 ) - - REAL ESFAC, ERFAC - PARAMETER ( ESFAC = H2OMW/AIRMW ) - PARAMETER ( ERFAC = (1.0-ESFAC)/ESFAC ) - - real aw0, aw1, aw2, aw3, aw4, aw5, aw6 - real bw0, bw1, bw2, bw3, bw4, bw5, bw6 - real ai0, ai1, ai2, ai3, ai4, ai5, ai6 - real bi0, bi1, bi2, bi3, bi4, bi5, bi6 - - real d0, d1, d2, d3, d4, d5, d6 - real e0, e1, e2, e3, e4, e5, e6 - real f0, f1, f2, f3, f4, f5, f6 - real g0, g1, g2, g3, g4, g5, g6 - -c ******************************************************** -c *** Polynomial Coefficients WRT Water (Lowe, 1977) **** -c *** (Valid +50 C to -50 C) **** -c ******************************************************** - - parameter ( aw0 = 6.107799961e+00 * esfac ) - parameter ( aw1 = 4.436518521e-01 * esfac ) - parameter ( aw2 = 1.428945805e-02 * esfac ) - parameter ( aw3 = 2.650648471e-04 * esfac ) - parameter ( aw4 = 3.031240396e-06 * esfac ) - parameter ( aw5 = 2.034080948e-08 * esfac ) - parameter ( aw6 = 6.136820929e-11 * esfac ) - - parameter ( bw0 = +4.438099984e-01 * esfac ) - parameter ( bw1 = +2.857002636e-02 * esfac ) - parameter ( bw2 = +7.938054040e-04 * esfac ) - parameter ( bw3 = +1.215215065e-05 * esfac ) - parameter ( bw4 = +1.036561403e-07 * esfac ) - parameter ( bw5 = +3.532421810e-10 * esfac ) - parameter ( bw6 = -7.090244804e-13 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice (Lowe, 1977) **** -c *** (Valid +0 C to -50 C) **** -c ******************************************************** - - parameter ( ai0 = +6.109177956e+00 * esfac ) - parameter ( ai1 = +5.034698970e-01 * esfac ) - parameter ( ai2 = +1.886013408e-02 * esfac ) - parameter ( ai3 = +4.176223716e-04 * esfac ) - parameter ( ai4 = +5.824720280e-06 * esfac ) - parameter ( ai5 = +4.838803174e-08 * esfac ) - parameter ( ai6 = +1.838826904e-10 * esfac ) - - parameter ( bi0 = +5.030305237e-01 * esfac ) - parameter ( bi1 = +3.773255020e-02 * esfac ) - parameter ( bi2 = +1.267995369e-03 * esfac ) - parameter ( bi3 = +2.477563108e-05 * esfac ) - parameter ( bi4 = +3.005693132e-07 * esfac ) - parameter ( bi5 = +2.158542548e-09 * esfac ) - parameter ( bi6 = +7.131097725e-12 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -40 C to -70 C) **** -c ******************************************************** - - - parameter ( d0 = 0.535098336e+01 * esfac ) - parameter ( d1 = 0.401390832e+00 * esfac ) - parameter ( d2 = 0.129690326e-01 * esfac ) - parameter ( d3 = 0.230325039e-03 * esfac ) - parameter ( d4 = 0.236279781e-05 * esfac ) - parameter ( d5 = 0.132243858e-07 * esfac ) - parameter ( d6 = 0.314296723e-10 * esfac ) - - parameter ( e0 = 0.469290530e+00 * esfac ) - parameter ( e1 = 0.333092511e-01 * esfac ) - parameter ( e2 = 0.102164528e-02 * esfac ) - parameter ( e3 = 0.172979242e-04 * esfac ) - parameter ( e4 = 0.170017544e-06 * esfac ) - parameter ( e5 = 0.916466531e-09 * esfac ) - parameter ( e6 = 0.210844486e-11 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -65 C to -95 C) **** -c ******************************************************** - - parameter ( f0 = 0.298152339e+01 * esfac ) - parameter ( f1 = 0.191372282e+00 * esfac ) - parameter ( f2 = 0.517609116e-02 * esfac ) - parameter ( f3 = 0.754129933e-04 * esfac ) - parameter ( f4 = 0.623439266e-06 * esfac ) - parameter ( f5 = 0.276961083e-08 * esfac ) - parameter ( f6 = 0.516000335e-11 * esfac ) - - parameter ( g0 = 0.312654072e+00 * esfac ) - parameter ( g1 = 0.195789002e-01 * esfac ) - parameter ( g2 = 0.517837908e-03 * esfac ) - parameter ( g3 = 0.739410547e-05 * esfac ) - parameter ( g4 = 0.600331350e-07 * esfac ) - parameter ( g5 = 0.262430726e-09 * esfac ) - parameter ( g6 = 0.481960676e-12 * esfac ) - - REAL TMAX, TICE - PARAMETER ( TMAX=323.15, TICE=273.16) - - REAL T, D, W, QX, DQX - T = MIN(TT,TMAX) - TICE - DQX = 0. - QX = 0. - -c Fitting for temperatures above 0 degrees centigrade -c --------------------------------------------------- - if(t.gt.0.) then - qx = aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6))))) - if (ldqdt) then - dqx = bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6))))) - endif - endif - -c Fitting for temperatures between 0 and -40 -c ------------------------------------------ - if( t.le.0. .and. t.gt.-40.0 ) then - w = (40.0 + t)/40.0 - qx = w *(aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6)))))) - . + (1.-w)*(ai0+T*(ai1+T*(ai2+T*(ai3+T*(ai4+T*(ai5+T*ai6)))))) - if (ldqdt) then - dqx = w *(bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6)))))) - . + (1.-w)*(bi0+T*(bi1+T*(bi2+T*(bi3+T*(bi4+T*(bi5+T*bi6)))))) - endif - endif - -c Fitting for temperatures between -40 and -70 -c -------------------------------------------- - if( t.le.-40.0 .and. t.ge.-70.0 ) then - qx = d0+T*(d1+T*(d2+T*(d3+T*(d4+T*(d5+T*d6))))) - if (ldqdt) then - dqx = e0+T*(e1+T*(e2+T*(e3+T*(e4+T*(e5+T*e6))))) - endif - endif - -c Fitting for temperatures less than -70 -c -------------------------------------- - if(t.lt.-70.0) then - qx = f0+t*(f1+t*(f2+t*(f3+t*(f4+t*(f5+t*f6))))) - if (ldqdt) then - dqx = g0+t*(g1+t*(g2+t*(g3+t*(g4+t*(g5+t*g6))))) - endif - endif - -c Compute Saturation Specific Humidity -c ------------------------------------ - D = (P-ERFAC*QX) - IF(D.LT.0.) THEN - Q = 1.0 - IF (LDQDT) DQDT = 0. - ELSE - D = 1.0 / D - Q = MIN(QX * D,1.0) - IF (LDQDT) DQDT = (1.0 + ERFAC*Q) * D * DQX - ENDIF - RETURN - END - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*undef - return - end - - subroutine getchar (name,num) - character*2 num2 - character*3 num3 - integer num - character*1 junk(256) - character*1 name(256) - data junk /256*' '/ - equivalence ( num2,junk ) - equivalence ( num3,junk ) - - num2 = ' ' - num3 = ' ' - - if( num.lt.100 ) then - write(num2,102) num - else if( num.lt.1000 ) then - write(num3,103) num - endif - - name = junk - - 102 format(i2.2) - 103 format(i3.3) - - return - end - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end - - function nsecf2 (nhhmmss,nmmdd,nymd) -C*********************************************************************** -C Purpose -C Computes the Total Number of seconds from NYMD using NHHMMSS & NMMDD -C -C Arguments Description -C NHHMMSS IntervaL Frequency (HHMMSS) -C NMMDD Interval Frequency (MMDD) -C NYMD Current Date (YYMMDD) -C -C NOTE: -C IF (NMMDD.ne.0), THEN HOUR FREQUENCY HH MUST BE < 24 -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - PARAMETER ( NSDAY = 86400 ) - PARAMETER ( NCYCLE = 1461*24*3600 ) - - INTEGER YEAR, DAY, SEC - - DIMENSION MNDY(12,4) - DATA MNDY /0,31,60,91,121,152,182,213,244,274,305,335,366, - . 397,34*0 / - -C*********************************************************************** -C* COMPUTE # OF SECONDS FROM NHHMMSS * -C*********************************************************************** - - nsecf2 = nsecf( nhhmmss ) - - if( nmmdd.eq.0 ) return - -C*********************************************************************** -C* COMPUTE # OF DAYS IN A 4-YEAR CYCLE * -C*********************************************************************** - - DO 100 I=15,48 - MNDY(I,1) = MNDY(I-12,1) + 365 -100 CONTINUE - -C*********************************************************************** -C* COMPUTE # OF SECONDS FROM NMMDD * -C*********************************************************************** - - nsegm = nmmdd/100 - nsegd = mod(nmmdd,100) - - YEAR = NYMD / 10000 - MONTH = MOD(NYMD,10000) / 100 - DAY = MOD(NYMD,100) - SEC = NSECF(NHMS) - - IDAY = MNDY( MONTH ,MOD(YEAR ,4)+1 ) - month = month + nsegm - If( month.gt.12 ) then - month = month - 12 - year = year + 1 - endif - IDAY2 = MNDY( MONTH ,MOD(YEAR ,4)+1 ) - - nday = iday2-iday - if(nday.lt.0) nday = nday + 1461 - nday = nday + nsegd - - nsecf2 = nsecf2 + nday*nsday - - return - end - - subroutine remap ( ps1,dp1,u1,v1,thv1,q1,phis1,lm1, - . ps2,dp2,u2,v2,t2 ,q2,phis2,lm2,im,jm,nq,pbelow,pabove ) - -C*********************************************************************** -C -C Purpose -C Driver for remapping of target analysis to fv model levels -C -C Argument Description -C ps1 ...... model surface pressure -C dp1 ...... model pressure thickness -C u1 ....... model zonal wind -C v1 ....... model meridional wind -C thv1 ..... model virtual potential temperature -C q1 ....... model specific humidity -C oz1 ...... model ozone -C phis1 .... model surface geopotential -C lm1 ...... model vertical dimension -C -C ps2 ...... analysis surface pressure -C dp2 ...... analysis pressure thickness -C u2 ....... analysis zonal wind -C v2 ....... analysis meridional wind -C t2 . ..... analysis dry-bulb temperature -C q2 ....... analysis specific humidity -C oz2 ...... analysis ozone -C phis2 .... analysis surface geopotential -C lm2 ...... analysis vertical dimension -C -C im ....... zonal dimension -C jm ....... meridional dimension -C nq ....... number of trancers -C pbelow ... pressure below which analysis is used completely -C pabove ... pressure above which model is used completely -C Note: a blend is used in-between pbelow and pabove -C If pbelow=pabove, blending code is disabled -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - integer im,jm,nq,lm1,lm2 - -c fv-DAS variables -c ---------------- - real dp1(im,jm,lm1), dp0(im,jm,lm1) - real u1(im,jm,lm1), u0(im,jm,lm1) - real v1(im,jm,lm1), v0(im,jm,lm1) - real thv1(im,jm,lm1), thv0(im,jm,lm1) - real q1(im,jm,lm1,nq), q0(im,jm,lm1,nq) - real ps1(im,jm), ps0(im,jm) - - real phis1(im,jm) - real ak(lm1+1) - real bk(lm1+1) - -c Target analysis variables -c ------------------------- - real dp2(im,jm,lm2) - real u2(im,jm,lm2) - real v2(im,jm,lm2) - real t2(im,jm,lm2) - real thv2(im,jm,lm2) - real q2(im,jm,lm2,nq) - real ps2(im,jm) - real phis2(im,jm) - -c Local variables -c --------------- - real pe0(im,jm,lm1+1) - real pe1(im,jm,lm1+1) - real pe2(im,jm,lm2+1) - real pk (im,jm,lm2 ) - real pke0(im,jm,lm1+1) - real pke1(im,jm,lm1+1) - real pke2(im,jm,lm2+1) - real phi2(im,jm,lm2+1) - - real kappa,cp,ptop,pbelow,pabove,pl,alf,pint - real rgas,pref,tref,pkref,tstar,eps,rvap,grav - integer i,j,L,n,ks - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - -c Compute edge-level pressure and pressure thickness (Using Ak,Bk) -c ---------------------------------------------------------------- - call set_eta ( lm1,ks,ptop,pint,ak,bk ) - - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1(i,j,L) = ak(L) + bk(L)*ps1(i,j) - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -c Compute edge-level pressures (Old Way) -c -------------------------------------- -c pe1(:,:,lm1+1) = ps1(:,:) -c do L=lm1,1,-1 -c pe1(:,:,L) = pe1(:,:,L+1)-dp1(:,:,L) -c enddo - -c Copy input fv state into local variables -c ---------------------------------------- - ps0(:,:) = ps1(:,:) - dp0(:,:,:) = dp1(:,:,:) - u0(:,:,:) = u1(:,:,:) - v0(:,:,:) = v1(:,:,:) - thv0(:,:,:) = thv1(:,:,:) - q0(:,:,:,:) = q1(:,:,:,:) - pe0(:,:,:) = pe1(:,:,:) - pke0(:,:,:) = pe0(:,:,:)**kappa - -c Construct target analysis pressure variables -c -------------------------------------------- - do j=1,jm - do i=1,im - pe2(i,j,lm2+1) = ps2(i,j) - enddo - enddo - - do L=lm2,1,-1 - do j=1,jm - do i=1,im - pe2(i,j,L) = pe2(i,j,L+1) - dp2(i,j,L) - enddo - enddo - enddo - - do j=1,jm - do i=1,im - pe2(i,j,1) = max( pe2(i,j,1),1.0 ) ! Set ptop = 0.01 mb (rather than 0.0 mb from NCEP) - enddo - enddo - - do L=1,lm2+1 - do j=1,jm - do i=1,im - pke2(i,j,L) = pe2(i,j,L)**kappa - enddo - enddo - enddo - -c Construct target virtual potential temperature -c ---------------------------------------------- - do L=1,lm2 - do j=1,jm - do i=1,im - pk (i,j,L) = ( pke2(i,j,L+1)-pke2(i,j,L) )/( kappa*log(pe2(i,j,L+1)/pe2(i,j,L)) ) - thv2(i,j,L) = t2(i,j,L)*( 1.0+eps*max(0.0,q2(i,j,L,1)) )/pk(i,j,L) - enddo - enddo - enddo - -c Construct target analysis heights -c --------------------------------- - phi2(:,:,lm2+1) = phis2(:,:) - do L=lm2,1,-1 - phi2(:,:,L) = phi2(:,:,L+1) + cp*thv2(:,:,L)*( pke2(:,:,L+1)-pke2(:,:,L) ) - enddo - -c Compute new surface pressure consistent with fv topography -c ---------------------------------------------------------- - do j=1,jm - do i=1,im - L = lm2 - do while ( phi2(i,j,L).lt.phis1(i,j) ) - L = L-1 - enddo - ps1(i,j) = pe2(i,j,L+1)*( 1+(phi2(i,j,L+1)-phis1(i,j))/(cp*thv2(i,j,L)*pke2(i,j,L+1)) )**(1.0/kappa) - enddo - enddo - -c Construct fv pressure variables using new surface pressure -c ---------------------------------------------------------- - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1(i,j,L) = ak(L) + bk(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -c Map original fv state onto new eta grid -c --------------------------------------- - print *, ' ReMapping Original FV-State onto New Eta Grid' - call gmap ( im,jm,nq, kappa, - . lm1, pke0, pe0, u1, v1, thv1, q1, - . lm1, pke1, pe1, u0, v0, thv0, q0) - -c Map target analysis onto fv grid -c -------------------------------- - print *, ' Mapping NCEP-State onto New Eta Grid' - call gmap ( im,jm,nq, kappa, - . lm2, pke2, pe2, u2, v2, thv2, q2, - . lm1, pke1, pe1, u1, v1, thv1, q1) - -c Blend result with original fv state -c ----------------------------------- - if( pbelow.ne.pabove ) then - print *, ' Blending FV and NCEP States' - do L=1,lm1 - do j=1,jm - do i=1,im - pl=0.5*(pe1(i,j,L+1)+pe1(i,j,L)) - alf=(pl-pabove)/(pbelow-pabove) - if( pl.lt.pabove ) then - u1(i,j,L) = u0(i,j,L) - v1(i,j,L) = v0(i,j,L) - thv1(i,j,L) = thv0(i,j,L) - else if( pl.lt.pbelow ) then - u1(i,j,L) = u1(i,j,L)*alf + u0(i,j,L)*(1-alf) - v1(i,j,L) = v1(i,j,L)*alf + v0(i,j,L)*(1-alf) - thv1(i,j,L) = thv1(i,j,L)*alf + thv0(i,j,L)*(1-alf) - endif - enddo - enddo - enddo - do n=1,nq - do L=1,lm1 - do j=1,jm - do i=1,im - pl=0.5*(pe1(i,j,L+1)+pe1(i,j,L)) - alf=(pl-pabove)/(pbelow-pabove) - if( pl.lt.pabove ) then - q1(i,j,L,n) = q0(i,j,L,n) - else if( pl.lt.pbelow ) then - q1(i,j,L,n) = q1(i,j,L,n)*alf + q0(i,j,L,n)*(1-alf) - endif - enddo - enddo - enddo - enddo - endif - - return - end - - subroutine gauss_lat_nmc(gaul,k) - implicit double precision (a-h,o-z) - dimension a(500) - real gaul(1) - save - esp=1.d-14 - c=(1.d0-(2.d0/3.14159265358979d0)**2)*0.25d0 - fk=k - kk=k/2 - call bsslz1(a,kk) - do 30 is=1,kk - xz=cos(a(is)/sqrt((fk+0.5d0)**2+c)) - iter=0 - 10 pkm2=1.d0 - pkm1=xz - iter=iter+1 - if(iter.gt.10) go to 70 - do 20 n=2,k - fn=n - pk=((2.d0*fn-1.d0)*xz*pkm1-(fn-1.d0)*pkm2)/fn - pkm2=pkm1 - 20 pkm1=pk - pkm1=pkm2 - pkmrk=(fk*(pkm1-xz*pk))/(1.d0-xz**2) - sp=pk/pkmrk - xz=xz-sp - avsp=abs(sp) - if(avsp.gt.esp) go to 10 - a(is)=xz - 30 continue - if(k.eq.kk*2) go to 50 - a(kk+1)=0.d0 - pk=2.d0/fk**2 - do 40 n=2,k,2 - fn=n - 40 pk=pk*fn**2/(fn-1.d0)**2 - 50 continue - do 60 n=1,kk - l=k+1-n - a(l)=-a(n) - 60 continue - radi=180./(4.*atan(1.)) - do 211 n=1,k - gaul(n)=acos(a(n))*radi-90.0 - 211 continue - return - 70 write(6,6000) - 6000 format(//5x,14herror in gauaw//) - stop - end - - subroutine bsslz1(bes,n) - implicit double precision (a-h,o-z) - dimension bes(n) - dimension bz(50) - data pi/3.14159265358979d0/ - data bz / 2.4048255577d0, 5.5200781103d0, - $ 8.6537279129d0,11.7915344391d0,14.9309177086d0,18.0710639679d0, - $ 21.2116366299d0,24.3524715308d0,27.4934791320d0,30.6346064684d0, - $ 33.7758202136d0,36.9170983537d0,40.0584257646d0,43.1997917132d0, - $ 46.3411883717d0,49.4826098974d0,52.6240518411d0,55.7655107550d0, - $ 58.9069839261d0,62.0484691902d0,65.1899648002d0,68.3314693299d0, - $ 71.4729816036d0,74.6145006437d0,77.7560256304d0,80.8975558711d0, - $ 84.0390907769d0,87.1806298436d0,90.3221726372d0,93.4637187819d0, - $ 96.6052679510d0,99.7468198587d0,102.888374254d0,106.029930916d0, - $ 109.171489649d0,112.313050280d0,115.454612653d0,118.596176630d0, - $ 121.737742088d0,124.879308913d0,128.020877005d0,131.162446275d0, - $ 134.304016638d0,137.445588020d0,140.587160352d0,143.728733573d0, - $ 146.870307625d0,150.011882457d0,153.153458019d0,156.295034268d0/ - nn=n - if(n.le.50) go to 12 - bes(50)=bz(50) - do 5 j=51,n - 5 bes(j)=bes(j-1)+pi - nn=49 - 12 do 15 j=1,nn - 15 bes(j)=bz(j) - return - end - - - subroutine get_ozone ( ozone,pl,im,jm,lm,nymd,nhms ) - implicit none - - integer nlats - integer nlevs - parameter ( nlats = 37 ) ! 37 Latitudes - parameter ( nlevs = 34 ) ! 34 Pressure Levels - - real o3(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - -c Input Variables -c --------------- - integer im,jm,lm,nymd,nhms - real ozone(im,jm,lm) - real pl(im,jm,lm) - -c Local Variables -c --------------- - real xlat(im,jm) - integer i,j,koz - - real voltomas - PARAMETER ( VOLTOMAS = 1.655E-6 ) - - koz = 40 - - do j=1,jm - do i=1,im - xlat(i,j) = -90. + (j-1)*180./(jm-1) - enddo - enddo - - call chemistry (koz,nymd,nhms,o3,lats,levs,nlats,nlevs) - call interp_oz (o3,lats,levs,nlats,nlevs,im*jm,xlat,lm,pl,ozone) - - ozone(:,:,:) = ozone(:,:,:) * VOLTOMAS - - return - end - - subroutine chemistry (koz,nymd,nhms,ozone,lats,levs,nlats,nlevs) -C*********************************************************************** -C PURPOSE -C Chemistry Model -C -C ARGUMENTS DESCRIPTION -C koz Unit to read Stratospheric Ozone -C kqz Unit to read Stratospheric Moisture -C nymd Current Date -C nhms Current Time -C -C chemistry .. Chemistry State Data Structure -C grid ....... Dynamics Grid Data Structure -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer koz - integer nymd,nhms - - integer nlats - integer nlevs - real ozone(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - real o3(nlats,nlevs,12) - -c Local Variables -c --------------- - integer j,L - integer nymd1,nhms1,nymd2,nhms2,ipls,imns - real facm,facp - -C ********************************************************************** -C **** Read Ozone and Moisture Data (12 Monthly Means) **** -C ********************************************************************** - - call read_oz (koz,o3,lats,levs,nlats,nlevs,12) - -C ********************************************************************** -C **** Update Chemistry State to Current Time **** -C ********************************************************************** - - call time_bound ( nymd, nymd1,nhms1, nymd2,nhms2, imns,ipls ) - call interp_time ( nymd,nhms, nymd1,nhms1, nymd2,nhms2, facm,facp ) - - do L = 1,nlevs - do j = 1,nlats - ozone(j,L) = o3(j,L,imns)*facm + o3(j,L,ipls)*facp - enddo - enddo - - return - end - - subroutine read_oz (ku,oz,lats,levs,nlat,nlev,ntime) -C*********************************************************************** -C PURPOSE -C To Read Ozone Value -C -C ARGUMENTS DESCRIPTION -C ku ...... Unit to Read Ozone Data -C oz ...... Ozone Data -C lats .... Ozone Data Latitudes (degrees) -C levs .... Ozone Data Levels (mb) -C nlat .... Number of ozone latitudes -C nlev .... Number of ozone levels -C ntime ... Number of ozone time values -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer ku,nlat,nlev,ntime - - real oz(nlat,nlev,ntime) - real*4 o3(nlat) - real lats(nlat) - real levs(nlev) - - integer time - integer lat - integer lev - integer nrec - - real plevs(34) - data plevs/ 0.003, 0.005, 0.007, 0.01, 0.015, 0.02, 0.03, 0.05, - . 0.07, 0.1, 0.15, 0.2, 0.3, 0.5, 0.7, 1.0, 1.5, 2.0, - . 3.0, 5.0, 7.0, 10.0, 15.0, 20.0, 30.0, 50.0, 70.0, - . 100.0, 150.0, 200.0, 300.0, 500.0, 700.0, 1000.0 / - - rewind ku - -c Set Ozone Data Latitudes -c ------------------------ - do lat = 1,nlat - lats(lat) = -90. + (lat-1)*5. - enddo - -c Set Ozone Data Levels -c ------------------------ - do lev = 1,nlev - levs(lev) = plevs(lev)*100 - enddo - -c Read Ozone Amounts by Month and Level -c ------------------------------------- - close (ku) - open (ku, file="/home/ltakacs/data/bcs/TSMo3.v02.gra", - . form='unformatted', access='direct', recl=nlat*4) - - do time=1,ntime - do lev=1,nlev - nrec = lev+(time-1)*nlev*2 ! Note: 2 quantities in Ozone Dataset - read(ku,rec=nrec) o3 - do lat=1,nlat - oz(lat,nlev-lev+1,time) = o3(lat) - enddo - enddo - enddo - - close (ku) - return - end - - subroutine interp_oz (ozone,lats,levs,nlats,nlevs,irun ,xlat,km,plevs,ozrad) - -c Declare Modules and Data Structures -c ----------------------------------- - implicit none - integer nlats,nlevs - real ozone(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - - integer irun,km - real xlat (irun) - real plevs (irun,km) - real ozrad (irun,km) - -c Local Variables -c --------------- - real zero,one,o3min - PARAMETER ( ZERO = 0.0 ) - PARAMETER ( ONE = 1.0 ) - PARAMETER ( O3MIN = 1.0E-10 ) - - integer i,k,L1,L2,LM,LP - integer jlat,jlatm,jlatp - real O3INT1(IRUN,nlevs) - real QPR1(IRUN), QPR2(IRUN), SLOPE(IRUN) - real PR1(IRUN), PR2(IRUN) - -C ********************************************************************** -C **** INTERPOLATE ozone data to model latitudes *** -C ********************************************************************** - - DO 32 K=1,nlevs - DO 34 I=1,IRUN - - DO 36 jlat = 1,nlats - IF( lats(jlat).gt.xlat(i) ) THEN - IF( jlat.EQ.1 ) THEN - jlatm = 1 - jlatp = 1 - slope(i) = zero - ELSE - jlatm = jlat-1 - jlatp = jlat - slope(i) = ( XLAT(I) -lats(jlat-1) ) - . / ( lats(jlat)-lats(jlat-1) ) - ENDIF - GOTO 37 - ENDIF - 36 CONTINUE - jlatm = nlats - jlatp = nlats - slope(i) = one - 37 CONTINUE - QPR1(I) = ozone(jlatm,k) - QPR2(I) = ozone(jlatp,k) - 34 CONTINUE - - DO 38 I=1,IRUN - o3int1(i,k) = qpr1(i) + slope(i)*( qpr2(i)-qpr1(i) ) - 38 CONTINUE - - 32 CONTINUE - -C ********************************************************************** -C **** INTERPOLATE latitude ozone data to model pressures *** -C ********************************************************************** - - DO 40 L2 = 1,km - - DO 44 I = 1,IRUN - DO 46 L1 = 1,nlevs - IF( levs(L1).GT.PLEVS(I,L2) ) THEN - IF( L1.EQ.1 ) THEN - LM = 1 - LP = 2 - ELSE - LM = L1-1 - LP = L1 - ENDIF - GOTO 47 - ENDIF - 46 CONTINUE - LM = nlevs-1 - LP = nlevs - 47 CONTINUE - PR1(I) = levs (LM) - PR2(I) = levs (LP) - QPR1(I) = O3INT1(I,LM) - QPR2(I) = O3INT1(I,LP) - 44 CONTINUE - - DO 48 I=1,IRUN - SLOPE(I) = ( QPR1(I)-QPR2(I) ) - . / ( PR1(I)- PR2(I) ) - ozrad(I,L2) = QPR2(I) + ( PLEVS(I,L2)-PR2(I) )*SLOPE(I) - - if( ozrad(i,l2).lt.o3min ) then - ozrad(i,l2) = o3min - endif - - 48 CONTINUE - 40 CONTINUE - - RETURN - END - - subroutine interp_time ( nymd ,nhms , - . nymd1,nhms1, nymd2,nhms2, fac1,fac2 ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute interpolation factors, fac1 & fac2, to be used in the -C calculation of the instantanious boundary conditions, ie: -C -C q(i,j) = fac1*q1(i,j) + fac2*q2(i,j) -C where: -C q(i,j) => Boundary Data valid at (nymd , nhms ) -C q1(i,j) => Boundary Data centered at (nymd1 , nhms1) -C q2(i,j) => Boundary Data centered at (nymd2 , nhms2) -C -C INPUT: -C ====== -C nymd : Date (yymmdd) of Current Timestep -C nhms : Time (hhmmss) of Current Timestep -C nymd1 : Date (yymmdd) of Boundary Data 1 -C nhms1 : Time (hhmmss) of Boundary Data 1 -C nymd2 : Date (yymmdd) of Boundary Data 2 -C nhms2 : Time (hhmmss) of Boundary Data 2 -C -C OUTPUT: -C ======= -C fac1 : Interpolation factor for Boundary Data 1 -C fac2 : Interpolation factor for Boundary Data 2 -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER YEAR , MONTH , DAY , SEC - INTEGER YEAR1, MONTH1, DAY1, SEC1 - INTEGER YEAR2, MONTH2, DAY2, SEC2 - - real fac1, fac2 - real time, time1, time2 - - INTEGER DAYSCY - PARAMETER (DAYSCY = 365*4+1) - - REAL MNDY(12,4) - - LOGICAL FIRST - DATA FIRST/.TRUE./ - - DATA MNDY /0,31,60,91,121,152,182,213,244,274,305,335,366, - . 397,34*0 / - -C*********************************************************************** -C* SET TIME BOUNDARIES * -C*********************************************************************** - - YEAR = NYMD / 10000 - MONTH = MOD(NYMD,10000) / 100 - DAY = MOD(NYMD,100) - SEC = NSECF(NHMS) - - YEAR1 = NYMD1 / 10000 - MONTH1 = MOD(NYMD1,10000) / 100 - DAY1 = MOD(NYMD1,100) - SEC1 = NSECF(NHMS1) - - YEAR2 = NYMD2 / 10000 - MONTH2 = MOD(NYMD2,10000) / 100 - DAY2 = MOD(NYMD2,100) - SEC2 = NSECF(NHMS2) - -C*********************************************************************** -C* COMPUTE DAYS IN 4-YEAR CYCLE * -C*********************************************************************** - - IF(FIRST) THEN - DO I=15,48 - MNDY(I,1) = MNDY(I-12,1) + 365 - ENDDO - FIRST=.FALSE. - ENDIF - -C*********************************************************************** -C* COMPUTE INTERPOLATION FACTORS * -C*********************************************************************** - - time = DAY + MNDY(MONTH ,MOD(YEAR ,4)+1) + float(sec )/86400. - time1 = DAY1 + MNDY(MONTH1,MOD(YEAR1,4)+1) + float(sec1)/86400. - time2 = DAY2 + MNDY(MONTH2,MOD(YEAR2,4)+1) + float(sec2)/86400. - - if( time .lt.time1 ) time = time + dayscy - if( time2.lt.time1 ) time2 = time2 + dayscy - - fac1 = (time2-time)/(time2-time1) - fac2 = (time-time1)/(time2-time1) - - RETURN - END - - subroutine time_bound ( nymd,nymd1,nhms1,nymd2,nhms2, imnm,imnp ) -C*********************************************************************** -C PURPOSE -C Compute Date and Time boundaries. -C -C ARGUMENTS DESCRIPTION -C nymd .... Current Date -C nymd1 ... Previous Date Boundary -C nhms1 ... Previous Time Boundary -C nymd2 ... Subsequent Date Boundary -C nhms2 ... Subsequent Time Boundary -C -C imnm .... Previous Time Index for Interpolation -C imnp .... Subsequent Time Index for Interpolation -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer nymd, nymd1,nhms1, nymd2,nhms2 - -c Local Variables -c --------------- - integer month,day,nyear,midmon1,midmon,midmon2 - integer imnm,imnp - INTEGER DAYS(14), daysm, days0, daysp - DATA DAYS /31,31,28,31,30,31,30,31,31,30,31,30,31,31/ - - integer nmonf,ndayf,n - NMONF(N) = MOD(N,10000)/100 - NDAYF(N) = MOD(N,100) - -C********************************************************************* -C**** Find Proper Month and Time Boundaries for Climatological Data ** -C********************************************************************* - - MONTH = NMONF(NYMD) - DAY = NDAYF(NYMD) - - daysm = days(month ) - days0 = days(month+1) - daysp = days(month+2) - -c Check for Leap Year -c ------------------- - nyear = nymd/10000 - if( 4*(nyear/4).eq.nyear ) then - if( month.eq.3 ) daysm = daysm+1 - if( month.eq.2 ) days0 = days0+1 - if( month.eq.1 ) daysp = daysp+1 - endif - - MIDMON1 = daysm/2 + 1 - MIDMON = days0/2 + 1 - MIDMON2 = daysp/2 + 1 - - - IF(DAY.LT.MIDMON) THEN - imnm = month - imnp = month + 1 - nymd2 = (nymd/10000)*10000 + month*100 + midmon - nhms2 = 000000 - nymd1 = nymd2 - nhms1 = nhms2 - call tick ( nymd1,nhms1, -midmon *86400 ) - call tick ( nymd1,nhms1,-(daysm-midmon1)*86400 ) - ELSE - IMNM = MONTH + 1 - IMNP = MONTH + 2 - nymd1 = (nymd/10000)*10000 + month*100 + midmon - nhms1 = 000000 - nymd2 = nymd1 - nhms2 = nhms1 - call tick ( nymd2,nhms2,(days0-midmon)*86400 ) - call tick ( nymd2,nhms2, midmon2*86400 ) - ENDIF - -c ------------------------------------------------------------- -c Note: At this point, imnm & imnp range between 01-14, where -c 01 -> Previous years December -c 02-13 -> Current years January-December -c 14 -> Next years January -c ------------------------------------------------------------- - - imnm = imnm-1 - imnp = imnp-1 - - if( imnm.eq.0 ) imnm = 12 - if( imnp.eq.0 ) imnp = 12 - if( imnm.eq.13 ) imnm = 1 - if( imnp.eq.13 ) imnp = 1 - - return - end - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - END - - FUNCTION INCYMD (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - - RETURN - END - - subroutine usage() - print *, "Usage: " - print * - print *, " gg2fv.x [-ncep ncep.data]" - print *, " [-ctl ncep.ctl]" - print *, " [-ana eta.data]" - print *, " [-nymd nymd]" - print *, " [-nhms nhms]" - print *, " [-plow plow]" - print *, " [-phigh phigh]" - print *, " [-tag tag]" - print *, " [-ozone]" - print * - print *, "where:" - print * - print *, " -ncep ncep.data: Filename of NCEP sigma-level analysis data (from ss2gg)" - print *, " -ctl ncep.ctl : Filename of NCEP sigma-level analysis ctl (from ss2gg)" - print *, " -ana eta.data: Filename of GMAO Background Data (ana.eta format)" - print * - print *, " -plow plow: Pressure Level to begin blending" - print *, " -phigh phigh: Pressure Level to end blending" - print * - print *, " -nymd nymd: Desired date in yyyymmdd format" - print *, " -nhms nhms: Desired time in hhmmss format" - print * - print *, " -tag tag: Optional Prefix tag for output files" - print *, " -ozone Optional Flag to add ozone" - print * - error stop 7 - end - - subroutine interp_h ( q_cmp,im,jm,lm, - . dlam,dphi,rotation,tilt,precession, - . q_geo,irun,lon_geo,lat_geo, - . msgn,norder,check,undef ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C rotation ... Rotation parameter lam_np (Degrees) -C tilt ....... Rotation parameter phi_np (Degrees) -C precession . Rotation parameter lam_0 (Degrees) -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C msgn ....... Flag for scalar field ( msgn = 1 ) -C or vector component ( msgn = -1 ) -C norder ..... Order of Interpolation: Bi-Linear => abs(norder) = 1 -C Bi-Cubic => abs(norder) = 3 -C Note: If norder < 0, then check for positive definite -C check ...... Logical Flag to check for Undefined values -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun,norder,msgn - logical check - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - -c Local Variables -c --------------- - integer i,j,l,m,n - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - - integer ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1 - integer ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2 - integer jm2_for_jm2, jp1_for_jp1 - - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real, allocatable :: old_lon (:) - real, allocatable :: old_lat (:) - real, allocatable :: old_dlam(:) - real, allocatable :: old_dphi(:) - - real ap1, ap0, am1, am2 - real bp1, bp0, bm1, bm2 - - real lon_cmp(im) - real lat_cmp(jm) - real q_tmp(irun) - - real pi,cosnp,sinnp,p1,p2,p3,eps,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp,lam_np,phi_np,lam_0,eps_np - real rotation , tilt , precession - real lam_geo, lam_cmp - real phi_geo, phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - - logical compute_weights - real old_rotation - real old_tilt - real old_precession - data old_rotation /-999.9/ - data old_tilt /-999.9/ - data old_precession /-999.9/ - - parameter ( eps = 1.e-10 ) - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - if(.not.allocated(old_lon)) then - - allocate ( old_dlam(im) , old_dphi(jm) ) - allocate ( old_lon(irun) , old_lat(irun) ) - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - do i=1,irun - old_lon(i) = -999.9 - old_lat(i) = -999.9 - enddo - do i=1,im - old_dlam(i) = 0.0 - enddo - do j=1,jm - old_dphi(j) = 0.0 - enddo - - else - i = size (old_dlam) - j = size (old_dphi) - m = size (old_lon) - if(i.ne.im .or. j.ne.jm .or. m.ne.irun) then - deallocate ( old_dlam , old_dphi ) - deallocate ( old_lon , old_lat ) - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - allocate ( old_dlam(im) , old_dphi(jm) ) - allocate ( old_lon(irun) , old_lat(irun) ) - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - do i=1,irun - old_lon(i) = -999.9 - old_lat(i) = -999.9 - enddo - do i=1,im - old_dlam(i) = 0.0 - enddo - do j=1,jm - old_dphi(j) = 0.0 - enddo - endif - endif - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Check for Co-incident Grid-Point Latitude and Pole Locations -c ------------------------------------------------------------ - eps_np = 0.0 - do j=1,jm - phi_cmp = lat_cmp(j)*180./pi - if( abs( phi_cmp-tilt ).lt.1.e-3 ) eps_np = 1.e-3 - if( tilt+eps_np .gt. 90. ) eps_np = -1.e-3 - enddo - - lam_np = pi/180.*rotation - phi_np = pi/180.*(tilt+eps_np) - lam_0 = pi/180.*precession - - if( tilt.eq.90. ) then - cosnp = 0.0 - sinnp = 1.0 - else if(tilt.eq.-90.0) then - cosnp = 0.0 - sinnp =-1.0 - else - cosnp = cos(phi_np) - sinnp = sin(phi_np) - endif - -c Determine if Weights Need to be Updated -c --------------------------------------- - compute_weights = rotation.ne.old_rotation .or. - . tilt.ne.old_tilt .or. - . precession.ne.old_precession - - m = 1 - do while ( .not.compute_weights .and. m.le.irun ) - compute_weights = (lon_geo(m).ne.old_lon(m)) .or. - . (lat_geo(m).ne.old_lat(m)) - m = m+1 - enddo - i = 1 - do while ( .not.compute_weights .and. i.le.im ) - compute_weights = dlam(i).ne.old_dlam(i) - i = i+1 - enddo - j = 1 - do while ( .not.compute_weights .and. j.le.jm-1 ) - compute_weights = dphi(j).ne.old_dphi(j) - j = j+1 - enddo - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - if( compute_weights ) then - - old_rotation = rotation - old_tilt = tilt - old_precession = precession - -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (i,lam_geo,phi_geo,lam_cmp,phi_cmp,lam,phi) -!$omp& private (p1,p2,p3,d,icmp,jcmp,im1_cmp,jm1_cmp) -!$omp& private (lam_im2, lam_im1, lam_ip0, lam_ip1) -!$omp& private (phi_jm2, phi_jm1, phi_jp0, phi_jp1) -!$omp& private (ap1, ap0, am1, am2) -!$omp& private (bp1, bp0, bm1, bm2) -#endif - do i=1,irun - old_lon(i) = lon_geo(i) - old_lat(i) = lat_geo(i) - lam_geo = lon_geo(i) - phi_geo = lat_geo(i) - - p1 = cosnp*cos(phi_geo)*cos(lam_geo+lam_0-pi) - . + sin(phi_geo)*sinnp - p1 = min(p1, 1.0) - p1 = max(p1,-1.0) - phi_cmp = asin( p1 ) - - if( tilt.eq.90.0 .or. tilt.eq.-90.0 ) then - p2 = sinnp*cos(lam_geo+lam_0-pi) - else - p2 = sinnp*cos(phi_geo)*cos(lam_geo+lam_0-pi) - . - sin(phi_geo)*cosnp - p2 = p2 / max( cos(phi_cmp),eps ) - p2 = min(p2, 1.0) - p2 = max(p2,-1.0) - endif - p2 = acos( p2 ) - - p3 = cos(phi_geo)*sin(lam_geo+lam_0-pi) - if( p3.lt.0.0 ) p2 = -p2 - p2 = p2 + lam_np - pi - lam_cmp = mod( p2+3.0*pi,2.0*pi ) - pi - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm2 = lat_cmp(jm2(i)) - phi_jm1 = lat_cmp(jm1(i)) - phi_jp0 = lat_cmp(jp0(i)) - phi_jp1 = lat_cmp(jp1(i)) - - if( jm2(i).eq.0 ) phi_jm2 = phi_jm1 - dphi(1) - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - endif - if( jp1(i).eq.jm+1 ) phi_jp1 = phi_jp0 + dphi(jm-1) - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - endif - -c Interpolate Computational-Grid Quantities to Geophysical Grid Using Bi-Linear -c ----------------------------------------------------------------------------- - if( abs(norder).eq.1 ) then - - if( check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,q_tmp) -#endif - do L=1,lm - do i=1,irun - - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - if( .not.check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,q_tmp) -#endif - do L=1,lm - do i=1,irun - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - endif ! End Check for Bi-Linear Interpolation - - -c Interpolate Computational-Grid Quantities to Geophysical Grid Using Bi-Cubic -c ---------------------------------------------------------------------------- - if( abs(norder).eq.3 ) then - - if( check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,m,n,q_tmp) -!$omp& private (ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1) -!$omp& private (ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2) -!$omp& private (jp1_for_jp1, jm2_for_jm2) -#endif - do L=1,lm - do i=1,irun - - ip1_for_jp1 = ip1(i) - ip0_for_jp1 = ip0(i) - im1_for_jp1 = im1(i) - im2_for_jp1 = im2(i) - jp1_for_jp1 = jp1(i) - m = 1 - - if( jp0(i).eq.jm ) then - ip1_for_jp1 = 1 + mod( ip1_for_jp1 + im/2 -1, im ) - ip0_for_jp1 = 1 + mod( ip0_for_jp1 + im/2 -1, im ) - im1_for_jp1 = 1 + mod( im1_for_jp1 + im/2 -1, im ) - im2_for_jp1 = 1 + mod( im2_for_jp1 + im/2 -1, im ) - jp1_for_jp1 = jm-1 - if(msgn.eq.-1) m=-1 - endif - - ip1_for_jm2 = ip1(i) - ip0_for_jm2 = ip0(i) - im1_for_jm2 = im1(i) - im2_for_jm2 = im2(i) - jm2_for_jm2 = jm2(i) - n = 1 - - if( jm1(i).eq.1 ) then - ip1_for_jm2 = 1 + mod( ip1_for_jm2 + im/2 -1, im ) - ip0_for_jm2 = 1 + mod( ip0_for_jm2 + im/2 -1, im ) - im1_for_jm2 = 1 + mod( im1_for_jm2 + im/2 -1, im ) - im2_for_jm2 = 1 + mod( im2_for_jm2 + im/2 -1, im ) - jm2_for_jm2 = 2 - if(msgn.eq.-1) n=-1 - endif - - - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1_for_jm2,jm2_for_jm2,L ).ne.undef .and. - . q_cmp( ip0_for_jm2,jm2_for_jm2,L ).ne.undef .and. - . q_cmp( im1_for_jm2,jm2_for_jm2,L ).ne.undef .and. - . q_cmp( im2_for_jm2,jm2_for_jm2,L ).ne.undef .and. - - . q_cmp( ip1_for_jp1,jp1_for_jp1,L ).ne.undef .and. - . q_cmp( ip0_for_jp1,jp1_for_jp1,L ).ne.undef .and. - . q_cmp( im1_for_jp1,jp1_for_jp1,L ).ne.undef .and. - . q_cmp( im2_for_jp1,jp1_for_jp1,L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1_for_jp1,jp1_for_jp1,L )*m - . + wc_ip0jp1(i) * q_cmp( ip0_for_jp1,jp1_for_jp1,L )*m - . + wc_im1jp1(i) * q_cmp( im1_for_jp1,jp1_for_jp1,L )*m - . + wc_im2jp1(i) * q_cmp( im2_for_jp1,jp1_for_jp1,L )*m - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1_for_jm2,jm2_for_jm2,L )*n - . + wc_ip0jm2(i) * q_cmp( ip0_for_jm2,jm2_for_jm2,L )*n - . + wc_im1jm2(i) * q_cmp( im1_for_jm2,jm2_for_jm2,L )*n - . + wc_im2jm2(i) * q_cmp( im2_for_jm2,jm2_for_jm2,L )*n - - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - enddo - -c Check for Positive Definite -c --------------------------- - if( norder.lt.0 ) then - do i=1,irun - if( q_tmp(i).ne.undef .and. - . q_tmp(i).lt.0.0 ) then - q_tmp(i) = 0.0 - endif - enddo - endif - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - if( .not.check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,m,n,q_tmp) -!$omp& private (ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1) -!$omp& private (ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2) -!$omp& private (jp1_for_jp1, jm2_for_jm2) -#endif - do L=1,lm - do i=1,irun - - ip1_for_jp1 = ip1(i) - ip0_for_jp1 = ip0(i) - im1_for_jp1 = im1(i) - im2_for_jp1 = im2(i) - jp1_for_jp1 = jp1(i) - m = 1 - - if( jp0(i).eq.jm ) then - ip1_for_jp1 = 1 + mod( ip1_for_jp1 + im/2 -1, im ) - ip0_for_jp1 = 1 + mod( ip0_for_jp1 + im/2 -1, im ) - im1_for_jp1 = 1 + mod( im1_for_jp1 + im/2 -1, im ) - im2_for_jp1 = 1 + mod( im2_for_jp1 + im/2 -1, im ) - jp1_for_jp1 = jm-1 - if(msgn.eq.-1) m=-1 - endif - - ip1_for_jm2 = ip1(i) - ip0_for_jm2 = ip0(i) - im1_for_jm2 = im1(i) - im2_for_jm2 = im2(i) - jm2_for_jm2 = jm2(i) - n = 1 - - if( jm1(i).eq.1 ) then - ip1_for_jm2 = 1 + mod( ip1_for_jm2 + im/2 -1, im ) - ip0_for_jm2 = 1 + mod( ip0_for_jm2 + im/2 -1, im ) - im1_for_jm2 = 1 + mod( im1_for_jm2 + im/2 -1, im ) - im2_for_jm2 = 1 + mod( im2_for_jm2 + im/2 -1, im ) - jm2_for_jm2 = 2 - if(msgn.eq.-1) n=-1 - endif - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1_for_jp1,jp1_for_jp1,L )*m - . + wc_ip0jp1(i) * q_cmp( ip0_for_jp1,jp1_for_jp1,L )*m - . + wc_im1jp1(i) * q_cmp( im1_for_jp1,jp1_for_jp1,L )*m - . + wc_im2jp1(i) * q_cmp( im2_for_jp1,jp1_for_jp1,L )*m - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1_for_jm2,jm2_for_jm2,L )*n - . + wc_ip0jm2(i) * q_cmp( ip0_for_jm2,jm2_for_jm2,L )*n - . + wc_im1jm2(i) * q_cmp( im1_for_jm2,jm2_for_jm2,L )*n - . + wc_im2jm2(i) * q_cmp( im2_for_jm2,jm2_for_jm2,L )*n - - enddo - -c Check for Positive Definite -c --------------------------- - if( norder.lt.0 ) then - do i=1,irun - if( q_tmp(i).ne.undef .and. - . q_tmp(i).lt.0.0 ) then - q_tmp(i) = 0.0 - endif - enddo - endif - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - endif ! End Check for Bi-Cubic Interpolation - - deallocate ( old_dlam , old_dphi ) - deallocate ( old_lon , old_lat ) - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - return - end - - subroutine get_slp ( ps,phis,slp,pe,pk,tv,rgas,grav,im,jm,km ) - implicit none - integer im,jm,km - real grav - real rgas - real pk(im,jm,km) ! layer-mean P**kappa - real tv(im,jm,km) ! layer-mean virtual Temperature - real pe(im,jm,km+1) ! press at layer edges (Pa) - real ps(im,jm) ! surface pressure (Pa) - real phis(im,jm) ! surface geopotential - real slp(im,jm) ! sea-level pressure (hPa) - - real p_offset - real p_bot - real tstar ! extrapolated temperature (K) - real tref ! Reference virtual temperature (K) - real pref ! Reference pressure level (Pa) - real pkref ! Reference pressure level (Pa) ** kappa - real dp1, dp2 - real factor, yfactor - real gg - real gamma - integer k_bot, k, k1, k2, i,j - - gamma = 6.5e-3 - gg = gamma / grav - factor = grav / ( Rgas * gamma ) - yfactor = Rgas * gg - p_offset = 15000. ! 150 hPa above surface - - do j=1,jm - do i=1,im - p_bot = ps(i,j) - p_offset - k_bot = -1 - do k = km, 2, -1 - if ( pe(i,j,k+1) .lt. p_bot ) then - k_bot = k - go to 123 - endif - enddo -123 continue - k1 = k_bot - 1 - k2 = k_bot - dp1 = pe(i,j,k_bot) - pe(i,j,k_bot-1) - dp2 = pe(i,j,k_bot+1) - pe(i,j,k_bot) - pkref = ( pk(i,j,k1)*dp1 + pk(i,j,k2)*dp2 ) / (dp1+dp2) - tref = ( tv(i,j,k1)*dp1 + tv(i,j,k2)*dp2 ) / (dp1+dp2) - pref = 0.5 * ( pe(i,j,k_bot+1) + pe(i,j,k_bot-1) ) - tstar = tref*( ps(i,j)/pref )**yfactor - slp(i,j) = ps(i,j)*( 1.0+gg*phis(i,j)/tstar )**factor - enddo - enddo - - return - end - -C ********************************************************************** -C **** Read Grads CTL File for Meta Data **** -C ********************************************************************** - - subroutine read_ctl ( ctlfile,im,jm,lm,undef,format, - . nvars,names,descs,lmvars, - . lats,lons ) - implicit none - - character*256, pointer :: names(:) - character*256, pointer :: descs(:) - integer, pointer :: lmvars(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - - character*256 ctlfile, format - integer im,jm,lm,nvars - real undef,dx,dy - integer i,j,m,n,ndum - character*256 dummy - character*256, allocatable :: dum(:) - - open (10,file=trim(ctlfile),form='formatted') - format = 'direct' - do - read(10,*,end=500) dummy - -c OPTIONS -c ------- - if( trim(dummy).eq.'options' ) then - ndum = 1 - do - backspace(10) - allocate ( dum(ndum) ) - read(10,*,err=101) dummy - if( trim(dummy).eq.'options' ) then - backspace(10) - read(10,*,end=101) dummy,( dum(n),n=1,ndum ) - else - goto 101 - endif - if( trim(dum(ndum)).eq.'sequential' ) format = 'sequential' - deallocate ( dum ) - ndum = ndum + 1 - enddo - 100 format(a5) - 101 continue - deallocate ( dum ) - endif - -c XDEF -c ---- - if( trim(dummy).eq.'xdef' ) then - backspace(10) - read(10,*) dummy,im - allocate( lons(im) ) - backspace(10) - read(10,*) dummy,im,dummy,lons(1),dx - if( trim(dummy).eq.'linear' ) then - do i=2,im - lons(i) = lons(i-1) + dx - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lons(i),i=1,im) - endif - endif - -c YDEF -c ---- - if( trim(dummy).eq.'ydef' ) then - backspace(10) - read(10,*) dummy,jm - allocate( lats(jm) ) - backspace(10) - read(10,*) dummy,jm,dummy,lats(1),dy - if( trim(dummy).eq.'linear' ) then - do j=2,jm - lats(j) = lats(j-1) + dy - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lats(j),j=1,jm) - endif - endif - -c ZDEF -c ---- - if( trim(dummy).eq.'zdef' ) then - backspace(10) - read(10,*) dummy,lm -#if 0 - allocate( levs(lm) ) - backspace(10) - if( lm.eq.1 ) then - read(10,*) dummy,lm,dummy,levs(1) - else - read(10,*) dummy,lm,dummy,levs(1),dz - endif - if( trim(dummy).eq.'linear' ) then - do L=2,lm - levs(L) = levs(L-1) + dz - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(levs(L),L=1,lm) - endif -#endif - endif - -c UNDEF -c ----- - if( trim(dummy).eq.'undef' ) then - backspace(10) - read(10,*) dummy,undef - endif - - if( trim(dummy).eq.'vars' ) then - backspace(10) - read(10,*) dummy,nvars - allocate( names(nvars) ) - allocate( descs(nvars) ) - allocate( lmvars(nvars) ) - - do n=1,nvars - read(10,*) names(n),lmvars(n),m,descs(n) - if( lmvars(n).eq.0 ) lmvars(n) = 1 - enddo - - endif - enddo - 500 continue - rewind(10) - - if( nvars.eq.0 ) then - print *, 'Warning, nvars = 0!' - stop - endif - - return - end subroutine read_ctl diff --git a/GEOS_Util/post/hdf2rs.F b/GEOS_Util/post/hdf2rs.F deleted file mode 100644 index 382e7692..00000000 --- a/GEOS_Util/post/hdf2rs.F +++ /dev/null @@ -1,3987 +0,0 @@ -#define _DIFFERENCING_ - program main - -! ********************************************************************** -! ********************************************************************** -! **** **** -! **** Program to merge eta_hdf data into GEOS5 restarts **** -! **** **** -! **** Note: ANA files are interpolated/binned to the Model **** -! **** BKG restart resolution. The resulting blended **** -! **** restarts are then remapped to the Model topography. **** -! **** 26Feb2007 Todling - calc ple from top down **** -! **** 02Jul2007 Todling - updated to new analysis state vector **** -! **** 10Jul2007 Todling - handling of analysis increment **** -! **** 28Aug2007 Todling - compiled r8 (as well as all in this **** -! **** dir - needed for proper handle of bkg **** -! **** (e.g., zero-ob case); largely modified **** -! **** treatment of increments; opt to write **** -! **** out interpolated increment **** -! **** 18Sep2007 Todling - add low resolution analysis bkg update **** -! **** 04Mar2007 Todling - add low resolution analysis bkg update **** -! **** **** -! ********************************************************************** -! ********************************************************************** - -! Note: When updating analysis using increment there are at least two -! reasons for doing harm to the gcm fields when the increments -! are zero: (i) different accuracy between rst files (r8) and -! analysis increment file (r4); and (ii) the way the pressure -! field gets updated (particularly pk). The only fully no-data/ -! no-harm procedure is the one using the code within the compiler -! directive _DIFFERENCING_. -! - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice_ana - type ( dynamics_lattice_type ) lattice_bkg -#ifdef mpi - include 'mpif.h' -#endif - integer comm,myid,npes,ierror - - integer imaglobal,jmaglobal - integer imbglobal,jmbglobal - integer imxglobal,jmxglobal - integer npex,npey - - integer headr1(6) - integer headr2(5) - integer nymd,nhms,nymd_bkg,nhms_bkg - integer ima,jma,lm - integer imb,jmb - integer, parameter :: lugrd = 50 - - integer ntime,nvars,ngatts,timinc - integer ntdum,lmdum - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - character*128 dynrst, bkgeta, moistrst, pchemrst, topofile - character*128 anaeta, inceta, incout, bkgsfc - character*128 tag - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - character*3 iamdoing - -! ANA and BKG Variables -! --------------------- - real, allocatable :: dp_bkgx(:,:,:) - real, allocatable :: u_ana(:,:,:) , u_bkg(:,:,:), u_bkg0(:,:,:), u_bkgx(:,:,:) - real, allocatable :: v_ana(:,:,:) , v_bkg(:,:,:), v_bkg0(:,:,:), v_bkgx(:,:,:) - real, allocatable :: thv_ana(:,:,:) , thv_bkg(:,:,:) - real, allocatable :: tv_ana(:,:,:) , tv_bkgx(:,:,:) - real, allocatable :: th_bkg(:,:,:), th_bkg0(:,:,:) - real, allocatable :: pk_ana(:,:,:) , pk_bkg(:,:,:), dpk_bkg (:,:,:) - real, allocatable :: ple_ana(:,:,:) , ple_bkg(:,:,:), ple_bkg0(:,:,:), ple_bkgx(:,:,:) - real, allocatable :: pke_ana(:,:,:) , pke_bkg(:,:,:), dpke_bkg(:,:,:) - real, allocatable :: q_ana(:,:,:) , q_bkg(:,:,:), q_bkg0(:,:,:), q_bkgx(:,:,:) - real, allocatable :: o3_ana(:,:,:) , o3_bkg(:,:,:), o3_bkg0(:,:,:), o3_bkgx(:,:,:) - real, allocatable :: ps_ana(:,:) , ps_bkgx(:,:) - real, allocatable :: phis_ana(:,:) , phis_bkg(:,:) , phis_bkgx(:,:) - real, allocatable :: phis_tmp(:,:) - real, allocatable :: cosza(:,:) , coszb(:,:) - - real, allocatable :: glo(:,:) - real*8, allocatable :: ak(:) - real*8, allocatable :: bk(:) - - real*4 kappa - real*4 rgas,rvap,eps,grav - real undefa - - character*120, allocatable :: arg(:) - character*8 date - character*2 hour - integer n,nargs,L,ID,rc,method - logical increment,ihaveth,doremap,do_o3,showdiv - -C ********************************************************************** -C **** Initialize MPI Environment **** -C ********************************************************************** - - call timebeg ('main') - -#ifdef mpi - call mpi_init ( ierror ) ; comm = mpi_comm_world - call mpi_comm_rank ( comm,myid,ierror ) - call mpi_comm_size ( comm,npes,ierror ) - npex = nint ( sqrt( float(npes) ) ) - npey = npex - do while ( npex*npey .ne. npes ) - npex = npex-1 - npey = nint ( float(npes)/float(npex) ) - enddo -#else - comm = 0 - npes = 1 - npex = 1 - npey = 1 - myid = 0 -#endif - -! ********************************************************************** -! **** Initialize Filenames **** -! ********************************************************************** - - kappa = 2.0/7.0 - grav = 9.8 - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - - tag = 'ana' - dynrst = 'x' - pchemrst = 'x' - moistrst = 'x' - bkgeta = 'x' - anaeta = 'x' - bkgsfc = 'x' - inceta = 'x' - incout = 'x' - topofile = 'x' - nymd = -999 - nhms = -999 - method = -999 - doremap = .false. - - nargs = command_argument_count() - if(nargs.eq.0) call usage(myid) - allocate ( arg(nargs) ) - - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-h' ) call usage(myid) - if( trim(arg(n)).eq.'-help' ) call usage(myid) - if( trim(arg(n)).eq.'-H' ) call usage(myid) - if( trim(arg(n)).eq.'-Help' ) call usage(myid) - if( trim(arg(n)).eq.'-dynrst' ) then - dynrst = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-moistrst' ) then - moistrst = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-pchemrst' ) then - pchemrst = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-ana' ) then - anaeta = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-bkg' ) then - bkgeta = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-sfc' ) then - bkgsfc = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-inc' ) then - inceta = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-oinc' ) then - incout = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-topo' ) then - topofile = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-tag' ) then - tag = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-remap' ) doremap = .true. - if( trim(arg(n)).eq.'-divr' ) method = 1 - if( trim(arg(n)).eq.'-diva' ) method = 2 - if( trim(arg(n)).eq.'-showdiv' ) showdiv = .true. - if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1),*) nymd - if( trim(arg(n)).eq.'-nhms' ) read(arg(n+1),*) nhms - enddo - - - do_o3 = .false. - increment = .false. - iamdoing = 'ANA' - if( trim(anaeta) .eq.'x' .and. - . trim(inceta) .eq.'x' ) then - if( myid.eq.0 ) print *, 'You must supply either ANAETA or INCETA Files!' - call my_finalize - error stop 7 - stop - else if ( trim(anaeta) .eq. 'x' ) then ! increment is provided as input - increment = .true. - anaeta = inceta - iamdoing = 'INC' - do_o3 = .true. - if( trim(dynrst) .eq.'x' .or. - . trim(moistrst).eq.'x' .or. - . trim(pchemrst).eq.'x' .or. - . trim(bkgsfc) .eq.'x' ) then - if( myid.eq.0 ) print *, 'You must supply DYNRST, MOISTRST, PCHEMRST, and BKGSFC Files!' - call my_finalize - error stop 7 - stop - endif - else ! analyis is provided as input - if( trim(dynrst) .eq.'x' .or. - . trim(moistrst).eq.'x' ) then - if( myid.eq.0 ) print *, 'You must supply at least DYNRST, and MOISTRST Files!' - call my_finalize - error stop 7 - stop - endif - do_o3 = trim(pchemrst).ne.'x' .and. trim(bkgsfc).eq.'x' - if ( bkgeta .ne. 'x' ) then - if( myid.eq.0 ) print *, 'Opt not available: ANA BKG cannot be updated w/o INCs!' - call my_finalize - error stop 7 - stop - endif - endif - - -! ********************************************************************** -! **** Read Dycore Internal Restart for RSLV, Date and Time **** -! ********************************************************************** - - if( myid.eq.0 ) then - print * - print *, 'Reading ',trim(dynrst),' from PE: ',myid - open (10, file=trim(dynrst),form='unformatted',access='sequential') - read (10) headr1 - read (10) headr2 - endif -#ifdef mpi - call mpi_bcast ( headr1,6,mpi_integer,0,comm,ierror ) - call mpi_bcast ( headr2,5,mpi_integer,0,comm,ierror ) -#endif - - nymd_bkg = headr1(1)*10000 - . + headr1(2)*100 - . + headr1(3) - nhms_bkg = headr1(4)*10000 - . + headr1(5)*100 - . + headr1(6) - - imbglobal = headr2(1) - jmbglobal = headr2(2) - lm = headr2(3) - - if( nymd.eq.-999 ) nymd = nymd_bkg - if( nhms.eq.-999 ) nhms = nhms_bkg - - write(date,101) nymd - write(hour,102) nhms/10000 - 101 format(i8.8) - 102 format(i2.2) - - call create_dynamics_lattice ( lattice_bkg,npex,npey ) - call init_dynamics_lattice ( lattice_bkg,comm,imbglobal,jmbglobal,lm ) - - imb = lattice_bkg%im( lattice_bkg%pei ) - jmb = lattice_bkg%jm( lattice_bkg%pej ) - - allocate ( q_bkg(imb,jmb,lm) ) - allocate ( o3_bkg(imb,jmb,lm) ) - allocate ( thv_bkg(imb,jmb,lm) ) - allocate ( pke_bkg(imb,jmb,lm+1) ) - allocate ( phis_bkg(imb,jmb) ) - - allocate ( u_bkg(imb,jmb,lm) ) - allocate ( v_bkg(imb,jmb,lm) ) - allocate ( th_bkg(imb,jmb,lm) ) - allocate ( ple_bkg(imb,jmb,lm+1) ) - allocate ( pk_bkg(imb,jmb,lm) ) - allocate ( dpk_bkg(imb,jmb,lm) ) - - allocate ( u_bkg0(imb,jmb,lm) ) - allocate ( v_bkg0(imb,jmb,lm) ) - allocate ( ple_bkg0(imb,jmb,lm+1) ) - if (increment) then - allocate ( q_bkg0(imb,jmb,lm) ) - allocate ( o3_bkg0(imb,jmb,lm) ) - allocate ( th_bkg0(imb,jmb,lm) ) - endif - - allocate ( ak(lm+1) ) - allocate ( bk(lm+1) ) - - if( myid.eq.0 ) then - read (10) ak - read (10) bk - endif -#ifdef mpi - call mpi_bcast ( ak,lm+1,mpi_double_precision,0,comm,ierror ) - call mpi_bcast ( bk,lm+1,mpi_double_precision,0,comm,ierror ) -#endif - - call read_fv ( u_bkg0,imb,jmb,lm ,10,lattice_bkg ) - call read_fv ( v_bkg0,imb,jmb,lm ,10,lattice_bkg ) - if (increment) then - call read_fv ( th_bkg0,imb,jmb,lm,10,lattice_bkg ) - else - call read_fv ( ple_bkg0,imb,jmb,lm,10,lattice_bkg ) - endif - call read_fv ( ple_bkg0,imb,jmb,lm+1,10,lattice_bkg ) - if (increment) then - call read_fv ( pk_bkg,imb,jmb,lm,10,lattice_bkg ) - endif - - if( myid.eq.0 ) close(10) - -! ********************************************************************** -! **** Read Moist Internal Restart **** -! ********************************************************************** - - if( increment ) then - if( myid.eq.0 ) then - print *, 'Reading GEOS-5 moist_internal_restart: ',trim(moistrst) - print * - open (20,file=trim(moistrst),form='unformatted',access='sequential') - endif - -! Read first field: SPHU -! ---------------------- - allocate ( glo(imb,jmb) ) - do L=1,lm - call readit ( glo,imb,jmb,1,20,lattice_bkg,moistrst,rc ) - q_bkg0(:,:,L) = glo(:,:) - enddo - deallocate ( glo ) - - if( myid.eq.0 ) close(20) - endif ! < increment > - -! ********************************************************************** -! **** Read Pchem Internal Restart **** -! ********************************************************************** - - if( do_o3 ) then - if( myid.eq.0 ) then - print *, 'Reading GEOS-5 pchem_internal_restart: ',trim(pchemrst) - print * - open (30,file=trim(pchemrst),form='unformatted',access='sequential') - endif - -! Read first field: OZONE -! ----------------------- - allocate ( glo(imb,jmb) ) - do L=1,lm - call readit ( glo,imb,jmb,1,30,lattice_bkg,moistrst,rc ) - o3_bkg0(:,:,L) = glo(:,:) - enddo - deallocate ( glo ) - - if( myid.eq.0 ) close(30) - - else - o3_bkg0 = 0.0 - endif ! < do_o3 > - -! ********************************************************************** -! **** Read Analysis/Increment ANA/INC File **** -! ********************************************************************** - - call timebeg(' read_ana') - if( myid.eq.0 ) then - print *, 'Reading ', iamdoing, ' File from PE: ',myid - call gfio_open ( trim(anaeta),1,ID,rc ) - call gfio_diminquire ( id,imaglobal,jmaglobal,lm,ntime,nvars,ngatts,rc ) - endif -#ifdef mpi - call mpi_bcast ( imaglobal,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( jmaglobal,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( lm,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( ntime,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( nvars,1, mpi_integer,0,comm,ierror ) -#endif - call create_dynamics_lattice ( lattice_ana,npex,npey ) - call init_dynamics_lattice ( lattice_ana,comm,imaglobal,jmaglobal,lm ) - - ima = lattice_ana%im( lattice_ana%pei ) - jma = lattice_ana%jm( lattice_ana%pej ) - - allocate ( lon(imaglobal) ) - allocate ( lat(jmaglobal) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - if( myid.eq.0 ) then - call gfio_inquire ( id,imaglobal,jmaglobal,lm,ntime,nvars, - . title,source,contact,undefa, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - endif -#ifdef mpi - call mpi_bcast ( undefa, 1,lattice_ana%mpi_rkind,0,comm,ierror ) - call mpi_bcast ( lon,imaglobal,lattice_ana%mpi_rkind,0,comm,ierror ) -#endif - - allocate ( ps_ana(ima,jma) ) - allocate ( pk_ana(ima,jma,lm) ) - allocate ( pke_ana(ima,jma,lm+1) ) - allocate ( thv_ana(ima,jma,lm) ) - - allocate ( phis_ana(ima,jma) ) - allocate ( u_ana(ima,jma,lm) ) - allocate ( v_ana(ima,jma,lm) ) - allocate ( tv_ana(ima,jma,lm) ) - allocate ( q_ana(ima,jma,lm) ) - allocate ( o3_ana(ima,jma,lm) ) - allocate ( ple_ana(ima,jma,lm+1) ) - - call getit ( id,'phis' ,nymd,nhms,ima,jma,0,1 ,phis_ana,lattice_ana ) - call getit ( id,'ps' ,nymd,nhms,ima,jma,0,1 , ps_ana,lattice_ana ) - call getit ( id,'u' ,nymd,nhms,ima,jma,1,lm, u_ana,lattice_ana ) - call getit ( id,'v' ,nymd,nhms,ima,jma,1,lm, v_ana,lattice_ana ) - call getit ( id,'tv' ,nymd,nhms,ima,jma,1,lm, tv_ana,lattice_ana ) - call getit ( id,'sphu' ,nymd,nhms,ima,jma,1,lm, q_ana,lattice_ana ) - call getit ( id,'ozone',nymd,nhms,ima,jma,1,lm, o3_ana,lattice_ana ) - - if( myid.eq.0 ) call gfio_close ( id,rc ) - call timeend(' read_ana') - - -! Calculate analysis pressure edges (or increments to it) -! ------------------------------------------------------- - if ( increment ) then - do L=1,lm+1 - ple_ana(:,:,L) = ps_ana(:,:)*bk(L) - enddo - else - do L=1,lm+1 - ple_ana(:,:,L) = ak(L) + ps_ana(:,:)*bk(L) - enddo - endif - - deallocate ( ps_ana ) - -! Check for Indexing Consistency with Model -! ----------------------------------------- - if( myid.eq.0 ) print *, 'Analysis ', iamdoing, ' File begins at Lon: ',lon(1) - if( lon(1) .eq. 0.0 ) then - if( myid.eq.0 ) print *, ' Flipping Horizontal Coordinate' - call hflip (phis_ana,ima,jma,1 ,lattice_ana ) - call hflip ( u_ana,ima,jma,lm ,lattice_ana ) - call hflip ( v_ana,ima,jma,lm ,lattice_ana ) - call hflip ( tv_ana,ima,jma,lm ,lattice_ana ) - call hflip ( ple_ana,ima,jma,lm+1,lattice_ana ) - call hflip ( q_ana,ima,jma,lm ,lattice_ana ) - call hflip ( o3_ana,ima,jma,lm ,lattice_ana ) - endif - -! Create ANA Virtual Potential Temperature -! NOTE: If input data is increment, thv_ana -! carries increment in virtual temperature -! ----------------------------------------------- - if ( increment ) then - thv_ana = tv_ana - ihaveth = .true. ! in this case, at the point of calling remap - ! the temperature variable contains theta - else - pke_ana(:,:,:) = ple_ana(:,:,:)**kappa - do L=1,lm - pk_ana(:,:,L) = ( pke_ana(:,:,L+1)-pke_ana(:,:,L) ) - . / ( kappa*log(ple_ana(:,:,L+1)/ple_ana(:,:,L)) ) - enddo - thv_ana = tv_ana/pk_ana - ihaveth = .false. ! in this case, at the point of calling remap - ! the temperature variable contains virtual theta - endif - - deallocate ( lon ) - deallocate ( lat ) - deallocate ( lev ) - deallocate ( yymmdd ) - deallocate ( hhmmss ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( kmvar ) - deallocate ( vrange ) - deallocate ( prange ) - deallocate ( tv_ana ) - - -! If so, update analysis background and overwrite it -! -------------------------------------------------- - if ( bkgeta .ne. 'x' ) then - -! ********************************************************************** -! **** Read Analysis BKG File **** -! ********************************************************************** - - if( myid.eq.0 ) then - print *, 'Reading ', trim(bkgeta), ' File from PE: ',myid - call gfio_open ( trim(bkgeta),0,ID,rc ) - call gfio_diminquire ( id,imxglobal,jmxglobal,lm,ntime,nvars,ngatts,rc ) - endif -#ifdef mpi - call mpi_bcast ( imxglobal,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( jmxglobal,1, mpi_integer,0,comm,ierror ) -#endif - if ( imxglobal.ne.imaglobal .and. jmxglobal.ne.jmaglobal ) then - if( myid.eq.0 ) print *, 'Dimension of ANA background incompatible w/ INCs!' - call my_finalize - error stop 7 - stop - endif - - allocate ( lon(imxglobal) ) - allocate ( lat(jmxglobal) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - if( myid.eq.0 ) then - call gfio_inquire ( id,imxglobal,jmxglobal,lm,ntime,nvars, - . title,source,contact,undefa, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - endif -#ifdef mpi - call mpi_bcast ( lon,imxglobal,lattice_ana%mpi_rkind,0,comm,ierror ) -#endif - -! Check for Indexing Consistency with Model -! ----------------------------------------- - if( myid.eq.0 ) print *, 'Background ', trim(bkgeta), ' File begins at Lon: ',lon(1) - if( lon(1) .eq. 0.0 ) then - if( myid.eq.0 ) print *, 'Longitudes in BKG file incompatible with INC file!' - call my_finalize - error stop 7 - stop - endif - - deallocate ( lon ) - deallocate ( lat ) - deallocate ( lev ) - deallocate ( yymmdd ) - deallocate ( hhmmss ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( kmvar ) - deallocate ( vrange ) - deallocate ( prange ) - - allocate ( phis_bkgx(ima,jma) ) - allocate ( ps_bkgx(ima,jma) ) - allocate ( dp_bkgx(ima,jma,lm) ) - allocate ( u_bkgx(ima,jma,lm) ) - allocate ( v_bkgx(ima,jma,lm) ) - allocate ( tv_bkgx(ima,jma,lm) ) - allocate ( q_bkgx(ima,jma,lm) ) - allocate ( o3_bkgx(ima,jma,lm) ) - allocate ( ple_bkgx(ima,jma,lm+1) ) - - call getit ( id,'phis' ,nymd,nhms,ima,jma,0,1 ,phis_bkgx,lattice_ana ) - call getit ( id,'ps' ,nymd,nhms,ima,jma,0,1 , ps_bkgx,lattice_ana ) - call getit ( id,'delp' ,nymd,nhms,ima,jma,1,lm, dp_bkgx,lattice_ana ) - call getit ( id,'u' ,nymd,nhms,ima,jma,1,lm, u_bkgx,lattice_ana ) - call getit ( id,'v' ,nymd,nhms,ima,jma,1,lm, v_bkgx,lattice_ana ) - call getit ( id,'tv' ,nymd,nhms,ima,jma,1,lm, tv_bkgx,lattice_ana ) - call getit ( id,'sphu' ,nymd,nhms,ima,jma,1,lm, q_bkgx,lattice_ana ) - call getit ( id,'ozone',nymd,nhms,ima,jma,1,lm, o3_bkgx,lattice_ana ) - -! Calculate pressure edges for full resolution analysis background -! ---------------------------------------------------------------- - do L=1,lm+1 - ple_bkgx(:,:,L) = ak(L) + ps_bkgx(:,:)*bk(L) - enddo - -! Now simply add increments to full resolution Analysis Background -! ---------------------------------------------------------------- - ple_bkgx = ple_bkgx + ple_ana - u_bkgx = u_bkgx + u_ana - v_bkgx = v_bkgx + v_ana - tv_bkgx = tv_bkgx + thv_ana - q_bkgx = q_bkgx + q_ana - o3_bkgx = o3_bkgx + o3_ana - -! Update surface pressure and delp's -! ---------------------------------- - do L = 1, lm - dp_bkgx(:,:,L) = ple_bkgx(:,:,L+1) - ple_bkgx(:,:,L) - enddo - ps_bkgx = ple_bkgx(:,:,lm+1) - -! Write out updated full resolution background (analysis) -! ------------------------------------------------------- - call putit ( id,'ps' ,nymd,nhms,ima,jma,0,1 , ps_bkgx,lattice_ana ) - call putit ( id,'delp' ,nymd,nhms,ima,jma,1,lm, dp_bkgx,lattice_ana ) - call putit ( id,'u' ,nymd,nhms,ima,jma,1,lm, u_bkgx,lattice_ana ) - call putit ( id,'v' ,nymd,nhms,ima,jma,1,lm, v_bkgx,lattice_ana ) - call putit ( id,'tv' ,nymd,nhms,ima,jma,1,lm, tv_bkgx,lattice_ana ) - call putit ( id,'sphu' ,nymd,nhms,ima,jma,1,lm, q_bkgx,lattice_ana ) - call putit ( id,'ozone',nymd,nhms,ima,jma,1,lm, o3_bkgx,lattice_ana ) - - if ( myid.eq.0 ) then - call gfio_close ( id,rc ) - print * - print *, 'Updated Analysis Background File: ', trim(bkgeta) - print * - endif - - deallocate ( ple_bkgx ) - deallocate ( o3_bkgx ) - deallocate ( q_bkgx ) - deallocate ( tv_bkgx ) - deallocate ( v_bkgx ) - deallocate ( u_bkgx ) - deallocate ( dp_bkgx ) - deallocate ( ps_bkgx ) - deallocate ( phis_bkgx ) - - endif ! < update analysis background > - -! ********************************************************************** -! **** Read Surface Background File **** -! **** Only to extract Cosine of Zenith Angle **** -! ********************************************************************** - - if ( do_o3 ) then - - call timebeg(' read_sfc') - if( myid.eq.0 ) then - print *, 'Reading ', trim(bkgsfc), ' File from PE: ',myid - call gfio_open ( trim(bkgsfc),1,ID,rc ) - call gfio_diminquire ( id,imxglobal,jmxglobal,lmdum,ntdum,nvars,ngatts,rc ) - endif -#ifdef mpi - call mpi_bcast ( imxglobal,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( jmxglobal,1, mpi_integer,0,comm,ierror ) -#endif - if (imxglobal.ne.imaglobal .or. jmxglobal.ne.jmaglobal ) then - if( myid.eq.0 ) print *, 'Dimension of BKG SFC file inconsistent w/ that of ANA ETA' - call my_finalize - error stop 7 - endif - - allocate ( cosza(ima,jma) ) - - call getit ( id,'COSZ' ,nymd,nhms,ima,jma,0,1 ,cosza,lattice_ana ) - - if( myid.eq.0 ) call gfio_close ( id,rc ) - call timeend(' read_sfc') - - else - allocate ( cosza(ima,jma) ) - cosza = 0.0 ! it doesn't really matter what this gets set to in this case - endif ! < do_o3 > - - if( myid.eq.0 ) then - print * - print *, ' FV Restart filename: ',trim(dynrst) - print *, ' FV resolution: ',imbglobal,jmbglobal,lm - print * - print *, ' Analysis filename: ',trim(anaeta) - print *, ' ', iamdoing,' resolution: ',imaglobal,jmaglobal,lm - print * - print *, ' Date: ',nymd,nhms - print *, ' Tag: ',trim(tag) - print * - endif - -! ********************************************************************** -! **** Create/Update Restarts Using ANA/INC Data **** -! ********************************************************************** - if( imaglobal.ne.imbglobal .or. - . jmaglobal.ne.jmbglobal .or. - . doremap ) then - - if( trim(topofile).eq.'x' ) then - if( myid.eq.0 ) print *, 'You must supply TOPO File at Model Resolution!' - call my_finalize - error stop 7 - stop - else - if( myid.eq.0 ) print *, 'Reading ',trim(topofile),' from PE: ',myid - open (10,file=trim(topofile),form='unformatted',access='sequential') - call readit ( phis_bkg,imb,jmb,1,10,lattice_bkg,topofile,rc ) - phis_bkg = phis_bkg*grav - close (10) - endif - allocate ( phis_tmp(imb,jmb) ) - allocate ( coszb(imb,jmb) ) - -! Interpolate ANA Data to BKG Resolution -! NOTE: If input data is increment, thv_bkg -! will carry increment of virtual temperature -! after interpolations are completed -! -------------------------------------------------- - if( imaglobal.lt.imbglobal ) then - if( myid.eq.0 ) print *, 'Interpolating ', iamdoing, ' Data to BKG Resolution' - call hinterp ( cosza,ima,jma, coszb,imb,jmb,1 ,undefa,lattice_ana,lattice_bkg,1 ) - call hinterp ( phis_ana,ima,jma,phis_tmp,imb,jmb,1 ,undefa,lattice_ana,lattice_bkg,0 ) - call hinterp ( u_ana,ima,jma, u_bkg,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg,0 ) - call hinterp ( v_ana,ima,jma, v_bkg,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg,0 ) - call hinterp ( thv_ana,ima,jma, thv_bkg,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg,0 ) - call hinterp ( ple_ana,ima,jma, ple_bkg,imb,jmb,lm+1,undefa,lattice_ana,lattice_bkg,0 ) - call hinterp ( q_ana,ima,jma, q_bkg,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg,1 ) - call hinterp ( o3_ana,ima,jma, o3_bkg,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg,1 ) - endif - -! Bin ANA Data to BKG Resolution -! ------------------------------ - if( imaglobal.gt.imbglobal ) then - if( myid.eq.0 ) print *, 'Binning ', iamdoing, ' Data to BKG Resolution' - call bin ( cosza,ima,jma, coszb,imb,jmb,1 ,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( phis_ana,ima,jma,phis_tmp,imb,jmb,1 ,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( u_ana,ima,jma, u_bkg,imb,jmb,lm ,undefa, 1 ,lattice_ana,lattice_bkg ) - call bin ( v_ana,ima,jma, v_bkg,imb,jmb,lm ,undefa, 1 ,lattice_ana,lattice_bkg ) - call bin ( thv_ana,ima,jma, thv_bkg,imb,jmb,lm ,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( ple_ana,ima,jma, ple_bkg,imb,jmb,lm+1,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( q_ana,ima,jma, q_bkg,imb,jmb,lm ,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( o3_ana,ima,jma, o3_bkg,imb,jmb,lm ,undefa, 0 ,lattice_ana,lattice_bkg ) - endif - -! BKG and ANA Horizontal Resolutions Match -! ---------------------------------------- - if( imaglobal.eq.imbglobal .and. jmaglobal.eq.jmbglobal ) then - coszb = cosza - phis_tmp = phis_ana - u_bkg = u_ana - v_bkg = v_ana - thv_bkg = thv_ana - ple_bkg = ple_ana - q_bkg = q_ana - o3_bkg = o3_ana - endif - - -! If so, add interpolated increment to RST background -! (BKG will contain analysis from this point on) -! --------------------------------------------------- - if ( increment ) then - -! Calculate correction to pk given change in ple due to analysis ... -! ------------------------------------------------------------------ -#ifdef _DIFFERENCING_ - -! ... based on finite differencing -! -------------------------------- - allocate( dpke_bkg(imb,jmb,lm+1) ) - pke_bkg(:,:,:) = (ple_bkg0(:,:,:))** kappa - dpke_bkg(:,:,:) = kappa*(ple_bkg0(:,:,:))**(kappa-1)*ple_bkg(:,:,:) - do L=1,lm - dpk_bkg(:,:,L) = ( ( dpke_bkg (:,:,L+1) - dpke_bkg(:,:,L) )* - . log((ple_bkg0(:,:,L+1))/(ple_bkg0(:,:,L) )) - . - ( pke_bkg (:,:,L+1) - pke_bkg (:,:,L) )* - . ( ple_bkg (:,:,L+1) * ple_bkg0(:,:,L) - . - ple_bkg (:,:,L) * ple_bkg0(:,:,L+1) ) - . / (ple_bkg0(:,:,L+1)*ple_bkg0(:,:,L)) - . ) / (kappa*( log(ple_bkg0(:,:,L+1)/ple_bkg0(:,:,L)) )**2) - enddo - deallocate( dpke_bkg ) - -#else /* _DIFFERENCING_ */ - -! ... based on difference between analysis and background pressure edges -! ---------------------------------------------------------------------- - pke_bkg(:,:,:) = (ple_bkg0(:,:,:)+ple_bkg(:,:,:))** kappa - do L=1,lm - dpk_bkg(:,:,L) = ( pke_bkg(:,:,L+1)-pke_bkg(:,:,L) ) - . / ( kappa*log((ple_bkg0(:,:,L+1)+ple_bkg(:,:,L+1))/(ple_bkg0(:,:,L)+ple_bkg(:,:,L))) ) - . - pk_bkg(:,:,L) - enddo - -#endif /* _DIFFERENCING_ */ - -! Calculate correction to dry potential temperature -! ------------------------------------------------- - th_bkg = - th_bkg0 * ( dpk_bkg/pk_bkg + eps*q_bkg/(1+eps*q_bkg0) ) - . + thv_bkg / ( pk_bkg*(1+eps*q_bkg0) ) - -! If so, output increments for diagnostics purposes -! ------------------------------------------------- - if ( trim(incout) /= 'x' ) then - open (lugrd, file=trim(incout),form='unformatted',access='sequential') - call write_fv ( u_bkg,imb,jmb,lm,lugrd,4, lattice_bkg ) - call write_fv ( v_bkg,imb,jmb,lm,lugrd,4, lattice_bkg ) - call write_fv ( thv_bkg,imb,jmb,lm,lugrd,4, lattice_bkg ) ! note: output here is del_Tv - call write_fv ( dpk_bkg,imb,jmb,lm,lugrd,4, lattice_bkg ) - call write_fv ( ple_bkg(:,:,2:lm+1),imb,jmb,lm,lugrd,4, lattice_bkg ) ! note: ple minue top layer - call write_fv ( q_bkg,imb,jmb,lm,lugrd,4, lattice_bkg ) - call write_fv ( o3_bkg,imb,jmb,lm,lugrd,4, lattice_bkg ) - close(lugrd) - if(myid==0) print *, 'Wrote model increment out to: ', trim(incout) - endif - -! Construct D-Grid Wind Increments -! -------------------------------- - allocate ( glo(imbglobal,jmbglobal) ) - do L=1,lm - call timebeg (' Gather') - call gather_2d ( glo,u_bkg(1,1,L),lattice_bkg ) - call timeend (' Gather') - call timebeg (' atod') - if( lattice_ana%myid.eq.0 ) call atod ( glo,glo,imbglobal,jmbglobal,1,2 ) - call timeend (' atod') - call timebeg (' Scatter') - call scatter_2d ( glo,u_bkg(1,1,L),lattice_bkg ) - call timeend (' Scatter') - call timebeg (' Gather') - call gather_2d ( glo,v_bkg(1,1,L),lattice_bkg ) - call timeend (' Gather') - call timebeg (' atod') - if( lattice_ana%myid.eq.0 ) call atod ( glo,glo,imbglobal,jmbglobal,1,1 ) - call timeend (' atod') - call timebeg (' Scatter') - call scatter_2d ( glo,v_bkg(1,1,L),lattice_bkg ) - call timeend (' Scatter') - enddo - deallocate ( glo ) - -! Now add increments to background -! -------------------------------- - ! the following is no-data/harm because of precision - ! of rst vs ana files; however, in presence of remap - ! this is not an issue - allocate ( ps_ana(imb,jmb) ) - ps_ana(:,:) = ple_bkg0(:,:,lm+1) + ple_bkg(:,:,lm+1) - do L=1,lm+1 - ple_bkg(:,:,L) = ak(L) + ps_ana(:,:)*bk(L) - enddo - deallocate ( ps_ana ) - pke_bkg(:,:,:) = ple_bkg(:,:,:)**kappa - do L=1,lm - pk_bkg(:,:,L) = ( pke_bkg(:,:,L+1)-pke_bkg(:,:,L) ) - . / ( kappa*log(ple_bkg(:,:,L+1)/ple_bkg(:,:,L)) ) - enddo - !ple_bkg = ple_bkg0 + ple_bkg ! <-- this is funny for an eta-analysis - ! but the above is no-data/harm - !pk_bkg = pk_bkg + dpk_bkg ! this is no-data/no-harm - - th_bkg = th_bkg0 + th_bkg - u_bkg = u_bkg0 + u_bkg - v_bkg = v_bkg0 + v_bkg - q_bkg = q_bkg0 + q_bkg - -! Convert analyzed O3 to OX -! ------------------------- - call updox ( imb,jmb,lm, o3_bkg, o3_bkg0, ple_bkg, coszb ) - - -! Construct A-Grid Wind Increments (for remap purposes) -! -------------------------------- - allocate ( glo(imbglobal,jmbglobal) ) - do L=1,lm - call timebeg (' Gather') - call gather_2d ( glo,u_bkg(1,1,L),lattice_bkg ) - call timeend (' Gather') - if( lattice_bkg%myid.eq.0 ) call dtoa ( glo,glo,imbglobal,jmbglobal,1,2 ) - call timebeg (' Scatter') - call scatter_2d ( glo,u_bkg(1,1,L),lattice_bkg ) - call timeend (' Scatter') - call timebeg (' Gather') - call gather_2d ( glo,v_bkg(1,1,L),lattice_bkg ) - call timeend (' Gather') - if( lattice_bkg%myid.eq.0 ) call dtoa ( glo,glo,imbglobal,jmbglobal,1,1 ) - call timebeg (' Scatter') - call scatter_2d ( glo,v_bkg(1,1,L),lattice_bkg ) - call timeend (' Scatter') - enddo - deallocate ( glo ) - - thv_bkg = th_bkg ! use thv slot for dry theta - - else ! < increment > - -! Convert analyzed O3 to OX -! ------------------------- - if (do_o3) call getox ( imb,jmb,lm, o3_bkg, ple_bkg, coszb ) - - endif ! < increment > - - where(phis_bkg<0.0) phis_bkg = 0.0 - where(phis_tmp<0.0) phis_tmp = 0.0 - -! Remap Based on TOPO Differences -! ------------------------------- - if( myid.eq.0 ) print *, 'Remapping Data to BKG Topography' - call timebeg(' remap') - call remap ( ple_bkg, - . u_bkg, - . v_bkg, - . thv_bkg, - . q_bkg, - . o3_bkg, - . phis_tmp,phis_bkg,ak,bk,imb,jmb,lm,ihaveth ) - call timeend(' remap') - if( myid.eq.0 ) print *, 'Remapping Complete' - -! Construct D-Grid Winds -! ---------------------- - allocate ( glo(imbglobal,jmbglobal) ) - do L=1,lm - call timebeg (' Gather') - call gather_2d ( glo,u_bkg(1,1,L),lattice_bkg ) - call timeend (' Gather') - call timebeg (' atod') - if( lattice_ana%myid.eq.0 ) call atod ( glo,glo,imbglobal,jmbglobal,1,2 ) - call timeend (' atod') - call timebeg (' Scatter') - call scatter_2d ( glo,u_bkg(1,1,L),lattice_bkg ) - call timeend (' Scatter') - call timebeg (' Gather') - call gather_2d ( glo,v_bkg(1,1,L),lattice_bkg ) - call timeend (' Gather') - call timebeg (' atod') - if( lattice_ana%myid.eq.0 ) call atod ( glo,glo,imbglobal,jmbglobal,1,1 ) - call timeend (' atod') - call timebeg (' Scatter') - call scatter_2d ( glo,v_bkg(1,1,L),lattice_bkg ) - call timeend (' Scatter') - enddo - deallocate ( glo ) - -! Re-construct PK Model Variable after remapping -! ---------------------------------------------- - pke_bkg(:,:,:) = ple_bkg(:,:,:)**kappa - do L=1,lm - pk_bkg(:,:,L) = ( pke_bkg(:,:,L+1)-pke_bkg(:,:,L) ) - . / ( kappa*log(ple_bkg(:,:,L+1)/ple_bkg(:,:,L)) ) - enddo - -! Construct Dry Potential Temperature -! ----------------------------------- - if( increment ) then - th_bkg = thv_bkg - else - th_bkg = thv_bkg/(1+eps*q_bkg) - endif - - deallocate ( coszb ) - deallocate ( phis_tmp ) - - else ! if( imaglobal.eq.imbglobal .and. - ! jmaglobal.eq.jmbglobal .and. - ! .not. doremap ) then - -! Construct D-Grid Winds -! ---------------------- - allocate ( glo(imbglobal,jmbglobal) ) - do L=1,lm - call timebeg (' Gather') - call gather_2d ( glo,u_ana(1,1,L),lattice_ana ) - call timeend (' Gather') - call timebeg (' atod') - if( lattice_ana%myid.eq.0 ) call atod ( glo,glo,imaglobal,jmaglobal,1,2 ) - call timeend (' atod') - call timebeg (' Scatter') - call scatter_2d ( glo,u_ana(1,1,L),lattice_ana ) - call timeend (' Scatter') - call timebeg (' Gather') - call gather_2d ( glo,v_ana(1,1,L),lattice_ana ) - call timeend (' Gather') - call timebeg (' atod') - if( lattice_ana%myid.eq.0 ) call atod ( glo,glo,imaglobal,jmaglobal,1,1 ) - call timeend (' atod') - call timebeg (' Scatter') - call scatter_2d ( glo,v_ana(1,1,L),lattice_ana ) - call timeend (' Scatter') - enddo - deallocate ( glo ) - -! BKG and ANA Horizontal Resolutions Match -! ---------------------------------------- - if ( increment ) then - -! CASE: analysis and gcm IC's have same resolution, -! no remapping is requested and increment is -! an input field. - -! Add increment of ple to background ple, and calculate pk -! -------------------------------------------------------- - ! the following is no-data/harm because of precision - ! of rst vs ana files; however, in presence of remap - ! this is not an issue - allocate ( ps_ana(imb,jmb) ) - ps_ana(:,:) = ple_bkg0(:,:,lm+1) + ple_ana(:,:,lm+1) - do L=1,lm+1 - ple_bkg(:,:,L) = ak(L) + ps_ana(:,:)*bk(L) - enddo - deallocate ( ps_ana ) - -#ifdef _DIFFERENCING_ - -! Calculate dpk based finite differencing -! --------------------------------------- - allocate( dpke_bkg(imb,jmb,lm+1) ) - pke_bkg(:,:,:) = (ple_bkg0(:,:,:))** kappa - dpke_bkg(:,:,:) = kappa*(ple_bkg0(:,:,:))**(kappa-1)*ple_ana(:,:,:) - do L=1,lm - dpk_bkg(:,:,L) = ( ( dpke_bkg (:,:,L+1)-dpke_bkg(:,:,L) )* - . log( ple_bkg0(:,:,L+1)/ple_bkg0(:,:,L) ) - . - ( pke_bkg (:,:,L+1)-pke_bkg (:,:,L) )* - . ( ple_ana (:,:,L+1)*ple_bkg0(:,:,L) - . - ple_ana (:,:,L) *ple_bkg0(:,:,L+1) ) - . / (ple_bkg0(:,:,L+1)*ple_bkg0(:,:,L)) - . ) / (kappa*( log(ple_bkg0(:,:,L+1)/ple_bkg0(:,:,L)) )**2) - enddo - deallocate( dpke_bkg ) - -#else /* _DIFFERENCING_ */ - -! Calculate dpk based on diff between analyzed pk and background pk -! ----------------------------------------------------------------- - pke_bkg = ple_bkg** kappa ! based on analyzed pressure edges - do L=1,lm - dpk_bkg(:,:,L) = ( pke_bkg(:,:,L+1)-pke_bkg(:,:,L) ) - . / ( kappa*log((ple_bkg(:,:,L+1))/(ple_bkg(:,:,L))) ) - . - pk_bkg(:,:,L) - enddo - -#endif /* _DIFFERENCING_ */ - -! Calculate correction to dry potential temperature -! ------------------------------------------------- - th_bkg = - th_bkg0 * ( dpk_bkg/pk_bkg + eps*q_ana/(1+eps*q_bkg0) ) - . + thv_ana / ( pk_bkg*(1+eps*q_bkg0) ) - -! If so, output increments for diagnostics purposes -! ------------------------------------------------- - if ( trim(incout) /= 'x' ) then - open (lugrd, file=trim(incout),form='unformatted',access='sequential') - call write_fv ( u_ana,imb,jmb,lm,lugrd,4, lattice_bkg ) - call write_fv ( v_ana,imb,jmb,lm,lugrd,4, lattice_bkg ) - call write_fv ( thv_ana,imb,jmb,lm,lugrd,4, lattice_bkg ) ! note: output here is del_Tv - call write_fv ( dpk_bkg,imb,jmb,lm,lugrd,4, lattice_bkg ) - call write_fv ( ple_ana(:,:,2:lm+1),imb,jmb,lm,lugrd,4, lattice_bkg ) ! note: ple excluding pressure edge - call write_fv ( q_ana,imb,jmb,lm,lugrd,4, lattice_bkg ) - call write_fv ( o3_ana,imb,jmb,lm,lugrd,4, lattice_bkg ) - close(lugrd) - if(myid==0) print *, 'Wrote model increment out to: ', trim(incout) - endif - -! Update pk (only after correction to th has been calculated) -! ----------------------------------------------------------- - pke_bkg(:,:,:) = ple_bkg(:,:,:)**kappa - do L=1,lm - pk_bkg(:,:,L) = ( pke_bkg(:,:,L+1)-pke_bkg(:,:,L) ) - . / ( kappa*log(ple_bkg(:,:,L+1)/ple_bkg(:,:,L)) ) - enddo - - th_bkg = th_bkg0 + th_bkg - u_bkg = u_bkg0 + u_ana - v_bkg = v_bkg0 + v_ana - q_bkg = q_bkg0 + q_ana - -! Convert analyzed O3 to OX -! ------------------------- - call updox ( imb,jmb,lm, o3_ana, o3_bkg0, ple_bkg, cosza ) - o3_bkg = o3_ana - - else ! < increment > - -! CASE: analysis and gcm IC's have same resolution, -! no remapping is requested and analysis is -! an input field. - -! Convert analyzed O3 to OX -! ------------------------- - if(do_o3) call getox ( imb,jmb,lm, o3_ana, ple_ana, cosza ) - - u_bkg = u_ana - v_bkg = v_ana - thv_bkg = thv_ana - ple_bkg = ple_ana - q_bkg = q_ana - o3_bkg = o3_ana - -! Construct PK Model Variable -! --------------------------- - pk_bkg = pk_ana - -! Construct Dry Potential Temperature -! ----------------------------------- - th_bkg = thv_bkg/(1+eps*q_bkg) - - endif ! < increment > - - endif ! < resolution of ana/inc > - - deallocate ( cosza ) - deallocate ( u_ana ) - deallocate ( v_ana ) - deallocate ( thv_ana ) - deallocate ( ple_ana ) - deallocate ( q_ana ) - deallocate ( o3_ana ) - - -! Modify vertically integrated wind increment to be non-divergent -! --------------------------------------------------------------- - - if( method.eq.-999 ) then - if( myid.eq.0 ) print *, 'No Wind Adjustment Change to Divergence' - else - if ( showdiv ) then - if( myid.eq.0 ) then - print *, 'Creating GEOS-5 fvcore_internal_restart: ',trim(anaeta) - open (lugrd,file='windiv.grd',form='unformatted',access='sequential') - endif - call write_d ( lugrd, u_bkg0,v_bkg0,ple_bkg0,imb,jmb,lm,lattice_bkg ) ! Background - call write_d ( lugrd, u_bkg ,v_bkg ,ple_bkg ,imb,jmb,lm,lattice_bkg ) ! Analysis before Adjustment - endif - - if( myid.eq.0 ) then - if( method.eq.1 ) print *, 'Minimizing Relative Change to Divergence' - if( method.eq.2 ) print *, 'Minimizing Absolute Change to Divergence' - print *, 'Calling Windfix' - endif - call timebeg (' windfix') - call windfix ( u_bkg ,v_bkg ,ple_bkg , - . u_bkg0,v_bkg0,ple_bkg0,imb,jmb,lm,lattice_bkg,'D',method ) - call timeend (' windfix') - - if ( showdiv ) then - call write_d ( lugrd, u_bkg,v_bkg,ple_bkg,imb,jmb,lm,lattice_bkg ) ! Analysis after Adjustment - close (lugrd) - endif - - endif - - -! ********************************************************************** -! **** Write Dycore Internal Restart **** -! ********************************************************************** - - anaeta = trim(dynrst) // '.' // trim(tag) // '.' // date // '_' // hour // 'z' - - call timebeg(' writefv') - if( myid.eq.0 ) then - print *, 'Creating GEOS-5 fvcore_internal_restart: ',trim(anaeta) - open (20,file=trim(anaeta),form='unformatted',access='sequential') - write(20) headr1 - write(20) headr2 - write(20) ak - write(20) bk - endif - - call write_fv ( u_bkg,imb,jmb,lm ,20,kind(ak(1)),lattice_bkg ) - call write_fv ( v_bkg,imb,jmb,lm ,20,kind(ak(1)),lattice_bkg ) - call write_fv ( th_bkg,imb,jmb,lm ,20,kind(ak(1)),lattice_bkg ) - call write_fv ( ple_bkg,imb,jmb,lm+1,20,kind(ak(1)),lattice_bkg ) - call write_fv ( pk_bkg,imb,jmb,lm ,20,kind(ak(1)),lattice_bkg ) - - if( myid.eq.0 ) close (20) - call timeend(' writefv') - -! ********************************************************************** -! **** Merge Moist Internal Restart with Analysis ANA Data **** -! ********************************************************************** - - anaeta = trim(moistrst) // '.' // trim(tag) // '.' // date // '_' // hour // 'z' - - call timebeg(' writemois') - if( myid.eq.0 ) then - print *, 'Creating GEOS-5 moist_internal_restart: ',trim(anaeta) - endif - - open (10,file=trim(moistrst),form='unformatted',access='sequential') - open (20,file=trim(anaeta) ,form='unformatted',access='sequential') - - allocate ( glo(imb,jmb) ) - -! First moist variable is SPHU -! ---------------------------- - do L=1,lm - call readit ( glo,imb,jmb,1,10,lattice_bkg,moistrst,rc ) - glo(:,:) = q_bkg(:,:,L) - call writit ( glo,imb,jmb,1,20,lattice_bkg ) - enddo - -! Copy Rest of Moist Internal State -! --------------------------------- - rc = 0 - dowhile (rc.eq.0) - do L=1,lm - call readit ( glo,imb,jmb,1,10,lattice_bkg,moistrst,rc ) - if(rc.eq.0) call writit ( glo,imb,jmb,1,20,lattice_bkg ) - enddo - enddo - - deallocate ( glo ) - close (10) - close (20) - call timeend(' writemois') - -! ********************************************************************** -! **** Merge Pchem Internal Restart with Analysis ANA Data **** -! ********************************************************************** - - if ( do_o3 ) then - - anaeta = trim(pchemrst) // '.' // trim(tag) // '.' // date // '_' // hour // 'z' - call timebeg(' writechem') - if( myid.eq.0 ) then - print *, 'Creating GEOS-5 pchem_internal_restart: ',trim(anaeta) - print * - endif - open (10,file=trim(pchemrst),form='unformatted',access='sequential') - open (20,file=trim(anaeta) ,form='unformatted',access='sequential') - - allocate ( glo(imb,jmb) ) - -! First pchem variable is OZONE -! ----------------------------- - do L=1,lm - call readit ( glo,imb,jmb,1,10,lattice_bkg,pchemrst,rc ) - glo(:,:) = o3_bkg(:,:,L) - call writit ( glo,imb,jmb,1,20,lattice_bkg ) - enddo - -! Copy Rest of Pchem Internal State -! --------------------------------- - rc = 0 - dowhile (rc.eq.0) - do L=1,lm - call readit ( glo,imb,jmb,1,10,lattice_bkg,pchemrst,rc ) - if(rc.eq.0) call writit ( glo,imb,jmb,1,20,lattice_bkg ) - enddo - enddo - - deallocate ( glo ) - close (10) - close (20) - call timeend(' writechem') - - endif ! < do_o3 > - -! ********************************************************************** -! **** Write Timing Information **** -! ********************************************************************** - - call timeend ('main') - if( myid.eq.0 ) call timepri (6) - call my_finalize - - stop - end - - subroutine getit ( id,name,nymd,nhms,im,jm,lbeg,lm,q,lattice ) - use dynamics_lattice_module - implicit none -#ifdef mpi - include 'mpif.h' -#endif - type ( dynamics_lattice_type ) lattice - integer L,id,nymd,nhms,im,jm,img,jmg,lbeg,lm - real q(im,jm,lm) - real,allocatable :: glo(:,:,:) - character(*) name - integer rc,ierror - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg,lm) ) - if( lattice%myid.eq.0 ) then - call gfio_getvar ( id,trim(name),nymd,nhms,img,jmg,lbeg,lm,glo,rc ) - if( rc.ne.0 ) print *, '!! Error Reading: ',trim(name),' RC = ',rc - endif -#ifdef mpi - call mpi_bcast ( rc,1,mpi_integer,0,lattice%comm,ierror ) -#endif - if ( rc.ne.0 ) then - call my_finalize - error stop 7 - endif - call timebeg (' Scatter') - do L=1,lm - call scatter_2d ( glo(1,1,L),q(1,1,L),lattice ) - enddo - call timeend (' Scatter') - deallocate ( glo ) - return - end - - subroutine putit ( id,name,nymd,nhms,im,jm,lbeg,lm,q,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer L,id,nymd,nhms,im,jm,img,jmg,lbeg,lm - real q(im,jm,lm) - real,allocatable :: glo(:,:,:) - character(*) name - integer rc - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg,lm) ) - call timebeg (' Gather') - do L=1,lm - call gather_2d ( glo(1,1,L),q(1,1,L),lattice ) - enddo - call timeend (' Gather') - if( lattice%myid.eq.0 ) then - call gfio_putvar ( id,trim(name),nymd,nhms,img,jmg,lbeg,lm,glo,rc ) - if( rc.ne.0 ) print *, '!! Error Writing: ',trim(name),' RC = ',rc - endif - deallocate ( glo ) - return - end - - subroutine readit ( q,im,jm,lm,ku,lattice,filename,rc ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice -#ifdef mpi - include 'mpif.h' -#endif - character(*) filename - integer im,jm,lm,L,ku,img,jmg,rc,ierror - real q(im,jm,lm) - real, allocatable :: glo(:,:) - real*4, allocatable :: a(:,:) - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg) ) - allocate ( a(img,jmg) ) - do L=1,lm - if( lattice%myid.eq.0 ) then - read(ku,iostat=rc) a - glo = a - endif -#ifdef mpi - call mpi_bcast ( rc,1,mpi_integer,0,lattice%comm,ierror ) -#endif - if( rc.eq.0 ) then - call timebeg (' Scatter') - call scatter_2d ( glo,q(1,1,L),lattice ) - call timeend (' Scatter') - else if( rc.gt.0 ) then - if( lattice%myid.eq.0 ) print *, 'Error Reading File: ',trim(filename) - call my_finalize - error stop 7 - endif - enddo - deallocate ( a,glo ) - return - end - - subroutine writit ( q,im,jm,lm,ku,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,lm,L,ku,img,jmg - real q(im,jm,lm) - real, allocatable :: glo(:,:) - real*4, allocatable :: a(:,:) - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg) ) - allocate ( a(img,jmg) ) - do L=1,lm - call timebeg (' Gather') - call gather_2d ( glo,q(1,1,L),lattice ) - call timeend (' Gather') - if( lattice%myid.eq.0 ) then - a = glo - write(ku) a - endif - enddo - deallocate ( a,glo ) - return - end - - subroutine read_fv ( q,im,jm,lm,ku,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,lm,L,ku,img,jmg - real q(im,jm,lm) - real, allocatable :: glo4(:,:) - real*8, allocatable :: glo8(:,:) - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo4(img,jmg) ) - allocate ( glo8(img,jmg) ) - do L=1,lm - if( lattice%myid.eq.0 ) then - read(ku) glo8 - glo4 = glo8 - endif - call timebeg (' Scatter') - call scatter_2d ( glo4,q(1,1,L),lattice ) - call timeend (' Scatter') - enddo - deallocate ( glo4 ) - deallocate ( glo8 ) - return - end - - subroutine write_fv ( q,im,jm,lm,ku,mykind,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,lm,L,ku,img,jmg,mykind - real q(im,jm,lm) - real*4, allocatable :: glo4(:,:) - real*8, allocatable :: glo8(:,:) - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo4(img,jmg) ) - allocate ( glo8(img,jmg) ) - do L=1,lm - call timebeg (' Gather') - call gather_2d ( glo4,q(1,1,L),lattice ) - call timeend (' Gather') - if( lattice%myid.eq.0 ) then - if ( mykind==8 ) then - glo8 = glo4 - write(ku) glo8 - else - write(ku) glo4 - endif - endif - enddo - deallocate ( glo4 ) - deallocate ( glo8 ) - return - end - - subroutine hflip ( q,im,jm,lm,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,lm,i,j,L,img,jmg - real q(im,jm,lm) - real, allocatable :: glo(:,:) - real, allocatable :: dum(:) - img = lattice%imglobal - jmg = lattice%jmglobal - - allocate ( glo(img,jmg) ) - allocate ( dum(img) ) - - do L=1,lm - call timebeg (' Gather') - call gather_2d ( glo,q(1,1,L),lattice ) - call timeend (' Gather') - if( lattice%myid.eq.0 ) then - do j=1,jmg - do i=1,img/2 - dum(i) = glo(i+img/2,j) - dum(i+img/2) = glo(i,j) - enddo - glo(:,j) = dum(:) - enddo - endif - call timebeg (' Scatter') - call scatter_2d ( glo,q(1,1,L),lattice ) - call timeend (' Scatter') - enddo - - deallocate ( glo ) - deallocate ( dum ) - return - end - - subroutine getoxinc ( im,jm,lm, ox, oxbkg, ple, cosza, ak ) - - implicit none - integer, intent(in) :: im, jm, lm - real, intent(inout) :: ox(im,jm,lm) ! on input, contains inc O3 - ! on output, contains inc OX - real, intent(in) :: cosza(im,jm) ! cosine of zenith angle - real, intent(in) :: ple(im,jm,lm+1) ! pressure edge increments - real, intent(in) :: oxbkg(im,jm,lm) ! full ox background - real*8, intent(in) :: ak(lm+1) - - real, parameter :: czaLimit = 1.0d-5 - integer :: i,j,L - real :: rlog, prsm, beta - real, allocatable :: pl(:,:,:) - real, allocatable :: ro3ox1(:,:,:) - real, allocatable :: ro3ox2(:,:,:) - real, allocatable :: akm(:) - - allocate ( ro3ox1(im,jm,lm) ) - allocate ( ro3ox2(im,jm,lm) ) - allocate ( pl(im,jm,lm) ) - allocate ( akm(lm) ) - - ro3ox1 = 1.d0 - ro3ox2 = 0.d0 - pl = 0.5 * ( ple(:,:,1:lm) + ple(:,:,2:lm+1) ) - akm = 0.5 * ( ak(1:lm) + ak(2:lm+1) ) - beta = 4.5/alog(10.) - do L = 1, lm - do j = 1, jm - do i = 1, im - ! the following is to prevent taking pressures that go <0 near the top - prsm = max(akm(lm),akm(L)+pl(i,j,L)) - if ( prsm<100.0 .and. cosza(i,j)>czaLimit ) then - rlog = log10(0.01*(prsm)) - ro3ox1(i,j,L) = exp(1.5*(rlog)**2) - ro3ox2(i,j,L) = beta * rlog * pl(i,j,L)/prsm - endif - enddo - enddo - enddo - ox = ox * 1.0d-6*ro3ox1 + oxbkg * ro3ox2 - - deallocate ( akm ) - deallocate ( pl ) - deallocate ( ro3ox1 ) - deallocate ( ro3ox2 ) - - end subroutine getoxinc - - subroutine getox ( im,jm,lm, ox, ple, cosza ) - - implicit none - integer, intent(in) :: im, jm, lm - real, intent(inout) :: ox(im,jm,lm) ! on input, contains O3 - ! on output, contains OX - real, intent(in) :: cosza(im,jm) ! cosine of zenith angle - real, intent(in) :: ple(im,jm,lm+1) ! pressure edges - - real, parameter :: czaLimit = 1.0d-5 - integer :: L - real, allocatable :: pl(:,:,:) - real, allocatable :: ro3ox(:,:,:) - - allocate ( ro3ox(im,jm,lm) ) - allocate ( pl(im,jm,lm) ) - - ro3ox = 1.d0 - pl = 0.5 * ( ple(:,:,1:lm) + ple(:,:,2:lm+1) ) - do L = 1, lm - where (pl(:,:,L) < 100.0 .and. cosza > czaLimit) - ro3ox(:,:,L) = exp(-1.5d0*(log10(0.01*pl(:,:,L)))**2) - end where - enddo - ox = ox * 1.0d-6/ro3ox - - deallocate ( pl ) - deallocate ( ro3ox ) - - end subroutine getox - - subroutine updox ( im,jm,lm, ox, oxbkg, ple, cosza ) - - implicit none - integer, intent(in) :: im, jm, lm - real, intent(inout) :: ox(im,jm,lm) ! on input, O3 increment - ! on output, OX analysis - real, intent(in) :: oxbkg(im,jm,lm) ! O3 background - real, intent(in) :: cosza(im,jm) ! cosine of zenith angle - real, intent(in) :: ple(im,jm,lm+1) ! pressure edges - - real, parameter :: czaLimit = 1.0d-5 - integer :: L - real, allocatable :: pl(:,:,:) - real, allocatable :: ro3ox(:,:,:) - - allocate ( ro3ox(im,jm,lm) ) - allocate ( pl(im,jm,lm) ) - - ro3ox = 1.d0 - pl = 0.5 * ( ple(:,:,1:lm) + ple(:,:,2:lm+1) ) - do L = 1, lm - where (pl(:,:,L) < 100.0 .and. cosza > czaLimit) - ro3ox(:,:,L) = exp(-1.5d0*(log10(0.01*pl(:,:,L)))**2) - end where - enddo - ox = oxbkg*1.0d+6*ro3ox + ox ! update o3 - ox = ox *1.0d-6/ro3ox ! convert updated o3 to ox - - deallocate ( pl ) - deallocate ( ro3ox ) - - end subroutine updox - - subroutine minmax (q,im,jm,L) - real q(im,jm) - qmin = q(1,1) - qmax = q(1,1) - do j=1,jm - do i=1,im - qmin = min( qmin,q(i,j) ) - qmax = max( qmax,q(i,j) ) - enddo - enddo - print *, 'L: ',L,' qmin: ',qmin,' qmax: ',qmax - return - end - - subroutine usage ( myid ) - integer ierror - if(myid.eq.0) then - print *, "Usage: " - print * - print *, " hdf2rs_$ARCH.x -dynrst FV internal_restart " - print *, " -moistrst Moist internal_restart " - print *, " -bkg input: Background-Style bkg.eta file " - print *, " -sfc input: Background-Style bkg.sfc file " - print *, " -ana input: Analysis-Style ana.eta file " - print *, " -inc input: Increment-Style inc.eta file " - print *, " -nymd (Date to Read From ANA.ETA File (YYYYMMDD)," - print *, " Default: Date within DYNRST)" - print *, " -nhms (Time to Read From ANA.ETA File (HHMMSS)," - print *, " Default: Time within DYNRST)" - print *, " -topo (Optional Topography File if Different from ANA) " - print *, " -divr (Optional flag to Minimize Relative Adjustment of" - print *, " Div.Inc.)" - print *, " -diva (Optional flag to Minimize Absolute Adjustment of" - print *, " Div.Inc.)" - print *, " -showdiv Output file with bkg/ana/ and corrected ana div" - print *, " -oinc output: filename for output increment" - print *, " -remap forces remapping" - print * - print *, " NOTES: " - print *, " 1) opt -bkg only makes sense together with -inc. In this case, " - print *, " bkg file is overwritten on output with bkg+inc (analysis field)" - print *, " 2) topography specification no longer determines remap (as in older versions)" - print * - print * - endif -#ifdef mpi - call mpi_finalize (ierror) -#endif - stop - end -#ifdef _REDUNDANT_ - subroutine atod ( qa,qd,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded data **** -C **** to 'D' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted left (westward), **** -C **** u is shifted down (southward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real qax ( im+2 ,lm) - real cx (2*(im+2),lm) - real qay ( 2*jm ,lm) - real cy (2*(2*jm),lm) - - real cosx (im/2), sinx(im/2) - real cosy (jm) , siny(jm) - real trigx(3*(im+1)) - real trigy(3*(2*jm)) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - -C ********************************************************* -C **** shift left (-dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qa(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) + qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) - qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qd(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift down (-dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qa(i,j+1,L) - qay(j+jmm1,L) = -qa(i+imh,jm-j,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) + qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) - qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qd(i,j+1,L) = qay(j,L) - qd(i+imh,jm-j+1,L) = -qay(j+jmm1,L) - enddo - enddo - enddo - - endif - - return - end - - subroutine dtoa ( qd,qa,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real qax ( im+2 ,lm) - real cx (2*(im+2),lm) - real qay ( 2*jm ,lm) - real cy (2*(2*jm),lm) - - real cosx (im/2), sinx(im/2) - real cosy (jm) , siny(jm) - real trigx(3*(im+1)) - real trigy(3*(2*jm)) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - -C ********************************************************* -C **** shift right (dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qd(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) - qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) + qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qa(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift up (dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qd(i,j+1,L) - qay(j+jmm1,L) = -qd(i+imh,jm-j+1,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) - qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) + qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qa(i,j+1,L) = qay(j,L) - qa(i+imh,jm-j,L) = -qay(j+jmm1,L) - enddo - enddo - - enddo - - do L=1,lm - do i=1,imh - qa(i+imh,jm,L) = -qa(i,jm,L) - qa(i,1,L) = -qa(i+imh,1,L) - enddo - enddo - endif - - return - end - - subroutine rfftmlt (a,work,trigs,ifax,inc,jump,n,lot,isign) - integer INC, JUMP, N, LOT, ISIGN - real(kind=KIND(1.0)) A(N),WORK(N),TRIGS(N) - integer IFAX(*) -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR -! CALL Q8QST4 ( 4HXLIB, 6HFFT99F, 6HFFT991, 10HVERSION 01) -!FPP$ NOVECTOR R - integer NFAX, NH, NX, INK - integer I, J, IBASE, JBASE, L, IGO, IA, LA, K, M, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, - * INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, - * 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 -!DIR$ IVDEP - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END - - subroutine fftfax (n,ifax,trigs) - integer IFAX(13) - integer N - REAL(kind=KIND(1.0)) TRIGS(*) -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - integer I, MODE - DATA MODE /3/ -!FPP$ NOVECTOR R - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) WRITE(6,FMT="(//5X, ' FFTFAX -- INVALID N =', I5,/)") N - IF (IFAX(1) .LE. 0 ) STOP 999 - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END - - subroutine fft99a (a,work,trigs,inc,jump,n,lot) - integer inc, jump, N, lot - real(kind=KIND(1.0)) A(N),WORK(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 -! (SPECTRAL TO GRIDPOINT TRANSFORM) -! -!FPP$ NOVECTOR R - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) C, S - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - IA=1 - IB=N*INC+1 - JA=1 - JB=2 -!DIR$ IVDEP - DO 10 L=1,LOT - WORK(JA)=A(IA)+A(IB) - WORK(JB)=A(IA)-A(IB) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 10 CONTINUE -! -! REMAINING WAVENUMBERS - IABASE=2*INC+1 - IBBASE=(N-2)*INC+1 - JABASE=3 - JBBASE=N-1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - WORK(JA)=(A(IA)+A(IB))- - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JB)=(A(IA)+A(IB))+ - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+ - * (A(IA+INC)-A(IB+INC)) - WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))- - * (A(IA+INC)-A(IB+INC)) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 20 CONTINUE - IABASE=IABASE+INK - IBBASE=IBBASE-INK - JABASE=JABASE+2 - JBBASE=JBBASE-2 - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE -!DIR$ IVDEP - DO 40 L=1,LOT - WORK(JA)=2.0*A(IA) - WORK(JA+1)=-2.0*A(IA+INC) - IA=IA+JUMP - JA=JA+NX - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fft99b (work,a,trigs,inc,jump,n,lot) - integer INC, JUMP, N, LOT - real(kind=KIND(1.0)) WORK(N),A(N) - REAL(kind=KIND(1.0)) TRIGS(N) - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) SCALE - real(kind=KIND(1.0)) C, S -! -! SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 -! (GRIDPOINT TO SPECTRAL TRANSFORM) -! -!FPP$ NOVECTOR R - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - SCALE=1.0/FLOAT(N) - IA=1 - IB=2 - JA=1 - JB=N*INC+1 -!DIR$ IVDEP - DO 10 L=1,LOT - A(JA)=SCALE*(WORK(IA)+WORK(IB)) - A(JB)=SCALE*(WORK(IA)-WORK(IB)) - A(JA+INC)=0.0 - A(JB+INC)=0.0 - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 10 CONTINUE -! -! REMAINING WAVENUMBERS - SCALE=0.5*SCALE - IABASE=3 - IBBASE=N-1 - JABASE=2*INC+1 - JBBASE=(N-2)*INC+1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - A(JA)=SCALE*((WORK(IA)+WORK(IB)) - * +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JB)=SCALE*((WORK(IA)+WORK(IB)) - * -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * +(WORK(IB+1)-WORK(IA+1))) - A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * -(WORK(IB+1)-WORK(IA+1))) - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 20 CONTINUE - IABASE=IABASE+2 - IBBASE=IBBASE-2 - JABASE=JABASE+INK - JBBASE=JBBASE-INK - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - SCALE=2.0*SCALE -!DIR$ IVDEP - DO 40 L=1,LOT - A(JA)=SCALE*WORK(IA) - A(JA+INC)=-SCALE*WORK(IA+1) - IA=IA+NX - JA=JA+JUMP - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fax (ifax,n,mode) - integer IFAX(10) - integer N, MODE -!FPP$ NOVECTOR R - integer NN, K, L, INC, II, ISTOP, ITEM, NFAX, I - NN=N - IF (IABS(MODE).EQ.1) GO TO 10 - IF (IABS(MODE).EQ.8) GO TO 10 - NN=N/2 - IF ((NN+NN).EQ.N) GO TO 10 - IFAX(1)=-99 - RETURN - 10 K=1 -! TEST FOR FACTORS OF 4 - 20 IF (MOD(NN,4).NE.0) GO TO 30 - K=K+1 - IFAX(K)=4 - NN=NN/4 - IF (NN.EQ.1) GO TO 80 - GO TO 20 -! TEST FOR EXTRA FACTOR OF 2 - 30 IF (MOD(NN,2).NE.0) GO TO 40 - K=K+1 - IFAX(K)=2 - NN=NN/2 - IF (NN.EQ.1) GO TO 80 -! TEST FOR FACTORS OF 3 - 40 IF (MOD(NN,3).NE.0) GO TO 50 - K=K+1 - IFAX(K)=3 - NN=NN/3 - IF (NN.EQ.1) GO TO 80 - GO TO 40 -! NOW FIND REMAINING FACTORS - 50 L=5 - INC=2 -! INC ALTERNATELY TAKES ON VALUES 2 AND 4 - 60 IF (MOD(NN,L).NE.0) GO TO 70 - K=K+1 - IFAX(K)=L - NN=NN/L - IF (NN.EQ.1) GO TO 80 - GO TO 60 - 70 L=L+INC - INC=6-INC - GO TO 60 - 80 IFAX(1)=K-1 -! IFAX(1) CONTAINS NUMBER OF FACTORS - NFAX=IFAX(1) -! SORT FACTORS INTO ASCENDING ORDER - IF (NFAX.EQ.1) GO TO 110 - DO 100 II=2,NFAX - ISTOP=NFAX+2-II - DO 90 I=2,ISTOP - IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 - ITEM=IFAX(I) - IFAX(I)=IFAX(I+1) - IFAX(I+1)=ITEM - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN - END - - subroutine fftrig (trigs,n,mode) - REAL(kind=KIND(1.0)) TRIGS(*) - integer N, MODE -!FPP$ NOVECTOR R - real(kind=KIND(1.0)) PI - integer IMODE, NN, L, I, NH, LA - real(kind=KIND(1.0)) DEL, ANGLE - PI=2.0*ASIN(1.0) - IMODE=IABS(MODE) - NN=N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 - DEL=(PI+PI)/FLOAT(NN) - L=NN+NN - DO 10 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(I)=COS(ANGLE) - TRIGS(I+1)=SIN(ANGLE) - 10 CONTINUE - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - DEL=0.5*DEL - NH=(NN+1)/2 - L=NH+NH - LA=NN+NN - DO 20 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(LA+I)=COS(ANGLE) - TRIGS(LA+I+1)=SIN(ANGLE) - 20 CONTINUE - IF (IMODE.LE.3) RETURN - DEL=0.5*DEL - LA=LA+NN - IF (MODE.EQ.5) GO TO 40 - DO 30 I=2,NN - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=2.0*SIN(ANGLE) - 30 CONTINUE - RETURN - 40 CONTINUE - DEL=0.5*DEL - DO 50 I=2,N - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=SIN(ANGLE) - 50 CONTINUE - RETURN - END - - subroutine vpassm (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la) - integer INC1,INC2,INC3,INC4,LOT,N,IFAC,LA - real(kind=KIND(1.0)) A(N),B(N),C(N),D(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA" -! PERFORMS ONE PASS THROUGH DATA -! AS PART OF MULTIPLE COMPLEX FFT ROUTINE -! A IS FIRST REAL INPUT VECTOR -! B IS FIRST IMAGINARY INPUT VECTOR -! C IS FIRST REAL OUTPUT VECTOR -! D IS FIRST IMAGINARY OUTPUT VECTOR -! TRIGS IS PRECALCULATED TABLE OF SINES & COSINES -! INC1 IS ADDRESSING INCREMENT FOR A AND B -! INC2 IS ADDRESSING INCREMENT FOR C AND D -! INC3 IS ADDRESSING INCREMENT BETWEEN As & Bs -! INC4 IS ADDRESSING INCREMENT BETWEEN Cs & Ds -! LOT IS THE NUMBER OF VECTORS -! N IS LENGTH OF VECTORS -! IFAC IS CURRENT FACTOR OF N -! LA IS PRODUCT OF PREVIOUS FACTORS -! - real(kind=KIND(1.0)) SIN36, COS36, SIN72, COS72, SIN60 - DATA SIN36/0.587785252292473/,COS36/0.809016994374947/, - * SIN72/0.951056516295154/,COS72/0.309016994374947/, - * SIN60/0.866025403784437/ - integer M, IINK, JINK, JUMP, IBASE, JBASE, IGO, IA, JA, IB, JB - integer IC, JC, ID, JD, IE, JE - integer I, J, K, L, IJK, LA1, KB, KC, KD, KE - real(kind=KIND(1.0)) C1, S1, C2, S2, C3, S3, C4, S4 -! -!FPP$ NOVECTOR R - M=N/IFAC - IINK=M*INC1 - JINK=LA*INC2 - JUMP=(IFAC-1)*JINK - IBASE=0 - JBASE=0 - IGO=IFAC-1 - IF (IGO.GT.4) RETURN - GO TO (10,50,90,130),IGO -! -! CODING FOR FACTOR 2 -! - 10 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - DO 20 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 15 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=A(IA+I)-A(IB+I) - D(JB+J)=B(IA+I)-B(IB+I) - I=I+INC3 - J=J+INC4 - 15 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 20 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 40 K=LA1,M,LA - KB=K+K-2 - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - DO 30 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 25 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) - D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) - I=I+INC3 - J=J+INC4 - 25 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 30 CONTINUE - JBASE=JBASE+JUMP - 40 CONTINUE - RETURN -! -! CODING FOR FACTOR 3 -! - 50 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - DO 60 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 55 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))) - C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))) - D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))) - D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))) - I=I+INC3 - J=J+INC4 - 55 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 60 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 80 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - DO 70 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 65 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)= - * C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - D(JB+J)= - * S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - C(JC+J)= - * C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - D(JC+J)= - * S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - I=I+INC3 - J=J+INC4 - 65 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 70 CONTINUE - JBASE=JBASE+JUMP - 80 CONTINUE - RETURN -! -! CODING FOR FACTOR 4 -! - 90 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - DO 100 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 95 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) - C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) - C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) - D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) - D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) - I=I+INC3 - J=J+INC4 - 95 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 100 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 120 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - DO 110 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 105 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - C(JC+J)= - * C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - D(JC+J)= - * S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - C(JB+J)= - * C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - D(JB+J)= - * S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - C(JD+J)= - * C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - D(JD+J)= - * S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 105 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 110 CONTINUE - JBASE=JBASE+JUMP - 120 CONTINUE - RETURN -! -! CODING FOR FACTOR 5 -! - 130 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - IE=ID+IINK - JE=JD+JINK - DO 140 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 135 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 135 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 140 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 160 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - KE=KD+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - C4=TRIGS(KE+1) - S4=TRIGS(KE+2) - DO 150 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 145 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)= - * C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JB+J)= - * S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JE+J)= - * C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JE+J)= - * S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JC+J)= - * C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JC+J)= - * S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - C(JD+J)= - * C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JD+J)= - * S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - I=I+INC3 - J=J+INC4 - 145 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 150 CONTINUE - JBASE=JBASE+JUMP - 160 CONTINUE - RETURN - END -#endif /* _REDUNDANT_ */ - - subroutine bin ( qin,im_in,jm_in,qout,im_out,jm_out,lm,undef,msgn,lat_i,lat_o ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lat_i - type ( dynamics_lattice_type ) lat_o - -#ifdef mpi - include 'mpif.h' -#endif - integer comm,myid,npes - integer imgi,jmgi,imgo,jmgo - - integer im_in ,jm_in ,msgn, lm - integer im_out,jm_out, L - real undef - real qin(im_in ,jm_in ,lm) - real qout(im_out,jm_out,lm) - - real, allocatable :: glo_i(:,:,:) - real, allocatable :: glo_o(:,:,:) - -c Temporary Array for Binning -c --------------------------- - integer imax - integer jmax - parameter ( imax = 360*12 ) - parameter ( jmax = 180*12 ) - real qbin ( imax,jmax ) - - integer index(lm),ierror - - call timebeg (' bin') - - comm = lat_i%comm - myid = lat_i%myid - npes = lat_i%nx * lat_i%ny - - imgi = lat_i%imglobal - jmgi = lat_i%jmglobal - imgo = lat_o%imglobal - jmgo = lat_o%jmglobal - - allocate ( glo_i(imgi,jmgi,lm) ) - allocate ( glo_o(imgo,jmgo,lm) ) - - call timebeg (' Gather') - do L=1,lm - call gather_2d ( glo_i(1,1,L),qin(1,1,L),lat_i ) - enddo - call timeend (' Gather') -#ifdef mpi - call mpi_bcast ( glo_i,imgi*jmgi*lm,lat_i%mpi_rkind,0,comm,ierror ) -#endif - - do L=1,lm - index(L) = mod(L-1,npes) - enddo - - do L=1,lm -c Parse Arbitray Field (im,jm) to 5'x5' Variable -c ---------------------------------------------- - call timebeg (' bin_q') - if( index(L).eq.myid ) call bin_q ( glo_i(1,1,L),imgi,jmgi,qbin,imax,jmax ) - call timeend (' bin_q') - -c Bin 10'x10' Variable to Output Field (im_out,jm_out) -c ---------------------------------------------------- - call timebeg (' ave_q') - if( index(L).eq.myid ) call ave_q ( qbin,imax,jmax,glo_o(1,1,L),imgo,jmgo,undef,msgn ) - call timeend (' ave_q') - enddo - -#ifdef mpi - call mpi_barrier (comm,ierror) - do L=1,lm - call mpi_bcast ( glo_o(1,1,L),imgo*jmgo,lat_o%mpi_rkind,index(L),comm,ierror ) - enddo - call mpi_barrier (comm,ierror) -#endif - call timebeg (' Scatter') - do L=1,lm - call scatter_2d ( glo_o(1,1,L),qout(1,1,L),lat_o ) - enddo - call timeend (' Scatter') - - deallocate ( glo_i ) - deallocate ( glo_o ) - - call timeend (' bin') - - return - end - - subroutine ave_q ( qbin,imax,jmax,q,im,jm,undef,msgn ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Average a (10m X 10m) input array to an output array (im,jm) -C -C INPUT: -C ====== -C qbin ....... Input array (imax,jmax) -C msgn ....... Integer Flag for scalar (0) or vector (1) -C -C OUTPUT: -C ======= -C q .......... Output array (im,jm) -C im ......... Longitudinal dimension of q -C jm ......... Latitudinal dimension of q -C -C NOTES: -C ====== -C Input array qbin represents values within a 5min X 5min grid-box. -C Each box is referenced by the latitude and longitude of -C its southwest corner, not its center point. Thus, -C the quantity associated with a coordinate actually -C represents the quantity centered to the northeast of that point. -C -C Output array q(im,jm) is assumed to be on an A-grid. -C q(i,j) represents the value at the center of the grid-box. -C q(1,j) is located at lon=-180. -C q(i,1) is located at lat=-90. -C q(i,jm) is located at lat=+90. -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer im,jm,msgn - real q(im,jm) - real dlam(im), dphi(jm) - - integer imax - integer jmax - real qbin ( imax,jmax ) - - integer i,j,ibeg,iend,jbeg,jend - integer ii,jj,itmp - real sum1,sum2 - real zlat,zlon - real lon1,lon2,wx - real lat1,lat2,wy - real lonbeg,lonend,lat,coslat - real latbeg,latend - real undef - real pi,dz - real lon_cmp(im) - real lat_cmp(jm) - logical defined - - pi = 4.*atan(1.0) - dlam = 2*pi/ im - dphi = pi/(jm-1) - dz = pi/(jmax) - -c Compute Computational Lambda's and Phi's -c ---------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - - -c Compute average away from poles -c ------------------------------- - do j=2,jm-1 - do i=1,im - - zlat = lat_cmp(j) - zlon = lon_cmp(i) - - latbeg = zlat-dphi(j-1)/2 - latend = zlat+dphi(j) /2 - if( i.eq.1 ) then - lonbeg = zlon-dlam(im) /2 - else - lonbeg = zlon-dlam(i-1)/2 - endif - lonend = zlon+dlam(i) /2 - - ibeg = 1.+(lonbeg+pi) /dz - iend = 1.+(lonend+pi) /dz - jbeg = 1.+(latbeg+pi/2)/dz - jend = 1.+(latend+pi/2)/dz - - sum1 = 0 - sum2 = 0 - do jj=jbeg,jend - lat = -pi/2+(jj-0.5)*dz - coslat = cos(lat) - lat1 = -pi/2 + (jj-1)*dz - lat2 = -pi/2 + jj *dz - wy = 1.0 - if( lat1.lt.latbeg ) wy = (lat2-latbeg)/dz - if( lat2.gt.latend ) wy = (latend-lat1)/dz - - if(ibeg.ge.1) then - do ii=ibeg,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - else - itmp = 1.+(lonbeg+0.1*dz+3*pi)/dz - do ii=itmp,imax - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg+2*pi ) wx = (lon2-lonbeg-2*pi)/dz - if( lon2.gt.lonend+2*pi ) wx = (2*pi+lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - do ii=1,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - endif - - enddo - q(i,j) = sum1/sum2 - enddo - enddo - -c Compute average at South Pole -c ----------------------------- - j=1 - do i=1,im - - zlat = lat_cmp(j) - zlon = lon_cmp(i) - - latbeg = zlat - latend = zlat+dphi(j) /2 - if( i.eq.1 ) then - lonbeg = zlon-dlam(im) /2 - else - lonbeg = zlon-dlam(i-1)/2 - endif - lonend = zlon+dlam(i) /2 - - ibeg = 1.+(lonbeg+pi) /dz - iend = 1.+(lonend+pi) /dz - jbeg = 1 - jend = 1.+(latend+pi/2)/dz - - sum1 = 0 - sum2 = 0 - do jj=jbeg,jend - lat = -pi/2+(jj-0.5)*dz - coslat = cos(lat) - lat1 = -pi/2 + (jj-1)*dz - lat2 = -pi/2 + jj *dz - wy = 1.0 - if( lat1.lt.latbeg ) wy = (lat2-latbeg)/dz - if( lat2.gt.latend ) wy = (latend-lat1)/dz - - if(ibeg.ge.1) then - do ii=ibeg,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - else - itmp = 1.+(lonbeg+0.1*dz+3*pi)/dz - do ii=itmp,imax - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg+2*pi ) wx = (lon2-lonbeg-2*pi)/dz - if( lon2.gt.lonend+2*pi ) wx = (2*pi+lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - do ii=1,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - endif - - enddo - q(i,j) = sum1/sum2 - enddo - -c Compute average at North Pole -c ----------------------------- - j=jm - do i=1,im - - zlat = lat_cmp(j) - zlon = lon_cmp(i) - - latbeg = zlat-dphi(j-1)/2 - latend = zlat - if( i.eq.1 ) then - lonbeg = zlon-dlam(im) /2 - else - lonbeg = zlon-dlam(i-1)/2 - endif - lonend = zlon+dlam(i) /2 - - ibeg = 1.+(lonbeg+pi) /dz - iend = 1.+(lonend+pi) /dz - jbeg = 1.+(latbeg+pi/2)/dz - jend = jmax - - sum1 = 0 - sum2 = 0 - do jj=jbeg,jend - lat = -pi/2+(jj-0.5)*dz - coslat = cos(lat) - lat1 = -pi/2 + (jj-1)*dz - lat2 = -pi/2 + jj *dz - wy = 1.0 - if( lat1.lt.latbeg ) wy = (lat2-latbeg)/dz - if( lat2.gt.latend ) wy = (latend-lat1)/dz - - if(ibeg.ge.1) then - do ii=ibeg,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - else - itmp = 1.+(lonbeg+0.1*dz+3*pi)/dz - do ii=itmp,imax - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg+2*pi ) wx = (lon2-lonbeg-2*pi)/dz - if( lon2.gt.lonend+2*pi ) wx = (2*pi+lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - do ii=1,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - endif - - enddo - q(i,j) = sum1/sum2 - enddo - -c Average Pole Values -c ------------------- - if( msgn.eq.0 ) then - sum1 = 0 - j = 0 - do i=1,im - if( defined(q(i,1),undef) ) then - sum1 = sum1 + q(i,1) - j = j + 1 - endif - enddo - if( j.ne.0 ) then - q(:,1) = sum1/j - else - q(:,1) = undef - endif - - sum2 = 0 - j = 0 - do i=1,im - if( defined(q(i,jm),undef) ) then - sum2 = sum2 + q(i,jm) - j = j + 1 - endif - enddo - if( j.ne.0 ) then - q(:,jm) = sum2/j - else - q(:,jm) = undef - endif - - endif - - return - end - subroutine bin_q ( q,im,jm,qbin,imax,jmax ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute a 5min X 5min binned array from an input array q(im,jm) -C -C INPUT: -C ====== -C q .......... Input array(im,jm) -C im ......... Longitudinal dimension of q -C jm ......... Latitudinal dimension of q -C -C OUTPUT: -C ======= -C qbin ....... Output array (imax,jmax) -C -C NOTES: -C ====== -C Input array q(im,jm) is assumed to be on an A-grid. -C q(i,j) represents the value at the center of the grid-box. -C q(1,j) is located at lon=-180. -C q(i,1) is located at lat=-90. -C q(i,jm) is located at lat=+90. -C -C Output array qbin represents values within a 5min X 5min grid-box. -C Each box is referenced by the latitude and longitude of -C its southwest corner, not its center point. Thus, -C the quantity associated with a coordinate actually -C represents the quantity centered to the northeast of that point. -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer im,jm - real q(im,jm) - - integer imax - integer jmax - real qbin ( imax,jmax ) - - integer i,j,ii,jj,ibeg,iend,jbeg,jend - real zlatc,zlonc - real lonbeg,lonend - real latbeg,latend - real pi,dl,dp,dz - - pi = 4.*atan(1.0) - dl = 2*pi/im - dp = pi/(jm-1) - dz = pi/(jmax) - - do j=1,jmax - do i=1,imax - - zlatc = -pi/2+(j-0.5)*dz ! Latitude at center of bin box - zlonc = -pi +(i-0.5)*dz ! Longitude at center of bin box - -c Find bounding lat and lon on IMxJM grid -c --------------------------------------- - iend = nint( 1.+(zlonc+pi)/dl ) - lonend = -pi + (iend-1)*dl - if( lonend.ge.zlonc ) then - lonbeg = -pi + (iend-2)*dl - else - iend = iend+1 - lonbeg = lonend - lonend = -pi + (iend-1)*dl - endif - ibeg = iend-1 - - jend = nint( 1.+(zlatc+pi/2)/dp ) - latend = -pi/2 + (jend-1)*dp - if( latend.ge.zlatc ) then - latbeg = -pi/2 + (jend-2)*dp - else - jend = jend+1 - latbeg = latend - latend = -pi/2 + (jend-1)*dp - endif - jbeg = jend-1 - - - if(iend.gt.im) iend=iend-im - - if( zlonc.le.lonbeg+0.5*dl ) then - ii = ibeg - else - ii = iend - endif - if( zlatc.le.latbeg+0.5*dp ) then - jj = jbeg - else - jj = jend - endif - - qbin(i,j) = q(ii,jj) - - enddo - enddo - - return - end - - subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef,lat_i,lat_o,flag ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lat_i - type ( dynamics_lattice_type ) lat_o -#ifdef mpi - include 'mpif.h' -#endif - integer comm,myid,npes - - integer iin,jin, iout,jout, mlev, flag - real qin(iin,jin,mlev), qout(iout,jout,mlev) - real undef,pi,dlin,dpin,dlout,dpout,lon,lat - integer i,j,L,loc - integer index(mlev),ierror - integer imgi,jmgi,imgo,jmgo - - real, allocatable :: glo_i(:,:,:) - real, allocatable :: glo_o(:,:,:) - real, allocatable :: lons(:), dlam(:) - real, allocatable :: lats(:), dphi(:) - - call timebeg (' hinterp') - - comm = lat_i%comm - myid = lat_i%myid - npes = lat_i%nx * lat_i%ny - - imgi = lat_i%imglobal - jmgi = lat_i%jmglobal - imgo = lat_o%imglobal - jmgo = lat_o%jmglobal - - allocate ( glo_i(imgi,jmgi,mlev) ) - allocate ( glo_o(imgo,jmgo,mlev) ) - allocate ( lons(imgo*jmgo) ) - allocate ( lats(imgo*jmgo) ) - allocate ( dlam(imgi) ) - allocate ( dphi(jmgi) ) - - do L=1,mlev - index(L) = mod(L-1,npes) - enddo - - pi = 4.0*atan(1.0) - dlin = 2*pi/ imgi - dpin = pi/(jmgi-1) - dlam(:) = dlin - dphi(:) = dpin - - dlout = 2*pi/ imgo - dpout = pi/(jmgo-1) - - loc = 0 - do j=1,jmgo - do i=1,imgo - loc = loc + 1 - lon = -pi + (i-1)*dlout - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jmgo - lat = -pi/2.0 + (j-1)*dpout - do i=1,imgo - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call timebeg (' Gather') - do L=1,mlev - call gather_2d ( glo_i(1,1,L),qin(1,1,L),lat_i ) - enddo - call timeend (' Gather') -#ifdef mpi - call mpi_bcast ( glo_i,imgi*jmgi*mlev,lat_i%mpi_rkind,0,comm,ierror ) -#endif - - do L=1,mlev - if( index(L).eq.myid ) then - call interp_h ( glo_i(1,1,L),imgi,jmgi,1,dlam,dphi, - . glo_o(1,1,L),imgo*jmgo,lons,lats,undef,flag ) - endif - enddo - -#ifdef mpi - call mpi_barrier (comm,ierror) - do L=1,mlev - call mpi_bcast ( glo_o(1,1,L),imgo*jmgo,lat_o%mpi_rkind,index(L),comm,ierror ) - enddo - call mpi_barrier (comm,ierror) -#endif - call timebeg (' Scatter') - do L=1,mlev - call scatter_2d ( glo_o(1,1,L),qout(1,1,L),lat_o ) - enddo - call timeend (' Scatter') - - deallocate ( glo_i ) - deallocate ( glo_o ) - deallocate ( lons ) - deallocate ( lats ) - deallocate ( dlam ) - deallocate ( dphi ) - - call timeend (' hinterp') - return - end - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*undef - return - end - - subroutine interp_h ( q_cmp,im,jm,lm,dlam,dphi, - . q_geo,irun,lon_geo,lat_geo,undef,flag ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C flag ....... Integer Flag to force Linear (Positive-Definite) Interpolation -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun,flag - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - -c Local Variables -c --------------- - integer i,j,l - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real ap1, ap0, am1, am2 - real bp1, bp0, bm1, bm2 - - real lon_cmp(im) - real lat_cmp(jm) - real q_tmp(irun) - - real pi,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp - real lam_cmp - real phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - do i=1,irun - lam_cmp = lon_geo(i) - phi_cmp = lat_geo(i) - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm2 = lat_cmp(jm2(i)) - phi_jm1 = lat_cmp(jm1(i)) - phi_jp0 = lat_cmp(jp0(i)) - phi_jp1 = lat_cmp(jp1(i)) - - if( jm2(i).eq.0 ) phi_jm2 = phi_jm1 - dphi(1) - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - endif - if( jp1(i).eq.jm+1 ) phi_jp1 = phi_jp0 + dphi(jm-1) - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - -c Interpolate Computational-Grid Quantities to Geophysical Grid -c ------------------------------------------------------------- - do L=1,lm - do i=1,irun - - if( lat_geo(i).le.lat_cmp(2) .or. - . lat_geo(i).ge.lat_cmp(jm-1) .or. flag.eq.1 ) then - -c 1st Order Interpolation at Poles -c -------------------------------- - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - else - -c Cubic Interpolation away from Poles -c ----------------------------------- - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jp1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp1(i),L ).ne.undef .and. - . q_cmp( im2(i),jp1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm2(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm2(i),L ).ne.undef .and. - . q_cmp( im1(i),jm2(i),L ).ne.undef .and. - . q_cmp( im2(i),jm2(i),L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) - . + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) - . + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) - . + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) - . + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) - . + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) - . + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - return - end - - subroutine remap ( ple,u,v,t_in,q,o3,phis_in,phis_out,ak,bk,im,jm,lm,ihaveth ) - -C*********************************************************************** -C -C Purpose -C Driver for remapping fields to new topography -C -C Argument Description -C ple ...... model edge pressure -C u ....... model zonal wind -C v ....... model meridional wind -C thv ..... model virtual potential temperature -C q ....... model specific humidity -C o3 ...... model ozone -C phis_in... model surface geopotential (input) -C phis_out.. model surface geopotential (output) -C ak ....... model vertical dimension -C bk ....... model vertical dimension -C -C im ....... zonal dimension -C jm ....... meridional dimension -C lm ....... meridional dimension -C -C ihaveth .. when .t., thv array has th not thv -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer im,jm,lm - logical ihaveth - -c Input variables -c --------------- - real ple(im,jm,lm+1) - real u(im,jm,lm) - real v(im,jm,lm) - real t_in(im,jm,lm) - real q(im,jm,lm) - real o3(im,jm,lm) - real phis_in (im,jm) - real phis_out(im,jm) - - real*8 ak(lm+1) - real*8 bk(lm+1) - -c Local variables -c --------------- - real ps (im,jm) - real phi (im,jm,lm+1) - real pke (im,jm,lm+1) - real thv (im,jm,lm) - real ple_out(im,jm,lm+1) - real pke_out(im,jm,lm+1) - - real u_out(im,jm,lm) - real v_out(im,jm,lm) - real thv_out(im,jm,lm) - real q_in (im,jm,lm,2) - real q_out(im,jm,lm,2) - - real kappa,cp,rgas,eps,rvap - integer i,j,L - - kappa = 2.0/7.0 - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - cp = rgas/kappa - -c If dry theta instead of virtual -c ------------------------------- - if(ihaveth) then - thv = t_in*(1+eps*q) - else - thv = t_in - endif - -c Construct Input Heights -c ----------------------- - pke(:,:,:) = ple(:,:,:)**kappa - - phi(:,:,lm+1) = phis_in(:,:) - do L=lm,1,-1 - phi(:,:,L) = phi(:,:,L+1) + cp*thv(:,:,L)*( pke(:,:,L+1)-pke(:,:,L) ) - enddo - -c Compute new surface pressure consistent with output topography -c -------------------------------------------------------------- - do j=1,jm - do i=1,im - L = lm - do while ( phi(i,j,L).lt.phis_out(i,j) ) - L = L-1 - enddo - ps(i,j) = ple(i,j,L+1)*( 1+(phi(i,j,L+1)-phis_out(i,j))/(cp*thv(i,j,L)*pke(i,j,L+1)) )**(1.0/kappa) - enddo - enddo - -c Construct fv pressure variables using new surface pressure -c ---------------------------------------------------------- - do L=1,lm+1 - do j=1,jm - do i=1,im - ple_out(i,j,L) = ak(L) + bk(L)*ps(i,j) - enddo - enddo - enddo - pke_out(:,:,:) = ple_out(:,:,:)**kappa - -c Map original fv state onto new eta grid -c --------------------------------------- - q_in(:,:,:,1) = q(:,:,:) - q_in(:,:,:,2) = o3(:,:,:) - - call gmap ( im,jm,2 , kappa, - . lm, pke ,ple ,u ,v ,t_in ,q_in , - . lm, pke_out,ple_out,u_out,v_out,thv_out,q_out) - - ple(:,:,:) = ple_out(:,:,:) - u(:,:,:) = u_out(:,:,:) - v(:,:,:) = v_out(:,:,:) - thv(:,:,:) = thv_out(:,:,:) - q(:,:,:) = q_out(:,:,:,1) - o3(:,:,:) = q_out(:,:,:,2) - - return - end - subroutine write_d ( lu, u,v,ple,im,jm,lm,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - integer im,jm,lm - real u(im,jm,lm) - real v(im,jm,lm) - real dp(im,jm,lm) - real div(im,jm,lm) - real ple(im,jm,lm+1) - - integer index(lm),ierror - - integer :: lu - real, allocatable :: uglo(:,:,:) - real, allocatable :: vglo(:,:,:) - real, allocatable :: dpglo(:,:,:) - real, allocatable :: dglo(:,:,:) - - real, allocatable :: sum1(:,:) - real*4, allocatable :: dum(:,:) - - integer L, comm, myid, npes - integer img, jmg - - img = lattice%imglobal - jmg = lattice%jmglobal - comm = lattice%comm - myid = lattice%myid - npes = lattice%nx * lattice%ny - - do L=1,lm - index (L) = mod(L-1,npes) - dp(:,:,L) = ( ple(:,:,L+1)-ple(:,:,L) ) - enddo - - allocate ( uglo(img,jmg,lm) ) - allocate ( vglo(img,jmg,lm) ) - allocate ( dglo(img,jmg,lm) ) - allocate ( dpglo(img,jmg,lm) ) - allocate ( dum(img,jmg) ) - allocate ( sum1(im,jm) ) - -! Construct A-Grid Winds -! ---------------------- - do L=1,lm - call gather_2d ( uglo(1,1,L), u(1,1,L),lattice ) - call gather_2d ( vglo(1,1,L), v(1,1,L),lattice ) - call gather_2d ( dpglo(1,1,L),dp(1,1,L),lattice ) - if( lattice%myid.eq.0 ) then - call dtoa ( uglo(1,1,L),uglo(1,1,L),img,jmg,1,2 ) - call dtoa ( vglo(1,1,L),vglo(1,1,L),img,jmg,1,1 ) - endif - enddo -#ifdef mpi - call mpi_bcast ( uglo,img*jmg*lm,lattice%mpi_rkind,0,comm,ierror ) - call mpi_bcast ( vglo,img*jmg*lm,lattice%mpi_rkind,0,comm,ierror ) - call mpi_bcast ( dpglo,img*jmg*lm,lattice%mpi_rkind,0,comm,ierror ) -#endif - -c Compute Mass-Weighted Divergence -c -------------------------------- - do L=1,lm - if( index(L).eq.myid ) call getdiv (uglo(1,1,L),vglo(1,1,L),dpglo(1,1,L),dglo(1,1,L),img,jmg ) - enddo -#ifdef mpi - call mpi_barrier (comm,ierror) - do L=1,lm - call mpi_bcast ( dglo(1,1,L),img*jmg,lattice%mpi_rkind,index(L),comm,ierror ) - enddo - call mpi_barrier (comm,ierror) -#endif - do L=1,lm - call scatter_2d ( dglo(1,1,L),div(1,1,L),lattice ) - enddo - -c Modify Divergence (to force vanishing vertical integral) -c -------------------------------------------------------- - sum1(:,:) = 0.0 - do L=1,lm - sum1(:,:) = sum1(:,:) + div(:,:,L) - enddo - -c Gather and Broadcast Divergence -c ------------------------------- - call gather_2d ( dglo(1,1,1),sum1,lattice ) - - if( lattice%myid.eq.0 ) then - dum(:,:) = dglo(:,:,1) - write(lu) dum - endif - - deallocate ( sum1,dum ) - deallocate ( uglo,vglo,dglo,dpglo ) - return - end diff --git a/GEOS_Util/post/makeiau.F b/GEOS_Util/post/makeiau.F deleted file mode 100644 index 500b5e9e..00000000 --- a/GEOS_Util/post/makeiau.F +++ /dev/null @@ -1,3672 +0,0 @@ - program main -!#define debug - -! ********************************************************************** -! ********************************************************************** -! **** **** -! **** Program to Create IAU from ANA.ETA and BKG.ETA Files **** -! **** **** -! **** Note: BKG files are interpolated/binned to the ANA **** -! **** resolution. The resulting IAU forcing is then **** -! **** binned/interpolated back to the Model resolution. **** -! **** **** -! **** !REVISION HISTORY: **** -! **** 02Apr2006 Todling dummy arrays to r*8 (gfio-r8) **** -! **** 03Apr2006 Todling added O3 increment **** -! **** 21Jun2006 Takacs Added BKG and ANA of different **** -! **** resolutions, implemented MPI **** -! **** 21Apr2007 Todling Removed delp; bypass dtoa; thv to tv **** -! **** 03Jun2008 Todling Removed dtoa for real **** -! **** 01Jul2008 Daescu Add -scale opt for obs impact **** -! **** 04Mar2009 RT/Nadeau - Char length fom 128 to 256 **** -! **** - hdf suffix to nc4 **** -! **** 12Mar2009 Takacs/RT - Merged FDDA w/ 530; interp ainc-out **** -! **** 01Apr2009 Takacs Made Backward Compatable for DGrid case **** -! **** 12Jun2012 Todling/Akella - add DTSDT increment **** -! **** **** -! ********************************************************************** -! ********************************************************************** - - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice_ana - type ( dynamics_lattice_type ) lattice_bkg - type ( dynamics_lattice_type ) lattice_out - include 'mpif.h' - integer comm,myid,npes,ierror - - integer imaglobal,jmaglobal - integer imbglobal,jmbglobal - integer imoglobal,jmoglobal - integer npex,npey - - integer nymd,nhms - integer ima,jma,lm - integer imb,jmb - integer imo,jmo - - real sclinc ! variable for parametric increment (obs impact) - - integer ntime,nvars,ngatts,timinc - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - character*80 bkgeta, anaeta, iaueta, biasin, biasout - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - -! BIAS Variables -! -------------- - real, allocatable :: psb_ana(:,:) - real, allocatable :: tsb_ana(:,:) , tsb_bkg(:,:) - real, allocatable :: ub_ana(:,:,:) , ub_bkg(:,:,:) - real, allocatable :: vb_ana(:,:,:) , vb_bkg(:,:,:) - real, allocatable :: tb_ana(:,:,:) , tb_bkg(:,:,:) - real, allocatable :: qb_ana(:,:,:) , qb_bkg(:,:,:) - real, allocatable :: pb_ana(:,:,:) , pb_bkg(:,:,:) - real, allocatable :: o3b_ana(:,:,:) , o3b_bkg(:,:,:) - -! ANA and BKG Variables -! --------------------- - real, allocatable :: u_ana(:,:,:) , u_bkg(:,:,:) - real, allocatable :: v_ana(:,:,:) , v_bkg(:,:,:) - real, allocatable :: t_bkg(:,:,:) - real, allocatable :: tv_ana(:,:,:) , tv_bkg(:,:,:) - real, allocatable :: thv_ana(:,:,:) , thv_bkg(:,:,:) - real, allocatable :: pk_ana(:,:,:) , pk_bkg(:,:,:) - real, allocatable :: ple_ana(:,:,:) , ple_bkg(:,:,:) - real, allocatable :: pke_ana(:,:,:) , pke_bkg(:,:,:) - real, allocatable :: q_ana(:,:,:) , q_bkg(:,:,:) - real, allocatable :: o3_ana(:,:,:) , o3_bkg(:,:,:) - real, allocatable :: ps_ana(:,:) , ps_bkg(:,:) - real, allocatable :: ts_ana(:,:) , ts_bkg(:,:) - real, allocatable :: phis_ana(:,:) ,phis_bkg(:,:) - real, allocatable :: ak(:) - real, allocatable :: bk(:) - real, allocatable :: pref(:) - - real, allocatable :: uglo(:,:) - real, allocatable :: vglo(:,:) - - real, pointer :: u_tmp(:,:,:) - real, pointer :: v_tmp(:,:,:) - real, pointer :: t_tmp(:,:,:) - real, pointer :: thv_tmp(:,:,:) - real, pointer :: pk_tmp(:,:,:) - real, pointer :: ple_tmp(:,:,:) - real, pointer :: pke_tmp(:,:,:) - real, pointer :: q_tmp(:,:,:) - real, pointer :: o3_tmp(:,:,:) - real, pointer :: ts_tmp(:,:) - real, pointer :: phis_tmp(:,:) - - real kappa, pl,pabove,pbelow,alf - real undefa,undefb,rgas,rvap,eps - - logical lremap - logical damp - logical agrid_ana, agrid_bkg - logical dgrid_ana, dgrid_bkg - logical u_agrid_ana, u_agrid_bkg - logical v_agrid_ana, v_agrid_bkg - logical u_dgrid_ana, u_dgrid_bkg - logical v_dgrid_ana, v_dgrid_bkg - logical tvflag_ana, tvflag_bkg - logical thvflag_ana, thvflag_bkg - - character*256, allocatable :: arg(:) - character*8 date - character*2 hour - integer n,nargs,L,ID,rc,method - - real, parameter :: tauana = 21600.0 - -C ********************************************************************** -C **** Initialize MPI Environment **** -C ********************************************************************** - - call timebeg ('main') - - call mpi_init ( ierror ) ; comm = mpi_comm_world - call mpi_comm_rank ( comm,myid,ierror ) - call mpi_comm_size ( comm,npes,ierror ) - npex = nint ( sqrt( float(npes) ) ) - npey = npex - do while ( npex*npey .ne. npes ) - npex = npex-1 - npey = nint ( float(npes)/float(npex) ) - enddo - -! ********************************************************************** -! **** Initialize Filenames **** -! ********************************************************************** - - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - kappa = 2.0/7.0 - - damp = .false. - bkgeta = 'xxx' - anaeta = 'xxx' - iaueta = 'xxx' - biasin = 'xxx' - nymd = -999 - nhms = -999 - method = -999 - sclinc = 1.0 - - imoglobal = -999 - jmoglobal = -999 - - nargs = command_argument_count() - if(nargs.eq.0) call usage(myid) - allocate ( arg(nargs) ) - - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-h' ) call usage(myid) - if( trim(arg(n)).eq.'-help' ) call usage(myid) - if( trim(arg(n)).eq.'-H' ) call usage(myid) - if( trim(arg(n)).eq.'-Help' ) call usage(myid) - if( trim(arg(n)).eq.'-bkg' ) then - bkgeta = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-divr' ) method = 1 - if( trim(arg(n)).eq.'-diva' ) method = 2 - if( trim(arg(n)).eq.'-damp' ) damp = .true. - if( trim(arg(n)).eq.'-ana' ) then - anaeta = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-iau' ) then - iaueta = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-bias' ) then - biasin = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1),*) nymd - if( trim(arg(n)).eq.'-nhms' ) read(arg(n+1),*) nhms - if( trim(arg(n)).eq.'-scale' ) read(arg(n+1),*) sclinc - if( trim(arg(n)).eq.'-imout' ) read(arg(n+1),*) imoglobal - if( trim(arg(n)).eq.'-jmout' ) read(arg(n+1),*) jmoglobal - enddo - - write(date,101) nymd - write(hour,102) nhms/10000 - 101 format(i8.8) - 102 format(i2.2) - - if(trim(bkgeta).eq.'xxx') bkgeta = 'geos5.bkg.eta.' // date // '_' // hour // 'z.nc4' - if(trim(anaeta).eq.'xxx') anaeta = 'geos5.ana.eta.' // date // '_' // hour // 'z.nc4' - if(trim(iaueta).eq.'xxx') iaueta = 'geos5.iau.eta.' // date // '_' // hour // 'z.bin' - - if( (imoglobal.ne.-999 .and. jmoglobal.eq.-999) .or. - . (imoglobal.eq.-999 .and. jmoglobal.ne.-999) ) then - if( myid.eq.0 ) then - print * - print *, 'You must supply BOTH parameters: IMOUT & JMOUT!' - endif - call my_finalize - error stop 7 - stop - endif - -! ********************************************************************** -! **** Read Analysis ana File **** -! ********************************************************************** - - call timebeg(' read_ana') - if( myid.eq.0 ) then - print * - print *, 'Reading ANA File from PE: ',myid - call gfio_open ( trim(anaeta),1,ID,rc ) - call gfio_diminquire ( id,imaglobal,jmaglobal,lm,ntime,nvars,ngatts,rc ) - endif - - call mpi_bcast ( imaglobal,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( jmaglobal,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( lm,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( ntime,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( nvars,1, mpi_integer,0,comm,ierror ) - - call create_dynamics_lattice ( lattice_ana,npex,npey ) - call init_dynamics_lattice ( lattice_ana,comm,imaglobal,jmaglobal,lm ) - - ima = lattice_ana%im( lattice_ana%pei ) - jma = lattice_ana%jm( lattice_ana%pej ) - - allocate ( lon(imaglobal) ) - allocate ( lat(jmaglobal) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - agrid_ana = .false. - dgrid_ana = .false. - u_agrid_ana = .false. - v_agrid_ana = .false. - u_dgrid_ana = .false. - v_dgrid_ana = .false. - tvflag_ana = .false. - thvflag_ana = .false. - - if( myid.eq.0 ) then - call gfio_inquire ( id,imaglobal,jmaglobal,lm,ntime,nvars, - . title,source,contact,undefa, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - do n=1,nvars - if( trim(vname(n)).eq.'u' ) u_agrid_ana = .true. - if( trim(vname(n)).eq.'v' ) v_agrid_ana = .true. - if( trim(vname(n)).eq.'uwnd' ) u_dgrid_ana = .true. - if( trim(vname(n)).eq.'vwnd' ) v_dgrid_ana = .true. - if( trim(vname(n)).eq.'tv' ) tvflag_ana = .true. - if( trim(vname(n)).eq.'theta' ) thvflag_ana = .true. - enddo - agrid_ana = u_agrid_ana .and. v_agrid_ana - dgrid_ana = u_dgrid_ana .and. v_dgrid_ana - endif - - call mpi_bcast ( agrid_ana,1, mpi_logical,0,comm,ierror ) - call mpi_bcast ( dgrid_ana,1, mpi_logical,0,comm,ierror ) - call mpi_bcast ( tvflag_ana,1, mpi_logical,0,comm,ierror ) - call mpi_bcast ( thvflag_ana,1, mpi_logical,0,comm,ierror ) - call mpi_bcast ( undefa, 1,lattice_ana%mpi_rkind ,0,comm,ierror ) - call mpi_bcast ( lon,imaglobal,lattice_ana%mpi_rkind ,0,comm,ierror ) - - if( (.not. agrid_ana .and. .not. dgrid_ana) .or. - . (.not.tvflag_ana .and. .not.thvflag_ana) ) then - if( myid.eq.0 ) then - print * - print *, 'ANA_ETA file does not contain necessary data:' - print *, ' agrid: ', agrid_ana - print *, ' dgrid: ', dgrid_ana - print *, ' tv_flag: ', tvflag_ana - print *, 'thv_flag: ',thvflag_ana - endif - call my_finalize - error stop 7 - stop - endif - - allocate ( phis_ana(ima,jma) ) - allocate ( ps_ana(ima,jma) ) - allocate ( ts_ana(ima,jma) ) - allocate ( u_ana(ima,jma,lm) ) - allocate ( v_ana(ima,jma,lm) ) - allocate ( thv_ana(ima,jma,lm) ) - allocate ( q_ana(ima,jma,lm) ) - allocate ( o3_ana(ima,jma,lm) ) - allocate ( ple_ana(ima,jma,lm+1) ) - - allocate ( ak(lm+1) ) - allocate ( bk(lm+1) ) - - call getit ( id,'phis' ,nymd,nhms,ima,jma,0,1 ,phis_ana,lattice_ana ) - call getit ( id,'ps' ,nymd,nhms,ima,jma,0,1 , ps_ana,lattice_ana ) - call getit ( id,'ts' ,nymd,nhms,ima,jma,0,1 , ts_ana,lattice_ana ) - call getit ( id,'sphu' ,nymd,nhms,ima,jma,1,lm, q_ana,lattice_ana ) - call getit ( id,'ozone',nymd,nhms,ima,jma,1,lm, o3_ana,lattice_ana ) - - if( agrid_ana ) then - call getit ( id,'u' ,nymd,nhms,ima,jma,1,lm,u_ana,lattice_ana ) - call getit ( id,'v' ,nymd,nhms,ima,jma,1,lm,v_ana,lattice_ana ) - else if( dgrid_ana ) then - call getit ( id,'uwnd',nymd,nhms,ima,jma,1,lm,u_ana,lattice_ana ) - call getit ( id,'vwnd',nymd,nhms,ima,jma,1,lm,v_ana,lattice_ana ) - endif - - if( thvflag_ana ) then - call getit ( id,'theta',nymd,nhms,ima,jma,1,lm,thv_ana,lattice_ana ) - else if( tvflag_ana ) then - allocate ( tv_ana(ima,jma,lm) ) - call getit ( id,'tv' ,nymd,nhms,ima,jma,1,lm, tv_ana,lattice_ana ) - endif - - if( myid.eq.0 ) then - call gfio_getrealatt ( id,'ak',lm+1,ak,rc ) - call gfio_getrealatt ( id,'bk',lm+1,bk,rc ) - call gfio_close ( id,rc ) - endif - - call mpi_bcast ( ak,lm+1,lattice_ana%mpi_rkind,0,comm,ierror ) - call mpi_bcast ( bk,lm+1,lattice_ana%mpi_rkind,0,comm,ierror ) - - call timeend(' read_ana') - -! Construct Pressure Variables -! ---------------------------- - do L=1,lm+1 - ple_ana(:,:,L) = ak(L) + ps_ana(:,:)*bk(L) - enddo - -! Construct ANA THV (if necessary) for REMAPPING -! ---------------------------------------------- - if( tvflag_ana .and. .not.thvflag_ana ) then - allocate ( pk_ana(ima,jma,lm ) ) - allocate ( pke_ana(ima,jma,lm+1) ) - pke_ana(:,:,:) = ple_ana(:,:,:)**kappa - do L=1,lm - pk_ana(:,:,L) = ( pke_ana(:,:,L+1)-pke_ana(:,:,L) ) - . / ( kappa*log(ple_ana(:,:,L+1)/ple_ana(:,:,L)) ) - enddo - thv_ana = tv_ana/pk_ana - deallocate ( tv_ana ) - deallocate ( pk_ana ) - deallocate ( pke_ana ) - endif - - if( myid.eq.0 ) print *, 'Analysis ANA File begins at Lon: ',lon(1) - if( lon(1) .eq. 0.0 ) then - if( myid.eq.0 ) print *, ' Flipping Horizontal Coordinate' - call hflip (phis_ana,ima,jma,1 ,lattice_ana ) - call hflip ( ts_ana,ima,jma,1 ,lattice_ana ) - call hflip ( u_ana,ima,jma,lm ,lattice_ana ) - call hflip ( v_ana,ima,jma,lm ,lattice_ana ) - call hflip ( thv_ana,ima,jma,lm ,lattice_ana ) - call hflip ( q_ana,ima,jma,lm ,lattice_ana ) - call hflip ( o3_ana,ima,jma,lm ,lattice_ana ) - call hflip ( ple_ana,ima,jma,lm+1,lattice_ana ) - endif - - deallocate ( lon ) - deallocate ( lat ) - deallocate ( lev ) - deallocate ( yymmdd ) - deallocate ( hhmmss ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( kmvar ) - deallocate ( vrange ) - deallocate ( prange ) - -! ********************************************************************** -! **** Read Background bkg File **** -! ********************************************************************** - - call timebeg(' read_bkg') - if( myid.eq.0 ) then - print * - print *, 'Reading BKG File from PE: ',myid - call gfio_open ( trim(bkgeta),1,ID,rc ) - call gfio_diminquire ( id,imbglobal,jmbglobal,lm,ntime,nvars,ngatts,rc ) - endif - - call mpi_bcast ( imbglobal,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( jmbglobal,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( lm,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( ntime,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( nvars,1, mpi_integer,0,comm,ierror ) - - call create_dynamics_lattice ( lattice_bkg,npex,npey ) - call init_dynamics_lattice ( lattice_bkg,comm,imbglobal,jmbglobal,lm ) - - imb = lattice_bkg%im( lattice_bkg%pei ) - jmb = lattice_bkg%jm( lattice_bkg%pej ) - - allocate ( lon(imbglobal) ) - allocate ( lat(jmbglobal) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - agrid_bkg = .false. - dgrid_bkg = .false. - u_agrid_bkg = .false. - v_agrid_bkg = .false. - u_dgrid_bkg = .false. - v_dgrid_bkg = .false. - tvflag_bkg = .false. - thvflag_bkg = .false. - - if( myid.eq.0 ) then - call gfio_inquire ( id,imbglobal,jmbglobal,lm,ntime,nvars, - . title,source,contact,undefb, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - do n=1,nvars - if( trim(vname(n)).eq.'u' ) u_agrid_bkg = .true. - if( trim(vname(n)).eq.'v' ) v_agrid_bkg = .true. - if( trim(vname(n)).eq.'uwnd' ) u_dgrid_bkg = .true. - if( trim(vname(n)).eq.'vwnd' ) v_dgrid_bkg = .true. - if( trim(vname(n)).eq.'tv' ) tvflag_bkg = .true. - if( trim(vname(n)).eq.'theta' ) thvflag_bkg = .true. - enddo - agrid_bkg = u_agrid_bkg .and. v_agrid_bkg - dgrid_bkg = u_dgrid_bkg .and. v_dgrid_bkg - endif - - call mpi_bcast ( agrid_bkg,1, mpi_logical,0,comm,ierror ) - call mpi_bcast ( dgrid_bkg,1, mpi_logical,0,comm,ierror ) - call mpi_bcast ( tvflag_bkg,1, mpi_logical,0,comm,ierror ) - call mpi_bcast ( thvflag_bkg,1, mpi_logical,0,comm,ierror ) - call mpi_bcast ( undefb, 1,lattice_bkg%mpi_rkind, 0,comm,ierror ) - call mpi_bcast ( lon,imbglobal,lattice_bkg%mpi_rkind, 0,comm,ierror ) - - allocate ( phis_bkg(imb,jmb) ) - allocate ( ts_bkg(imb,jmb) ) - allocate ( ps_bkg(imb,jmb) ) - allocate ( pk_bkg(imb,jmb,lm) ) - allocate ( pke_bkg(imb,jmb,lm+1) ) - allocate ( thv_bkg(imb,jmb,lm) ) - - allocate ( u_bkg(imb,jmb,lm) ) - allocate ( v_bkg(imb,jmb,lm) ) - allocate ( t_bkg(imb,jmb,lm) ) - allocate ( q_bkg(imb,jmb,lm) ) - allocate ( o3_bkg(imb,jmb,lm) ) - allocate ( ple_bkg(imb,jmb,lm+1) ) - - call getit ( id,'phis' ,nymd,nhms,imb,jmb,0,1 ,phis_bkg,lattice_bkg ) - call getit ( id,'ps' ,nymd,nhms,imb,jmb,0,1 , ps_bkg,lattice_bkg ) - call getit ( id,'ts' ,nymd,nhms,imb,jmb,0,1 , ts_bkg,lattice_bkg ) - call getit ( id,'sphu' ,nymd,nhms,imb,jmb,1,lm, q_bkg,lattice_bkg ) - call getit ( id,'ozone',nymd,nhms,imb,jmb,1,lm, o3_bkg,lattice_bkg ) - - if( agrid_bkg ) then - call getit ( id,'u' ,nymd,nhms,imb,jmb,1,lm,u_bkg,lattice_bkg ) - call getit ( id,'v' ,nymd,nhms,imb,jmb,1,lm,v_bkg,lattice_bkg ) - else if( dgrid_bkg ) then - call getit ( id,'uwnd',nymd,nhms,imb,jmb,1,lm,u_bkg,lattice_bkg ) - call getit ( id,'vwnd',nymd,nhms,imb,jmb,1,lm,v_bkg,lattice_bkg ) - endif - - if( thvflag_bkg ) then - call getit ( id,'theta',nymd,nhms,imb,jmb,1,lm,thv_bkg,lattice_bkg ) - else if( tvflag_bkg ) then - allocate ( tv_bkg(imb,jmb,lm) ) - call getit ( id,'tv' ,nymd,nhms,imb,jmb,1,lm, tv_bkg,lattice_bkg ) - endif - - if( myid.eq.0 ) call gfio_close ( id,rc ) - call timeend(' read_bkg') - -! Construct Pressure Variables -! ---------------------------- - do L=1,lm+1 - ple_bkg(:,:,L) = ak(L) + ps_bkg(:,:)*bk(L) - enddo - -! Construct BKG THV (if necessary) for REMAPPING -! ---------------------------------------------- - if( tvflag_bkg .and. .not.thvflag_bkg ) then - pke_bkg(:,:,:) = ple_bkg(:,:,:)**kappa - do L=1,lm - pk_bkg(:,:,L) = ( pke_bkg(:,:,L+1)-pke_bkg(:,:,L) ) - . / ( kappa*log(ple_bkg(:,:,L+1)/ple_bkg(:,:,L)) ) - enddo - thv_bkg = tv_bkg/pk_bkg - deallocate ( tv_bkg ) - endif - - if( myid.eq.0 ) print *, ' Model BKG File begins at Lon: ',lon(1) - if( lon(1) .eq. 0.0 ) then - if( myid.eq.0 ) print *, ' Flipping Horizontal Coordinate' - call hflip (phis_bkg,imb,jmb,1 ,lattice_bkg ) - call hflip ( ts_bkg,imb,jmb,1 ,lattice_bkg ) - call hflip ( u_bkg,imb,jmb,lm ,lattice_bkg ) - call hflip ( v_bkg,imb,jmb,lm ,lattice_bkg ) - call hflip ( thv_bkg,imb,jmb,lm ,lattice_bkg ) - call hflip ( q_bkg,imb,jmb,lm ,lattice_bkg ) - call hflip ( o3_bkg,imb,jmb,lm ,lattice_bkg ) - call hflip ( ple_bkg,imb,jmb,lm+1,lattice_bkg ) - endif - -! ********************************************************************** -! **** Read BIAS File from Analysis **** -! ********************************************************************** - - if( trim(biasin).ne.'xxx' ) then - - allocate ( psb_ana(ima,jma) ) - allocate ( tsb_ana(ima,jma) ) - allocate ( ub_ana(ima,jma,lm) ) - allocate ( vb_ana(ima,jma,lm) ) - allocate ( tb_ana(ima,jma,lm) ) - allocate ( qb_ana(ima,jma,lm) ) - allocate ( o3b_ana(ima,jma,lm) ) - allocate ( pb_ana(ima,jma,lm+1) ) - - allocate ( tsb_bkg(imb,jmb) ) - allocate ( ub_bkg(imb,jmb,lm) ) - allocate ( vb_bkg(imb,jmb,lm) ) - allocate ( tb_bkg(imb,jmb,lm) ) - allocate ( qb_bkg(imb,jmb,lm) ) - allocate ( o3b_bkg(imb,jmb,lm) ) - allocate ( pb_bkg(imb,jmb,lm+1) ) - - if( myid.eq.0 ) then - print * - print *, 'Reading BIAS File: ',trim(biasin) - endif - open (10,file=trim(biasin), - . form='unformatted',convert="big_endian",access='sequential') - - rewind (10) - call readit ( psb_ana,ima,jma,1 ,10,lattice_ana ) ! Log(PS) - call readit ( ub_ana,ima,jma,lm,10,lattice_ana ) ! Dummy Read VOR - call readit ( ub_ana,ima,jma,lm,10,lattice_ana ) ! Dummy Read DIV - call readit ( ub_ana,ima,jma,lm,10,lattice_ana ) ! D-Grid U-Wind - call readit ( vb_ana,ima,jma,lm,10,lattice_ana ) ! D-Grid V-Wind - call readit ( tb_ana,ima,jma,lm,10,lattice_ana ) ! Virtual Temperature - call readit ( qb_ana,ima,jma,lm,10,lattice_ana ) ! Specific Humidity - call readit ( o3b_ana,ima,jma,lm,10,lattice_ana ) ! Dummy Read - call readit ( o3b_ana,ima,jma,lm,10,lattice_ana ) ! Ozone - call readit ( tsb_ana,ima,jma,1 ,10,lattice_ana ) ! TSkin - close (10) - - call hflip ( psb_ana,ima,jma,1 ,lattice_ana ) - call hflip ( tsb_ana,ima,jma,1 ,lattice_ana ) - call hflip ( ub_ana,ima,jma,lm,lattice_ana ) - call hflip ( vb_ana,ima,jma,lm,lattice_ana ) - call hflip ( tb_ana,ima,jma,lm,lattice_ana ) - call hflip ( qb_ana,ima,jma,lm,lattice_ana ) - call hflip ( o3b_ana,ima,jma,lm,lattice_ana ) - - do L=1,lm+1 - pb_ana(:,:,L) = ak(L) + psb_ana(:,:)*bk(L) - enddo - -! Only Allow Moisture Bias -! ------------------------ - ub_ana = 0.0 - vb_ana = 0.0 - tb_ana = 0.0 - pb_ana = 0.0 - o3b_ana = 0.0 - tsb_ana = 0.0 - -! Compute Bias Tendency -! --------------------- - ub_bkg = ub_ana/tauana - vb_bkg = vb_ana/tauana - tb_bkg = tb_ana/tauana - qb_bkg = qb_ana/tauana - pb_bkg = pb_ana/tauana - o3b_bkg = o3b_ana/tauana - tsb_bkg = tsb_ana/tauana - - endif - -! ********************************************************************** -! **** Echo Input Files **** -! ********************************************************************** - - if( myid.eq.0 ) then - print * - print *, ' Background filename: ',trim(bkgeta) - print *, ' BKG resolution: ',imbglobal,jmbglobal,lm - print * - print *, ' agrid_bkg: ', agrid_bkg - print *, ' dgrid_bkg: ', dgrid_bkg - print *, ' tvflag_bkg: ', tvflag_bkg - print *, ' thvflag_bkg: ',thvflag_bkg - print * - print *, ' Analysis filename: ',trim(anaeta) - print *, ' ANA resolution: ',imaglobal,jmaglobal,lm - print * - print *, ' agrid_ana: ', agrid_ana - print *, ' dgrid_ana: ', dgrid_ana - print *, ' tvflag_ana: ', tvflag_ana - print *, ' thvflag_ana: ',thvflag_ana - print * - print *, ' Date: ',nymd,nhms - if( imoglobal.eq.-999 .and. jmoglobal.eq.-999 ) then - print *, ' Output resolution: ',imbglobal,jmbglobal,lm - else - print *, ' Output resolution: ',imoglobal,jmoglobal,lm - endif - print * - endif - -! ********************************************************************** -! **** Construct A-Grid Winds (if necessary) **** -! ********************************************************************** - - if( dgrid_ana .and. .not.agrid_ana ) then - call timebeg(' dtoa') - if( myid.eq.0 ) print *, 'Calling DTOA for ANA Winds ...' - allocate ( uglo(imaglobal,jmaglobal) ) - allocate ( vglo(imaglobal,jmaglobal) ) - do L=1,lm - call timebeg (' Gather') - call gather_2d ( uglo,u_ana(1,1,L),lattice_ana ) - call gather_2d ( vglo,v_ana(1,1,L),lattice_ana ) - call timeend (' Gather') - if( lattice_ana%myid.eq.0 ) call dtoa_winds ( uglo,vglo,uglo,vglo,imaglobal,jmaglobal,1 ) - call timebeg (' Scatter') - call scatter_2d ( uglo,u_ana(1,1,L),lattice_ana ) - call scatter_2d ( vglo,v_ana(1,1,L),lattice_ana ) - call timeend (' Scatter') - enddo - deallocate ( uglo,vglo ) - call timeend(' dtoa') - endif - - if( dgrid_bkg .and. .not.agrid_bkg ) then - call timebeg(' dtoa') - if( myid.eq.0 ) print *, 'Calling DTOA for BKG Winds ...' - allocate ( uglo(imbglobal,jmbglobal) ) - allocate ( vglo(imbglobal,jmbglobal) ) - do L=1,lm - call timebeg (' Gather') - call gather_2d ( uglo,u_bkg(1,1,L),lattice_bkg ) - call gather_2d ( vglo,v_bkg(1,1,L),lattice_bkg ) - call timeend (' Gather') - if( lattice_bkg%myid.eq.0 ) call dtoa_winds ( uglo,vglo,uglo,vglo,imbglobal,jmbglobal,1 ) - call timebeg (' Scatter') - call scatter_2d ( uglo,u_bkg(1,1,L),lattice_bkg ) - call scatter_2d ( vglo,v_bkg(1,1,L),lattice_bkg ) - call timeend (' Scatter') - enddo - deallocate ( uglo,vglo ) - call timeend(' dtoa') - endif - -#ifdef debug -! Write Original ANA Data for Debugging -! ------------------------------------- - call writit (phis_ana, ima,jma,1 ,31,lattice_ana ) - call writit ( ts_ana, ima,jma,1 ,31,lattice_ana ) - call writit ( ple_ana(1,1,lm+1),ima,jma,1 ,31,lattice_ana ) - call writit ( u_ana, ima,jma,lm ,31,lattice_ana ) - call writit ( v_ana, ima,jma,lm ,31,lattice_ana ) - call writit ( thv_ana, ima,jma,lm ,31,lattice_ana ) - -! Write Original BKG Data for Debugging -! ------------------------------------- - call writit (phis_bkg, imb,jmb,1 ,41,lattice_bkg ) - call writit ( ts_bkg, imb,jmb,1 ,41,lattice_bkg ) - call writit ( ple_bkg(1,1,lm+1),imb,jmb,1 ,41,lattice_bkg ) - call writit ( u_bkg, imb,jmb,lm ,41,lattice_bkg ) - call writit ( v_bkg, imb,jmb,lm ,41,lattice_bkg ) - call writit ( thv_bkg, imb,jmb,lm ,41,lattice_bkg ) -#endif - -! ********************************************************************** -! **** Modify BKG Data (if differing resolutions) **** -! ********************************************************************** - - if( imaglobal.ne.imbglobal .or. jmaglobal.ne.jmbglobal ) then - - allocate ( u_tmp(ima,jma,lm) ) - allocate ( v_tmp(ima,jma,lm) ) - allocate ( t_tmp(ima,jma,lm) ) - allocate ( thv_tmp(ima,jma,lm) ) - allocate ( q_tmp(ima,jma,lm) ) - allocate ( o3_tmp(ima,jma,lm) ) - allocate ( pk_tmp(ima,jma,lm) ) - allocate ( ple_tmp(ima,jma,lm+1) ) - allocate ( pke_tmp(ima,jma,lm+1) ) - allocate ( ts_tmp(ima,jma) ) - allocate ( phis_tmp(ima,jma) ) - -! Bin BKG file to ANA Resolution -! ------------------------------ - if( imaglobal.lt.imbglobal ) then - if( myid.eq.0 ) print *, 'Binning BKG Data to ANA Resolution' - call bin (phis_bkg,imb,jmb, phis_tmp,ima,jma,1 ,undefb, 1 ,lattice_bkg,lattice_ana ) - call bin ( ts_bkg,imb,jmb, ts_tmp,ima,jma,1 ,undefb, 1 ,lattice_bkg,lattice_ana ) - call bin ( u_bkg,imb,jmb, u_tmp,ima,jma,lm ,undefb, 1 ,lattice_bkg,lattice_ana ) - call bin ( v_bkg,imb,jmb, v_tmp,ima,jma,lm ,undefb, 1 ,lattice_bkg,lattice_ana ) - call bin ( thv_bkg,imb,jmb, thv_tmp,ima,jma,lm ,undefb, 0 ,lattice_bkg,lattice_ana ) - call bin ( q_bkg,imb,jmb, q_tmp,ima,jma,lm ,undefb, 0 ,lattice_bkg,lattice_ana ) - call bin ( o3_bkg,imb,jmb, o3_tmp,ima,jma,lm ,undefb, 0 ,lattice_bkg,lattice_ana ) - call bin ( ple_bkg,imb,jmb, ple_tmp,ima,jma,lm+1,undefb, 0 ,lattice_bkg,lattice_ana ) - endif - -! Interpolate BKG file to ANA Resolution -! -------------------------------------- - if( imaglobal.gt.imbglobal ) then - if( myid.eq.0 ) print *, 'Interpolating BKG Data to ANA Resolution' - call hinterp (phis_bkg,imb,jmb, phis_tmp,ima,jma,1 ,undefb,lattice_bkg,lattice_ana ) - call hinterp ( ts_bkg,imb,jmb, ts_tmp,ima,jma,1 ,undefb,lattice_bkg,lattice_ana ) - call hinterp ( u_bkg,imb,jmb, u_tmp,ima,jma,lm ,undefb,lattice_bkg,lattice_ana ) - call hinterp ( v_bkg,imb,jmb, v_tmp,ima,jma,lm ,undefb,lattice_bkg,lattice_ana ) - call hinterp ( thv_bkg,imb,jmb, thv_tmp,ima,jma,lm ,undefb,lattice_bkg,lattice_ana ) - call hinterp ( q_bkg,imb,jmb, q_tmp,ima,jma,lm ,undefb,lattice_bkg,lattice_ana ) - call hinterp ( o3_bkg,imb,jmb, o3_tmp,ima,jma,lm ,undefb,lattice_bkg,lattice_ana ) - call hinterp ( ple_bkg,imb,jmb, ple_tmp,ima,jma,lm+1,undefb,lattice_bkg,lattice_ana ) - endif - -! Remap Based on TOPO Differences -! ------------------------------- - if( myid.eq.0 ) print *, 'Remapping BKG Data to ANA Topography' - call timebeg(' remap') - call remap ( ple_tmp, - . u_tmp, - . v_tmp, - . thv_tmp, - . q_tmp, - . o3_tmp, - . phis_tmp,phis_ana,ak,bk,ima,jma,lm ) - call timeend(' remap') - -#ifdef debug -! Write BKG DATA at ANA Resolution for Debugging -! ---------------------------------------------- - call writit (phis_tmp, ima,jma,1 ,31,lattice_ana ) - call writit ( ts_tmp, ima,jma,1 ,31,lattice_ana ) - call writit ( ple_tmp(1,1,lm+1),ima,jma,1 ,31,lattice_ana ) - call writit ( u_tmp, ima,jma,lm ,31,lattice_ana ) - call writit ( v_tmp, ima,jma,lm ,31,lattice_ana ) - call writit ( thv_tmp, ima,jma,lm ,31,lattice_ana ) -#endif - - deallocate ( phis_tmp ) - allocate ( phis_tmp(imb,jmb) ) - -! Interpolate BKG Back to Original Resolution -! ------------------------------------------- - if( imaglobal.lt.imbglobal ) then - if( myid.eq.0 ) print *, 'Interpolating BKG Back to Original Resolution' - call hinterp (phis_ana,ima,jma, phis_tmp,imb,jmb,1 ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( ts_tmp,ima,jma, ts_bkg,imb,jmb,1 ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( u_tmp,ima,jma, u_bkg,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( v_tmp,ima,jma, v_bkg,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( thv_tmp,ima,jma, thv_bkg,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( q_tmp,ima,jma, q_bkg,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( o3_tmp,ima,jma, o3_bkg,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( ple_tmp,ima,jma, ple_bkg,imb,jmb,lm+1,undefa,lattice_ana,lattice_bkg ) - endif - -! Bin BKG Back to Original Resolution -! ----------------------------------- - if( imaglobal.gt.imbglobal ) then - if( myid.eq.0 ) print *, 'Binning BKG Back to Original Resolution' - call bin (phis_ana,ima,jma, phis_tmp,imb,jmb,1 ,undefa, 1 ,lattice_ana,lattice_bkg ) - call bin ( ts_tmp,ima,jma, ts_bkg,imb,jmb,1 ,undefa, 1 ,lattice_ana,lattice_bkg ) - call bin ( u_tmp,ima,jma, u_bkg,imb,jmb,lm ,undefa, 1 ,lattice_ana,lattice_bkg ) - call bin ( v_tmp,ima,jma, v_bkg,imb,jmb,lm ,undefa, 1 ,lattice_ana,lattice_bkg ) - call bin ( thv_tmp,ima,jma, thv_bkg,imb,jmb,lm ,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( q_tmp,ima,jma, q_bkg,imb,jmb,lm ,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( o3_tmp,ima,jma, o3_bkg,imb,jmb,lm ,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( ple_tmp,ima,jma, ple_bkg,imb,jmb,lm+1,undefa, 0 ,lattice_ana,lattice_bkg ) - endif - -! Remap Based on TOPO Differences -! ------------------------------- - if( myid.eq.0 ) print *, 'Remapping Modified BKG to Original Topography' - call timebeg(' remap') - call remap ( ple_bkg, - . u_bkg, - . v_bkg, - . thv_bkg, - . q_bkg, - . o3_bkg, - . phis_tmp,phis_bkg,ak,bk,imb,jmb,lm ) - call timeend(' remap') - -#ifdef debug -! Write Modified BKG Data for Debugging -! ------------------------------------- - call writit (phis_tmp, imb,jmb,1 ,41,lattice_bkg ) - call writit ( ts_bkg, imb,jmb,1 ,41,lattice_bkg ) - call writit ( ple_bkg(1,1,lm+1),imb,jmb,1 ,41,lattice_bkg ) - call writit ( u_bkg, imb,jmb,lm ,41,lattice_bkg ) - call writit ( v_bkg, imb,jmb,lm ,41,lattice_bkg ) - call writit ( thv_bkg, imb,jmb,lm ,41,lattice_bkg ) -#endif - - endif - -! Create BKG Dry Temperature -! -------------------------- - pke_bkg(:,:,:) = ple_bkg(:,:,:)**kappa - do L=1,lm - pk_bkg(:,:,L) = ( pke_bkg(:,:,L+1)-pke_bkg(:,:,L) ) - . / ( kappa*log(ple_bkg(:,:,L+1)/ple_bkg(:,:,L)) ) - enddo - t_bkg = thv_bkg*pk_bkg/(1+eps*q_bkg) - -! ********************************************************************** -! **** Check for TOPO Differences if Same Resolution **** -! ********************************************************************** - - if( imaglobal.eq.imbglobal .and. jmaglobal.eq.jmbglobal ) then - allocate ( uglo(imaglobal,jmaglobal) ) - allocate ( vglo(imaglobal,jmaglobal) ) - call gather_2d ( uglo,phis_bkg,lattice_bkg ) - call gather_2d ( vglo,phis_ana,lattice_ana ) - lremap = .false. - if( myid.eq.0 ) lremap = count( uglo.ne.vglo ).ne.0 - call mpi_bcast (lremap,1,mpi_logical,0,comm,ierror ) - deallocate ( uglo,vglo ) - - if( lremap ) then - if( myid.eq.0 ) print *, 'Remapping ANA Data to BKG Topography' - call timebeg(' remap') - call remap ( ple_ana, - . u_ana, - . v_ana, - . thv_ana, - . q_ana, - . o3_ana, - . phis_ana,phis_bkg,ak,bk,imb,jmb,lm ) - call timeend(' remap') - endif - endif - -! ********************************************************************** -! **** Create ANA data at BKG resolution **** -! ********************************************************************** - - if( associated( u_tmp ) ) deallocate ( u_tmp ) ; allocate ( u_tmp(imb,jmb,lm) ) - if( associated( v_tmp ) ) deallocate ( v_tmp ) ; allocate ( v_tmp(imb,jmb,lm) ) - if( associated( t_tmp ) ) deallocate ( t_tmp ) ; allocate ( t_tmp(imb,jmb,lm) ) - if( associated( thv_tmp ) ) deallocate ( thv_tmp ) ; allocate ( thv_tmp(imb,jmb,lm) ) - if( associated( q_tmp ) ) deallocate ( q_tmp ) ; allocate ( q_tmp(imb,jmb,lm) ) - if( associated( o3_tmp ) ) deallocate ( o3_tmp ) ; allocate ( o3_tmp(imb,jmb,lm) ) - if( associated( pk_tmp ) ) deallocate ( pk_tmp ) ; allocate ( pk_tmp(imb,jmb,lm) ) - if( associated( ple_tmp ) ) deallocate ( ple_tmp ) ; allocate ( ple_tmp(imb,jmb,lm+1) ) - if( associated( pke_tmp ) ) deallocate ( pke_tmp ) ; allocate ( pke_tmp(imb,jmb,lm+1) ) - if( associated( ts_tmp ) ) deallocate ( ts_tmp ) ; allocate ( ts_tmp(imb,jmb) ) - if( associated( phis_tmp ) ) deallocate ( phis_tmp ) ; allocate ( phis_tmp(imb,jmb) ) - - if( imaglobal.ne.imbglobal .or. jmaglobal.ne.jmbglobal ) then - -! Interpolate ANA Data to BKG Resolution -! -------------------------------------- - if( imaglobal.lt.imbglobal ) then - if( myid.eq.0 ) print *, 'Interpolating ANA Data to BKG Resolution' - call hinterp (phis_ana,ima,jma, phis_tmp,imb,jmb,1 ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( ts_ana,ima,jma, ts_tmp,imb,jmb,1 ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( u_ana,ima,jma, u_tmp,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( v_ana,ima,jma, v_tmp,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( thv_ana,ima,jma, thv_tmp,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( q_ana,ima,jma, q_tmp,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( o3_ana,ima,jma, o3_tmp,imb,jmb,lm ,undefa,lattice_ana,lattice_bkg ) - call hinterp ( ple_ana,ima,jma, ple_tmp,imb,jmb,lm+1,undefa,lattice_ana,lattice_bkg ) - endif - -! Bin ANA Data to BKG Resolution -! ------------------------------ - if( imaglobal.gt.imbglobal ) then - if( myid.eq.0 ) print *, 'Binning ANA Data to BKG Resolution' - call bin (phis_ana,ima,jma, phis_tmp,imb,jmb,1 ,undefa, 1 ,lattice_ana,lattice_bkg ) - call bin ( ts_ana,ima,jma, ts_tmp,imb,jmb,1 ,undefa, 1 ,lattice_ana,lattice_bkg ) - call bin ( u_ana,ima,jma, u_tmp,imb,jmb,lm ,undefa, 1 ,lattice_ana,lattice_bkg ) - call bin ( v_ana,ima,jma, v_tmp,imb,jmb,lm ,undefa, 1 ,lattice_ana,lattice_bkg ) - call bin ( thv_ana,ima,jma, thv_tmp,imb,jmb,lm ,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( q_ana,ima,jma, q_tmp,imb,jmb,lm ,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( o3_ana,ima,jma, o3_tmp,imb,jmb,lm ,undefa, 0 ,lattice_ana,lattice_bkg ) - call bin ( ple_ana,ima,jma, ple_tmp,imb,jmb,lm+1,undefa, 0 ,lattice_ana,lattice_bkg ) - endif - -! Remap Based on TOPO Differences -! ------------------------------- - if( myid.eq.0 ) print *, 'Remapping ANA Data to BKG Topography' - call timebeg(' remap') - call remap ( ple_tmp, - . u_tmp, - . v_tmp, - . thv_tmp, - . q_tmp, - . o3_tmp, - . phis_tmp,phis_bkg,ak,bk,imb,jmb,lm ) - call timeend(' remap') - -#ifdef debug -! Write ANA DATA at BKG Resolution for Debugging -! ---------------------------------------------- - call writit (phis_tmp, imb,jmb,1 ,41,lattice_bkg ) - call writit ( ts_tmp, imb,jmb,1 ,41,lattice_bkg ) - call writit ( ple_tmp(1,1,lm+1),imb,jmb,1 ,41,lattice_bkg ) - call writit ( u_tmp, imb,jmb,lm ,41,lattice_bkg ) - call writit ( v_tmp, imb,jmb,lm ,41,lattice_bkg ) - call writit ( thv_tmp, imb,jmb,lm ,41,lattice_bkg ) -#endif - - else - -! BKG and ANA Horizontal Resolutions Match -! ---------------------------------------- - phis_tmp = phis_ana - ts_tmp = ts_ana - u_tmp = u_ana - v_tmp = v_ana - thv_tmp = thv_ana - q_tmp = q_ana - o3_tmp = o3_ana - ple_tmp = ple_ana - - endif - -! Create ANA Dry Temperature -! -------------------------- - pke_tmp(:,:,:) = ple_tmp(:,:,:)**kappa - do L=1,lm - pk_tmp(:,:,L) = ( pke_tmp(:,:,L+1)-pke_tmp(:,:,L) ) - . / ( kappa*log(ple_tmp(:,:,L+1)/ple_tmp(:,:,L)) ) - enddo - t_tmp = thv_tmp*pk_tmp/(1+eps*q_tmp) - -! ********************************************************************** -! **** Damp Increments between Pabove and Pbelow **** -! ********************************************************************** - - if( damp ) then - pabove = 100 ! 1-mb - pbelow = 500 ! 5-mb - if( myid.eq.0 ) write(6,1001) pabove/100,pbelow/100 - allocate ( pref(lm+1) ) - do L=1,lm+1 - pref(L) = ak(L) + 100000.0*bk(L) - enddo - do L=1,lm - pl=0.5*(pref(L+1)+pref(L)) - alf= max( 0.0, (pl-pabove)/(pbelow-pabove) ) - if( pl.lt.pbelow ) then - if( myid.eq.0 ) write(6,1002) L,pl/100,alf - u_tmp(:,:,L) = u_bkg(:,:,L) + ( u_tmp(:,:,L)- u_bkg(:,:,L))*alf - v_tmp(:,:,L) = v_bkg(:,:,L) + ( v_tmp(:,:,L)- v_bkg(:,:,L))*alf - t_tmp(:,:,L) = t_bkg(:,:,L) + ( t_tmp(:,:,L)- t_bkg(:,:,L))*alf - q_tmp(:,:,L) = q_bkg(:,:,L) + ( q_tmp(:,:,L)- q_bkg(:,:,L))*alf - o3_tmp(:,:,L) = o3_bkg(:,:,L) + ( o3_tmp(:,:,L)- o3_bkg(:,:,L))*alf - ple_tmp(:,:,L) = ple_bkg(:,:,L) + (ple_tmp(:,:,L)-ple_bkg(:,:,L))*alf - endif - enddo - if( myid.eq.0 ) print * - endif - 1001 format(1x,'Damping Increments Between ',f5.2,' mb and ',f5.2,' mb') - 1002 format(1x,'Level: ',i3,' Pmid: ',f6.2,' Damping Coef: ',f7.4) - -! ********************************************************************** -! **** Modify vertically integrated wind increment **** -! **** to be non-divergent **** -! ********************************************************************** - - if( method.eq.-999 ) then - if( myid.eq.0 ) print *, 'No Wind Adjustment Change to Divergence' - else - if( myid.eq.0 ) then - if( method.eq.1 ) print *, 'Minimizing Relative Change to Divergence' - if( method.eq.2 ) print *, 'Minimizing Absolute Change to Divergence' - print *, 'Calling Windfix' - endif - call timebeg (' windfix') - call windfix ( u_tmp,v_tmp,ple_tmp, - . u_bkg,v_bkg,ple_bkg,imb,jmb,lm,lattice_bkg,'A',method ) - call timeend (' windfix') - endif - -! ********************************************************************** -! **** Create IAU Data at BKG resolution **** -! ********************************************************************** - - ts_bkg = sclinc*( ts_tmp- ts_bkg ) - u_bkg = sclinc*( u_tmp- u_bkg ) - v_bkg = sclinc*( v_tmp- v_bkg ) - t_bkg = sclinc*( t_tmp- t_bkg ) - q_bkg = sclinc*( q_tmp- q_bkg ) - o3_bkg = sclinc*( o3_tmp- o3_bkg ) - ple_bkg = sclinc*( ple_tmp-ple_bkg ) - -! Write IAU Forcing File -! ---------------------- - call timebeg (' write_iau') - if( myid.eq.0 ) then - print * - print *, 'Writing IAU File: ',trim(iaueta) - endif - open (10,file=trim(iaueta),form='unformatted',access='sequential') - - if( (imoglobal.eq.-999 .and. jmoglobal.eq.-999 ) .or. - . (imoglobal.eq.imbglobal .and. jmoglobal.eq.jmbglobal) ) then - - rewind (10) - call writit ( u_bkg,imb,jmb,lm ,10,lattice_bkg ) - call writit ( v_bkg,imb,jmb,lm ,10,lattice_bkg ) - call writit ( t_bkg,imb,jmb,lm ,10,lattice_bkg ) - call writit ( ple_bkg,imb,jmb,lm+1,10,lattice_bkg ) - call writit ( q_bkg,imb,jmb,lm ,10,lattice_bkg ) - call writit ( o3_bkg,imb,jmb,lm ,10,lattice_bkg ) - call writit ( ts_bkg,imb,jmb,1 ,10,lattice_bkg ) - close (10) - - else - - call create_dynamics_lattice ( lattice_out,npex,npey ) - call init_dynamics_lattice ( lattice_out,comm,imoglobal,jmoglobal,lm ) - - imo = lattice_out%im( lattice_out%pei ) - jmo = lattice_out%jm( lattice_out%pej ) - - if( associated( u_tmp ) ) deallocate ( u_tmp ) ; allocate ( u_tmp(imo,jmo,lm) ) - if( associated( v_tmp ) ) deallocate ( v_tmp ) ; allocate ( v_tmp(imo,jmo,lm) ) - if( associated( t_tmp ) ) deallocate ( t_tmp ) ; allocate ( t_tmp(imo,jmo,lm) ) - if( associated( ple_tmp ) ) deallocate ( ple_tmp ) ; allocate ( ple_tmp(imo,jmo,lm+1) ) - if( associated( q_tmp ) ) deallocate ( q_tmp ) ; allocate ( q_tmp(imo,jmo,lm) ) - if( associated( o3_tmp ) ) deallocate ( o3_tmp ) ; allocate ( o3_tmp(imo,jmo,lm) ) - if( associated( ts_tmp ) ) deallocate ( ts_tmp ) ; allocate ( ts_tmp(imo,jmo) ) - -! Bin BKG file to OUT Resolution -! ------------------------------ - if( imoglobal.lt.imbglobal ) then - if( myid.eq.0 ) print *, 'Binning IAU BKG Data to OUT Resolution' - call bin ( u_bkg,imb,jmb, u_tmp,imo,jmo,lm ,undefb, 1 ,lattice_bkg, lattice_out ) - call bin ( v_bkg,imb,jmb, v_tmp,imo,jmo,lm ,undefb, 1 ,lattice_bkg, lattice_out ) - call bin ( t_bkg,imb,jmb, t_tmp,imo,jmo,lm ,undefb, 0 ,lattice_bkg, lattice_out ) - call bin ( ple_bkg,imb,jmb, ple_tmp,imo,jmo,lm+1,undefb, 0 ,lattice_bkg, lattice_out ) - call bin ( q_bkg,imb,jmb, q_tmp,imo,jmo,lm ,undefb, 0 ,lattice_bkg, lattice_out ) - call bin ( o3_bkg,imb,jmb, o3_tmp,imo,jmo,lm ,undefb, 0 ,lattice_bkg, lattice_out ) - call bin ( ts_bkg,imb,jmb, ts_tmp,imo,jmo,1 ,undefb, 0 ,lattice_bkg, lattice_out ) - endif - -! Interpolate BKG file to OUT Resolution -! -------------------------------------- - if( imoglobal.gt.imbglobal ) then - if( myid.eq.0 ) print *, 'Interpolating IAU BKG Data to OUT Resolution' - call hinterp ( u_bkg,imb,jmb, u_tmp,imo,jmo,lm ,undefb, lattice_bkg, lattice_out ) - call hinterp ( v_bkg,imb,jmb, v_tmp,imo,jmo,lm ,undefb, lattice_bkg, lattice_out ) - call hinterp ( t_bkg,imb,jmb, t_tmp,imo,jmo,lm ,undefb, lattice_bkg, lattice_out ) - call hinterp ( ple_bkg,imb,jmb, ple_tmp,imo,jmo,lm+1,undefb, lattice_bkg, lattice_out ) - call hinterp ( q_bkg,imb,jmb, q_tmp,imo,jmo,lm ,undefb, lattice_bkg, lattice_out ) - call hinterp ( o3_bkg,imb,jmb, o3_tmp,imo,jmo,lm ,undefb, lattice_bkg, lattice_out ) - call hinterp ( ts_bkg,imb,jmb, ts_tmp,imo,jmo,1 ,undefb, lattice_bkg, lattice_out ) - endif - - rewind (10) - call writit ( u_tmp,imo,jmo,lm ,10,lattice_out ) - call writit ( v_tmp,imo,jmo,lm ,10,lattice_out ) - call writit ( t_tmp,imo,jmo,lm ,10,lattice_out ) - call writit ( ple_tmp,imo,jmo,lm+1,10,lattice_out ) - call writit ( q_tmp,imo,jmo,lm ,10,lattice_out ) - call writit ( o3_tmp,imo,jmo,lm ,10,lattice_out ) - call writit ( ts_tmp,imo,jmo,1 ,10,lattice_out ) - close (10) - - endif - - call timeend (' write_iau') - -! ********************************************************************** -! **** Write AGCM_INTERNAL_RST (BIAS File) **** -! ********************************************************************** - - if( trim(biasin).ne.'xxx' ) then - biasout = 'agcm_internal_rst' - call timebeg (' writebias') - if( myid.eq.0 ) then - print * - print *, 'Writing AGCM_INTERNAL_RST (BIAS File): ',trim(biasout) - endif - open (10,file=trim(biasout),form='unformatted',access='sequential') - - rewind (10) - call writit ( ub_bkg,imb,jmb,lm ,10,lattice_bkg ) - call writit ( vb_bkg,imb,jmb,lm ,10,lattice_bkg ) - call writit ( tb_bkg,imb,jmb,lm ,10,lattice_bkg ) - call writit ( pb_bkg,imb,jmb,lm+1,10,lattice_bkg ) - call writit ( qb_bkg,imb,jmb,lm ,10,lattice_bkg ) - call writit ( o3b_bkg,imb,jmb,lm ,10,lattice_bkg ) - call writit ( tsb_bkg,imb,jmb,1 ,10,lattice_bkg ) - close (10) - - call timeend (' writebias') - endif - -! ********************************************************************** -! **** Write Timing Information **** -! ********************************************************************** - - call timeend ('main') - if( myid.eq.0 ) call timepri (6) - - if( myid.eq.0 ) then - close(999) - open (999,file='IAU_EGRESS',form='formatted') - close(999) - end if - - call my_finalize - - stop - end - - subroutine getit ( id,name,nymd,nhms,im,jm,lbeg,lm,q,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer L,id,nymd,nhms,im,jm,img,jmg,lbeg,lm - real q(im,jm,lm) - real,allocatable :: glo(:,:,:) - character(*) name - integer rc - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg,lm) ) - if( lattice%myid.eq.0 ) then - call gfio_getvar ( id,trim(name),nymd,nhms,img,jmg,lbeg,lm,glo,rc ) - endif - call timebeg (' Scatter') - do L=1,lm - call scatter_2d ( glo(1,1,L),q(1,1,L),lattice ) - enddo - call timeend (' Scatter') - deallocate ( glo ) - return - end - - subroutine readit ( q,im,jm,lm,ku,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,lm,L,ku,img,jmg - real q(im,jm,lm) - real, allocatable :: glo(:,:) - real*4, allocatable :: a(:,:) - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg) ) - allocate ( a(img,jmg) ) - do L=1,lm - if( lattice%myid.eq.0 ) then - read(ku) a - glo = a - endif - call timebeg (' Scatter') - call scatter_2d ( glo,q(1,1,lm-L+1),lattice ) - call timeend (' Scatter') - enddo - deallocate ( glo ) - deallocate ( a ) - return - end - - subroutine writit ( q,im,jm,lm,ku,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,lm,L,ku,img,jmg - real q(im,jm,lm) - real, allocatable :: glo(:,:) - real*4, allocatable :: a(:,:) - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg) ) - allocate ( a(img,jmg) ) - do L=1,lm - call timebeg (' Gather') - call gather_2d ( glo,q(1,1,L),lattice ) - call timeend (' Gather') - if( lattice%myid.eq.0 ) then - a = glo - write(ku) a - endif - enddo - deallocate ( glo ) - deallocate ( a ) - return - end - - subroutine hflip ( q,im,jm,lm,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,lm,i,j,L,img,jmg - real q(im,jm,lm) - real, allocatable :: glo(:,:) - real, allocatable :: dum(:) - img = lattice%imglobal - jmg = lattice%jmglobal - - allocate ( glo(img,jmg) ) - allocate ( dum(img) ) - - do L=1,lm - call timebeg (' Gather') - call gather_2d ( glo,q(1,1,L),lattice ) - call timeend (' Gather') - if( lattice%myid.eq.0 ) then - do j=1,jmg - do i=1,img/2 - dum(i) = glo(i+img/2,j) - dum(i+img/2) = glo(i,j) - enddo - glo(:,j) = dum(:) - enddo - endif - call timebeg (' Scatter') - call scatter_2d ( glo,q(1,1,L),lattice ) - call timeend (' Scatter') - enddo - - deallocate ( glo ) - deallocate ( dum ) - return - end - - subroutine usage(myid) - if(myid.eq.0) then - print *, "Usage: " - print * - print *, " makeiau.x -bkg bkgeta_fname " - print *, " -ana anaeta_fname " - print *, " -iau iaueta_fname " - print *, " -nymd yyyymmdd " - print *, " -nhms hhmmss " - print * - print *, " -divr (optional flag to Minimize Relative Adjustment " - print *, " of Vertically Integrated Mass Divergence Increment)" - print *, " -diva (optional flag to Minimize Absolute Adjustment " - print *, " of Vertically Integrated Mass Divergence Increment)" - print *, " -damp (optional flag to Damp Final Increments above 1 mb)" - print * - print *, " -imout (optional zonal dimension output parameter" - print *, " DEFAULT: bkg rslv)" - print *, " -jmout (optional meridional dimension output parameter" - print *, " DEFAULT: bkg rslv)" - print * - endif - - call my_finalize - stop - end - - subroutine dtoa_winds ( ud,vd,ua,va,im,jm,lm ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded winds **** -C **** to 'A' gridded winds **** -C **** using simple averaging. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C ****************************************************************** - - real ua(im,jm,lm), ud(im,jm,lm) - real va(im,jm,lm), vd(im,jm,lm) - - real uz(im,jm) - real vz(im,jm) - real sinx(im/2) - real cosx(im/2) - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - - do i=1,imh - sinx(i) = sin( -pi + (i-1)*dx ) - cosx(i) = cos( -pi + (i-1)*dx ) - enddo - - do L=1,lm - - uz(:,:) = ud(:,:,L) - vz(:,:) = vd(:,:,L) - -C ********************************************************* -C **** Average D-Grid Winds **** -C ********************************************************* - - do j=2,jm-1 - i=im - do ip1=1,im - ua(i,j,L) = ( uz(i,j)+uz(i,j+1) )*0.5 - va(i,j,L) = ( vz(i,j)+vz(ip1,j) )*0.5 - i=ip1 - enddo - enddo - -C ********************************************************* -C **** Fix A-Grid Pole Winds **** -C ********************************************************* - - do m=1,2 - n = (-1)**m - jpole = 1 + (m-1)*(jm-1) - jstar = 2 + (m-1)*(jm-3) - - upole = 0.0 - vpole = 0.0 - do i=1,imh - upole = upole + ( ua(i+imh,jstar,L)-ua(i,jstar,L) )*sinx(i) - . + n*( va(i+imh,jstar,L)-va(i,jstar,L) )*cosx(i) - vpole = vpole - n*( ua(i+imh,jstar,L)-ua(i,jstar,L) )*cosx(i) - . + ( va(i+imh,jstar,L)-va(i,jstar,L) )*sinx(i) - enddo - upole = upole / im - vpole = vpole / im - do i=1,imh - ua(i ,jpole,L) = - upole*sinx(i) + n*vpole*cosx(i) - va(i ,jpole,L) = - n*upole*cosx(i) - vpole*sinx(i) - ua(i+imh,jpole,L) = - ua(i,jpole,L) - va(i+imh,jpole,L) = - va(i,jpole,L) - enddo - enddo - -C ********************************************************* -C **** End Level Loop **** -C ********************************************************* - - enddo - - return - end - - subroutine atod ( qa,qd,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded data **** -C **** to 'D' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted left (westward), **** -C **** u is shifted down (southward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real,allocatable :: qax(:,:) - real,allocatable :: cx(:,:) - real,allocatable :: qay(:,:) - real,allocatable :: cy(:,:) - - real,allocatable :: sinx(:) - real,allocatable :: cosx(:) - real,allocatable :: siny(:) - real,allocatable :: cosy(:) - real,allocatable :: trigx(:) - real,allocatable :: trigy(:) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - - allocate( qax ( im+2 ,lm) ) - allocate( cx (2*(im+2),lm) ) - allocate( qay ( 2*jm ,lm) ) - allocate( cy (2*(2*jm),lm) ) - - allocate( cosx(im/2) ) - allocate( sinx(im/2) ) - allocate( cosy(jm) ) - allocate( siny(jm) ) - allocate( trigx(3*(im+1)) ) - allocate( trigy(3*(2*jm)) ) - -C ********************************************************* -C **** shift left (-dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qa(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) + qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) - qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qd(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift down (-dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qa(i,j+1,L) - qay(j+jmm1,L) = -qa(i+imh,jm-j,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) + qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) - qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qd(i,j+1,L) = qay(j,L) - qd(i+imh,jm-j+1,L) = -qay(j+jmm1,L) - enddo - enddo - enddo - - endif - - deallocate( qax ) - deallocate( cx ) - deallocate( qay ) - deallocate( cy ) - - deallocate( cosx ) - deallocate( sinx ) - deallocate( cosy ) - deallocate( siny ) - deallocate( trigx ) - deallocate( trigy ) - - return - end - - subroutine dtoa ( qd,qa,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real,allocatable :: qax(:,:) - real,allocatable :: cx(:,:) - real,allocatable :: qay(:,:) - real,allocatable :: cy(:,:) - - real,allocatable :: sinx(:) - real,allocatable :: cosx(:) - real,allocatable :: siny(:) - real,allocatable :: cosy(:) - real,allocatable :: trigx(:) - real,allocatable :: trigy(:) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - - allocate( qax ( im+2 ,lm) ) - allocate( cx (2*(im+2),lm) ) - allocate( qay ( 2*jm ,lm) ) - allocate( cy (2*(2*jm),lm) ) - - allocate( cosx(im/2) ) - allocate( sinx(im/2) ) - allocate( cosy(jm) ) - allocate( siny(jm) ) - allocate( trigx(3*(im+1)) ) - allocate( trigy(3*(2*jm)) ) - -C ********************************************************* -C **** shift right (dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qd(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) - qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) + qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qa(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift up (dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qd(i,j+1,L) - qay(j+jmm1,L) = -qd(i+imh,jm-j+1,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) - qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) + qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qa(i,j+1,L) = qay(j,L) - qa(i+imh,jm-j,L) = -qay(j+jmm1,L) - enddo - enddo - - enddo - - do L=1,lm - do i=1,imh - qa(i+imh,jm,L) = -qa(i,jm,L) - qa(i,1,L) = -qa(i+imh,1,L) - enddo - enddo - endif - - deallocate( qax ) - deallocate( cx ) - deallocate( qay ) - deallocate( cy ) - - deallocate( cosx ) - deallocate( sinx ) - deallocate( cosy ) - deallocate( siny ) - deallocate( trigx ) - deallocate( trigy ) - - return - end - - subroutine rfftmlt (a,work,trigs,ifax,inc,jump,n,lot,isign) - integer INC, JUMP, N, LOT, ISIGN - real(kind=KIND(1.0)) A(N),WORK(N),TRIGS(N) - integer IFAX(*) -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR -! CALL Q8QST4 ( 4HXLIB, 6HFFT99F, 6HFFT991, 10HVERSION 01) -!FPP$ NOVECTOR R - integer NFAX, NH, NX, INK - integer I, J, IBASE, JBASE, L, IGO, IA, LA, K, M, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, - * INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, - * 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 -!DIR$ IVDEP - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END - - subroutine fftfax (n,ifax,trigs) - integer IFAX(13) - integer N - REAL(kind=KIND(1.0)) TRIGS(*) -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - integer I, MODE - DATA MODE /3/ -!FPP$ NOVECTOR R - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) WRITE(6,FMT="(//5X, ' FFTFAX -- INVALID N =', I5,/)") N - IF (IFAX(1) .LE. 0 ) STOP 999 - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END - - subroutine fft99a (a,work,trigs,inc,jump,n,lot) - integer inc, jump, N, lot - real(kind=KIND(1.0)) A(N),WORK(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 -! (SPECTRAL TO GRIDPOINT TRANSFORM) -! -!FPP$ NOVECTOR R - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) C, S - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - IA=1 - IB=N*INC+1 - JA=1 - JB=2 -!DIR$ IVDEP - DO 10 L=1,LOT - WORK(JA)=A(IA)+A(IB) - WORK(JB)=A(IA)-A(IB) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 10 CONTINUE -! -! REMAINING WAVENUMBERS - IABASE=2*INC+1 - IBBASE=(N-2)*INC+1 - JABASE=3 - JBBASE=N-1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - WORK(JA)=(A(IA)+A(IB))- - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JB)=(A(IA)+A(IB))+ - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+ - * (A(IA+INC)-A(IB+INC)) - WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))- - * (A(IA+INC)-A(IB+INC)) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 20 CONTINUE - IABASE=IABASE+INK - IBBASE=IBBASE-INK - JABASE=JABASE+2 - JBBASE=JBBASE-2 - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE -!DIR$ IVDEP - DO 40 L=1,LOT - WORK(JA)=2.0*A(IA) - WORK(JA+1)=-2.0*A(IA+INC) - IA=IA+JUMP - JA=JA+NX - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fft99b (work,a,trigs,inc,jump,n,lot) - integer INC, JUMP, N, LOT - real(kind=KIND(1.0)) WORK(N),A(N) - REAL(kind=KIND(1.0)) TRIGS(N) - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) SCALE - real(kind=KIND(1.0)) C, S -! -! SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 -! (GRIDPOINT TO SPECTRAL TRANSFORM) -! -!FPP$ NOVECTOR R - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - SCALE=1.0/FLOAT(N) - IA=1 - IB=2 - JA=1 - JB=N*INC+1 -!DIR$ IVDEP - DO 10 L=1,LOT - A(JA)=SCALE*(WORK(IA)+WORK(IB)) - A(JB)=SCALE*(WORK(IA)-WORK(IB)) - A(JA+INC)=0.0 - A(JB+INC)=0.0 - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 10 CONTINUE -! -! REMAINING WAVENUMBERS - SCALE=0.5*SCALE - IABASE=3 - IBBASE=N-1 - JABASE=2*INC+1 - JBBASE=(N-2)*INC+1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - A(JA)=SCALE*((WORK(IA)+WORK(IB)) - * +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JB)=SCALE*((WORK(IA)+WORK(IB)) - * -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * +(WORK(IB+1)-WORK(IA+1))) - A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * -(WORK(IB+1)-WORK(IA+1))) - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 20 CONTINUE - IABASE=IABASE+2 - IBBASE=IBBASE-2 - JABASE=JABASE+INK - JBBASE=JBBASE-INK - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - SCALE=2.0*SCALE -!DIR$ IVDEP - DO 40 L=1,LOT - A(JA)=SCALE*WORK(IA) - A(JA+INC)=-SCALE*WORK(IA+1) - IA=IA+NX - JA=JA+JUMP - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fax (ifax,n,mode) - integer IFAX(10) - integer N, MODE -!FPP$ NOVECTOR R - integer NN, K, L, INC, II, ISTOP, ITEM, NFAX, I - NN=N - IF (IABS(MODE).EQ.1) GO TO 10 - IF (IABS(MODE).EQ.8) GO TO 10 - NN=N/2 - IF ((NN+NN).EQ.N) GO TO 10 - IFAX(1)=-99 - RETURN - 10 K=1 -! TEST FOR FACTORS OF 4 - 20 IF (MOD(NN,4).NE.0) GO TO 30 - K=K+1 - IFAX(K)=4 - NN=NN/4 - IF (NN.EQ.1) GO TO 80 - GO TO 20 -! TEST FOR EXTRA FACTOR OF 2 - 30 IF (MOD(NN,2).NE.0) GO TO 40 - K=K+1 - IFAX(K)=2 - NN=NN/2 - IF (NN.EQ.1) GO TO 80 -! TEST FOR FACTORS OF 3 - 40 IF (MOD(NN,3).NE.0) GO TO 50 - K=K+1 - IFAX(K)=3 - NN=NN/3 - IF (NN.EQ.1) GO TO 80 - GO TO 40 -! NOW FIND REMAINING FACTORS - 50 L=5 - INC=2 -! INC ALTERNATELY TAKES ON VALUES 2 AND 4 - 60 IF (MOD(NN,L).NE.0) GO TO 70 - K=K+1 - IFAX(K)=L - NN=NN/L - IF (NN.EQ.1) GO TO 80 - GO TO 60 - 70 L=L+INC - INC=6-INC - GO TO 60 - 80 IFAX(1)=K-1 -! IFAX(1) CONTAINS NUMBER OF FACTORS - NFAX=IFAX(1) -! SORT FACTORS INTO ASCENDING ORDER - IF (NFAX.EQ.1) GO TO 110 - DO 100 II=2,NFAX - ISTOP=NFAX+2-II - DO 90 I=2,ISTOP - IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 - ITEM=IFAX(I) - IFAX(I)=IFAX(I+1) - IFAX(I+1)=ITEM - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN - END - - subroutine fftrig (trigs,n,mode) - REAL(kind=KIND(1.0)) TRIGS(*) - integer N, MODE -!FPP$ NOVECTOR R - real(kind=KIND(1.0)) PI - integer IMODE, NN, L, I, NH, LA - real(kind=KIND(1.0)) DEL, ANGLE - PI=2.0*ASIN(1.0) - IMODE=IABS(MODE) - NN=N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 - DEL=(PI+PI)/FLOAT(NN) - L=NN+NN - DO 10 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(I)=COS(ANGLE) - TRIGS(I+1)=SIN(ANGLE) - 10 CONTINUE - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - DEL=0.5*DEL - NH=(NN+1)/2 - L=NH+NH - LA=NN+NN - DO 20 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(LA+I)=COS(ANGLE) - TRIGS(LA+I+1)=SIN(ANGLE) - 20 CONTINUE - IF (IMODE.LE.3) RETURN - DEL=0.5*DEL - LA=LA+NN - IF (MODE.EQ.5) GO TO 40 - DO 30 I=2,NN - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=2.0*SIN(ANGLE) - 30 CONTINUE - RETURN - 40 CONTINUE - DEL=0.5*DEL - DO 50 I=2,N - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=SIN(ANGLE) - 50 CONTINUE - RETURN - END - - subroutine vpassm (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la) - integer INC1,INC2,INC3,INC4,LOT,N,IFAC,LA - real(kind=KIND(1.0)) A(N),B(N),C(N),D(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA" -! PERFORMS ONE PASS THROUGH DATA -! AS PART OF MULTIPLE COMPLEX FFT ROUTINE -! A IS FIRST REAL INPUT VECTOR -! B IS FIRST IMAGINARY INPUT VECTOR -! C IS FIRST REAL OUTPUT VECTOR -! D IS FIRST IMAGINARY OUTPUT VECTOR -! TRIGS IS PRECALCULATED TABLE OF SINES & COSINES -! INC1 IS ADDRESSING INCREMENT FOR A AND B -! INC2 IS ADDRESSING INCREMENT FOR C AND D -! INC3 IS ADDRESSING INCREMENT BETWEEN As & Bs -! INC4 IS ADDRESSING INCREMENT BETWEEN Cs & Ds -! LOT IS THE NUMBER OF VECTORS -! N IS LENGTH OF VECTORS -! IFAC IS CURRENT FACTOR OF N -! LA IS PRODUCT OF PREVIOUS FACTORS -! - real(kind=KIND(1.0)) SIN36, COS36, SIN72, COS72, SIN60 - DATA SIN36/0.587785252292473/,COS36/0.809016994374947/, - * SIN72/0.951056516295154/,COS72/0.309016994374947/, - * SIN60/0.866025403784437/ - integer M, IINK, JINK, JUMP, IBASE, JBASE, IGO, IA, JA, IB, JB - integer IC, JC, ID, JD, IE, JE - integer I, J, K, L, IJK, LA1, KB, KC, KD, KE - real(kind=KIND(1.0)) C1, S1, C2, S2, C3, S3, C4, S4 -! -!FPP$ NOVECTOR R - M=N/IFAC - IINK=M*INC1 - JINK=LA*INC2 - JUMP=(IFAC-1)*JINK - IBASE=0 - JBASE=0 - IGO=IFAC-1 - IF (IGO.GT.4) RETURN - GO TO (10,50,90,130),IGO -! -! CODING FOR FACTOR 2 -! - 10 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - DO 20 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 15 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=A(IA+I)-A(IB+I) - D(JB+J)=B(IA+I)-B(IB+I) - I=I+INC3 - J=J+INC4 - 15 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 20 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 40 K=LA1,M,LA - KB=K+K-2 - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - DO 30 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 25 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) - D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) - I=I+INC3 - J=J+INC4 - 25 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 30 CONTINUE - JBASE=JBASE+JUMP - 40 CONTINUE - RETURN -! -! CODING FOR FACTOR 3 -! - 50 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - DO 60 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 55 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))) - C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))) - D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))) - D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))) - I=I+INC3 - J=J+INC4 - 55 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 60 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 80 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - DO 70 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 65 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)= - * C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - D(JB+J)= - * S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - C(JC+J)= - * C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - D(JC+J)= - * S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - I=I+INC3 - J=J+INC4 - 65 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 70 CONTINUE - JBASE=JBASE+JUMP - 80 CONTINUE - RETURN -! -! CODING FOR FACTOR 4 -! - 90 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - DO 100 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 95 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) - C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) - C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) - D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) - D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) - I=I+INC3 - J=J+INC4 - 95 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 100 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 120 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - DO 110 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 105 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - C(JC+J)= - * C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - D(JC+J)= - * S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - C(JB+J)= - * C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - D(JB+J)= - * S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - C(JD+J)= - * C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - D(JD+J)= - * S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 105 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 110 CONTINUE - JBASE=JBASE+JUMP - 120 CONTINUE - RETURN -! -! CODING FOR FACTOR 5 -! - 130 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - IE=ID+IINK - JE=JD+JINK - DO 140 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 135 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 135 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 140 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 160 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - KE=KD+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - C4=TRIGS(KE+1) - S4=TRIGS(KE+2) - DO 150 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 145 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)= - * C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JB+J)= - * S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JE+J)= - * C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JE+J)= - * S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JC+J)= - * C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JC+J)= - * S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - C(JD+J)= - * C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JD+J)= - * S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - I=I+INC3 - J=J+INC4 - 145 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 150 CONTINUE - JBASE=JBASE+JUMP - 160 CONTINUE - RETURN - END - - subroutine bin ( qin,im_in,jm_in,qout,im_out,jm_out,lm,undef,msgn,lat_i,lat_o ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lat_i - type ( dynamics_lattice_type ) lat_o - - include 'mpif.h' - integer comm,myid,npes - integer imgi,jmgi,imgo,jmgo - - integer im_in ,jm_in ,msgn, lm - integer im_out,jm_out, L - real undef - real qin(im_in ,jm_in ,lm) - real qout(im_out,jm_out,lm) - - real, allocatable :: glo_i(:,:,:) - real, allocatable :: glo_o(:,:,:) - -c Temporary Array for Binning -c --------------------------- - integer imax - integer jmax - parameter ( imax = 360*12 ) - parameter ( jmax = 180*12 ) - real, allocatable :: qbin ( :,: ) - - integer index(lm),ierror - - call timebeg (' bin') - - comm = lat_i%comm - myid = lat_i%myid - npes = lat_i%nx * lat_i%ny - - imgi = lat_i%imglobal - jmgi = lat_i%jmglobal - imgo = lat_o%imglobal - jmgo = lat_o%jmglobal - - allocate ( qbin(imax,jmax) ) - allocate ( glo_i(imgi,jmgi,lm) ) - allocate ( glo_o(imgo,jmgo,lm) ) - - call timebeg (' Gather') - do L=1,lm - call gather_2d ( glo_i(1,1,L),qin(1,1,L),lat_i ) - enddo - call timeend (' Gather') - call mpi_bcast ( glo_i,imgi*jmgi*lm,lat_i%mpi_rkind,0,comm,ierror ) - - do L=1,lm - index(L) = mod(L-1,npes) - enddo - - do L=1,lm -c Parse Arbitray Field (im,jm) to 5'x5' Variable -c ---------------------------------------------- - call timebeg (' bin_q') - if( index(L).eq.myid ) call bin_q ( glo_i(1,1,L),imgi,jmgi,qbin,imax,jmax ) - call timeend (' bin_q') - -c Bin 10'x10' Variable to Output Field (im_out,jm_out) -c ---------------------------------------------------- - call timebeg (' ave_q') - if( index(L).eq.myid ) call ave_q ( qbin,imax,jmax,glo_o(1,1,L),imgo,jmgo,undef,msgn ) - call timeend (' ave_q') - enddo - - call mpi_barrier (comm,ierror) - do L=1,lm - call mpi_bcast ( glo_o(1,1,L),imgo*jmgo,lat_o%mpi_rkind,index(L),comm,ierror ) - enddo - call mpi_barrier (comm,ierror) - - call timebeg (' Scatter') - do L=1,lm - call scatter_2d ( glo_o(1,1,L),qout(1,1,L),lat_o ) - enddo - call timeend (' Scatter') - - deallocate ( qbin ) - deallocate ( glo_i ) - deallocate ( glo_o ) - - call timeend (' bin') - - return - end - - subroutine ave_q ( qbin,imax,jmax,q,im,jm,undef,msgn ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Average a (10m X 10m) input array to an output array (im,jm) -C -C INPUT: -C ====== -C qbin ....... Input array (imax,jmax) -C msgn ....... Integer Flag for scalar (0) or vector (1) -C -C OUTPUT: -C ======= -C q .......... Output array (im,jm) -C im ......... Longitudinal dimension of q -C jm ......... Latitudinal dimension of q -C -C NOTES: -C ====== -C Input array qbin represents values within a 5min X 5min grid-box. -C Each box is referenced by the latitude and longitude of -C its southwest corner, not its center point. Thus, -C the quantity associated with a coordinate actually -C represents the quantity centered to the northeast of that point. -C -C Output array q(im,jm) is assumed to be on an A-grid. -C q(i,j) represents the value at the center of the grid-box. -C q(1,j) is located at lon=-180. -C q(i,1) is located at lat=-90. -C q(i,jm) is located at lat=+90. -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer im,jm,msgn - real q(im,jm) - real dlam(im), dphi(jm) - - integer imax - integer jmax - real qbin ( imax,jmax ) - - integer i,j,ibeg,iend,jbeg,jend - integer ii,jj,itmp - real sum1,sum2 - real zlat,zlon - real lon1,lon2,wx - real lat1,lat2,wy - real lonbeg,lonend,lat,coslat - real latbeg,latend - real undef - real pi,dz - real lon_cmp(im) - real lat_cmp(jm) - logical defined - - pi = 4.*atan(1.0) - dlam = 2*pi/ im - dphi = pi/(jm-1) - dz = pi/(jmax) - -c Compute Computational Lambda's and Phi's -c ---------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - - -c Compute average away from poles -c ------------------------------- - do j=2,jm-1 - do i=1,im - - zlat = lat_cmp(j) - zlon = lon_cmp(i) - - latbeg = zlat-dphi(j-1)/2 - latend = zlat+dphi(j) /2 - if( i.eq.1 ) then - lonbeg = zlon-dlam(im) /2 - else - lonbeg = zlon-dlam(i-1)/2 - endif - lonend = zlon+dlam(i) /2 - - ibeg = 1.+(lonbeg+pi) /dz - iend = 1.+(lonend+pi) /dz - jbeg = 1.+(latbeg+pi/2)/dz - jend = 1.+(latend+pi/2)/dz - - sum1 = 0 - sum2 = 0 - do jj=jbeg,jend - lat = -pi/2+(jj-0.5)*dz - coslat = cos(lat) - lat1 = -pi/2 + (jj-1)*dz - lat2 = -pi/2 + jj *dz - wy = 1.0 - if( lat1.lt.latbeg ) wy = (lat2-latbeg)/dz - if( lat2.gt.latend ) wy = (latend-lat1)/dz - - if(ibeg.ge.1) then - do ii=ibeg,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - else - itmp = 1.+(lonbeg+0.1*dz+3*pi)/dz - do ii=itmp,imax - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg+2*pi ) wx = (lon2-lonbeg-2*pi)/dz - if( lon2.gt.lonend+2*pi ) wx = (2*pi+lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - do ii=1,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - endif - - enddo - q(i,j) = sum1/sum2 - enddo - enddo - -c Compute average at South Pole -c ----------------------------- - j=1 - do i=1,im - - zlat = lat_cmp(j) - zlon = lon_cmp(i) - - latbeg = zlat - latend = zlat+dphi(j) /2 - if( i.eq.1 ) then - lonbeg = zlon-dlam(im) /2 - else - lonbeg = zlon-dlam(i-1)/2 - endif - lonend = zlon+dlam(i) /2 - - ibeg = 1.+(lonbeg+pi) /dz - iend = 1.+(lonend+pi) /dz - jbeg = 1 - jend = 1.+(latend+pi/2)/dz - - sum1 = 0 - sum2 = 0 - do jj=jbeg,jend - lat = -pi/2+(jj-0.5)*dz - coslat = cos(lat) - lat1 = -pi/2 + (jj-1)*dz - lat2 = -pi/2 + jj *dz - wy = 1.0 - if( lat1.lt.latbeg ) wy = (lat2-latbeg)/dz - if( lat2.gt.latend ) wy = (latend-lat1)/dz - - if(ibeg.ge.1) then - do ii=ibeg,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - else - itmp = 1.+(lonbeg+0.1*dz+3*pi)/dz - do ii=itmp,imax - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg+2*pi ) wx = (lon2-lonbeg-2*pi)/dz - if( lon2.gt.lonend+2*pi ) wx = (2*pi+lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - do ii=1,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - endif - - enddo - q(i,j) = sum1/sum2 - enddo - -c Compute average at North Pole -c ----------------------------- - j=jm - do i=1,im - - zlat = lat_cmp(j) - zlon = lon_cmp(i) - - latbeg = zlat-dphi(j-1)/2 - latend = zlat - if( i.eq.1 ) then - lonbeg = zlon-dlam(im) /2 - else - lonbeg = zlon-dlam(i-1)/2 - endif - lonend = zlon+dlam(i) /2 - - ibeg = 1.+(lonbeg+pi) /dz - iend = 1.+(lonend+pi) /dz - jbeg = 1.+(latbeg+pi/2)/dz - jend = jmax - - sum1 = 0 - sum2 = 0 - do jj=jbeg,jend - lat = -pi/2+(jj-0.5)*dz - coslat = cos(lat) - lat1 = -pi/2 + (jj-1)*dz - lat2 = -pi/2 + jj *dz - wy = 1.0 - if( lat1.lt.latbeg ) wy = (lat2-latbeg)/dz - if( lat2.gt.latend ) wy = (latend-lat1)/dz - - if(ibeg.ge.1) then - do ii=ibeg,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - else - itmp = 1.+(lonbeg+0.1*dz+3*pi)/dz - do ii=itmp,imax - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg+2*pi ) wx = (lon2-lonbeg-2*pi)/dz - if( lon2.gt.lonend+2*pi ) wx = (2*pi+lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - do ii=1,iend - if( defined(qbin(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + qbin(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - endif - - enddo - q(i,j) = sum1/sum2 - enddo - -c Average Pole Values -c ------------------- - if( msgn.eq.0 ) then - sum1 = 0 - j = 0 - do i=1,im - if( defined(q(i,1),undef) ) then - sum1 = sum1 + q(i,1) - j = j + 1 - endif - enddo - if( j.ne.0 ) then - q(:,1) = sum1/j - else - q(:,1) = undef - endif - - sum2 = 0 - j = 0 - do i=1,im - if( defined(q(i,jm),undef) ) then - sum2 = sum2 + q(i,jm) - j = j + 1 - endif - enddo - if( j.ne.0 ) then - q(:,jm) = sum2/j - else - q(:,jm) = undef - endif - - endif - - return - end - subroutine bin_q ( q,im,jm,qbin,imax,jmax ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute a 5min X 5min binned array from an input array q(im,jm) -C -C INPUT: -C ====== -C q .......... Input array(im,jm) -C im ......... Longitudinal dimension of q -C jm ......... Latitudinal dimension of q -C -C OUTPUT: -C ======= -C qbin ....... Output array (imax,jmax) -C -C NOTES: -C ====== -C Input array q(im,jm) is assumed to be on an A-grid. -C q(i,j) represents the value at the center of the grid-box. -C q(1,j) is located at lon=-180. -C q(i,1) is located at lat=-90. -C q(i,jm) is located at lat=+90. -C -C Output array qbin represents values within a 5min X 5min grid-box. -C Each box is referenced by the latitude and longitude of -C its southwest corner, not its center point. Thus, -C the quantity associated with a coordinate actually -C represents the quantity centered to the northeast of that point. -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer im,jm - real q(im,jm) - - integer imax - integer jmax - real qbin ( imax,jmax ) - - integer i,j,ii,jj,ibeg,iend,jbeg,jend - real zlatc,zlonc - real lonbeg,lonend - real latbeg,latend - real pi,dl,dp,dz - - pi = 4.*atan(1.0) - dl = 2*pi/im - dp = pi/(jm-1) - dz = pi/(jmax) - - do j=1,jmax - do i=1,imax - - zlatc = -pi/2+(j-0.5)*dz ! Latitude at center of bin box - zlonc = -pi +(i-0.5)*dz ! Longitude at center of bin box - -c Find bounding lat and lon on IMxJM grid -c --------------------------------------- - iend = nint( 1.+(zlonc+pi)/dl ) - lonend = -pi + (iend-1)*dl - if( lonend.ge.zlonc ) then - lonbeg = -pi + (iend-2)*dl - else - iend = iend+1 - lonbeg = lonend - lonend = -pi + (iend-1)*dl - endif - ibeg = iend-1 - - jend = nint( 1.+(zlatc+pi/2)/dp ) - latend = -pi/2 + (jend-1)*dp - if( latend.ge.zlatc ) then - latbeg = -pi/2 + (jend-2)*dp - else - jend = jend+1 - latbeg = latend - latend = -pi/2 + (jend-1)*dp - endif - jbeg = jend-1 - - - if(iend.gt.im) iend=iend-im - - if( zlonc.le.lonbeg+0.5*dl ) then - ii = ibeg - else - ii = iend - endif - if( zlatc.le.latbeg+0.5*dp ) then - jj = jbeg - else - jj = jend - endif - - qbin(i,j) = q(ii,jj) - - enddo - enddo - - return - end - - subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef,lat_i,lat_o ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lat_i - type ( dynamics_lattice_type ) lat_o - include 'mpif.h' - integer comm,myid,npes - - integer iin,jin, iout,jout, mlev - real qin(iin,jin,mlev), qout(iout,jout,mlev) - real undef,pi,dlin,dpin,dlout,dpout,lon,lat - integer i,j,L,loc - integer index(mlev),ierror - integer imgi,jmgi,imgo,jmgo - - real, allocatable :: glo_i(:,:,:) - real, allocatable :: glo_o(:,:,:) - real, allocatable :: lons(:), dlam(:) - real, allocatable :: lats(:), dphi(:) - - call timebeg (' hinterp') - - comm = lat_i%comm - myid = lat_i%myid - npes = lat_i%nx * lat_i%ny - - imgi = lat_i%imglobal - jmgi = lat_i%jmglobal - imgo = lat_o%imglobal - jmgo = lat_o%jmglobal - - allocate ( glo_i(imgi,jmgi,mlev) ) - allocate ( glo_o(imgo,jmgo,mlev) ) - allocate ( lons(imgo*jmgo) ) - allocate ( lats(imgo*jmgo) ) - allocate ( dlam(imgi) ) - allocate ( dphi(jmgi) ) - - do L=1,mlev - index(L) = mod(L-1,npes) - enddo - - pi = 4.0*atan(1.0) - dlin = 2*pi/ imgi - dpin = pi/(jmgi-1) - dlam(:) = dlin - dphi(:) = dpin - - dlout = 2*pi/ imgo - dpout = pi/(jmgo-1) - - loc = 0 - do j=1,jmgo - do i=1,imgo - loc = loc + 1 - lon = -pi + (i-1)*dlout - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jmgo - lat = -pi/2.0 + (j-1)*dpout - do i=1,imgo - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call timebeg (' Gather') - do L=1,mlev - call gather_2d ( glo_i(1,1,L),qin(1,1,L),lat_i ) - enddo - call timeend (' Gather') - call mpi_bcast ( glo_i,imgi*jmgi*mlev,lat_i%mpi_rkind,0,comm,ierror ) - - do L=1,mlev - if( index(L).eq.myid ) then - call interp_h ( glo_i(1,1,L),imgi,jmgi,1,dlam,dphi, - . glo_o(1,1,L),imgo*jmgo,lons,lats,undef ) - endif - enddo - - call mpi_barrier (comm,ierror) - do L=1,mlev - call mpi_bcast ( glo_o(1,1,L),imgo*jmgo,lat_o%mpi_rkind,index(L),comm,ierror ) - enddo - call mpi_barrier (comm,ierror) - - call timebeg (' Scatter') - do L=1,mlev - call scatter_2d ( glo_o(1,1,L),qout(1,1,L),lat_o ) - enddo - call timeend (' Scatter') - - deallocate ( glo_i ) - deallocate ( glo_o ) - deallocate ( lons ) - deallocate ( lats ) - deallocate ( dlam ) - deallocate ( dphi ) - - call timeend (' hinterp') - return - end - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*undef - return - end - - subroutine interp_h ( q_cmp,im,jm,lm,dlam,dphi, - . q_geo,irun,lon_geo,lat_geo,undef ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - -c Local Variables -c --------------- - integer i,j,l - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real ap1, ap0, am1, am2 - real bp1, bp0, bm1, bm2 - - real, allocatable :: lon_cmp(:) - real, allocatable :: lat_cmp(:) - real, allocatable :: q_tmp(:) - - real pi,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp - real lam_cmp - real phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - - allocate ( lon_cmp(im) ) - allocate ( lat_cmp(jm) ) - allocate ( q_tmp(irun) ) - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - do i=1,irun - lam_cmp = lon_geo(i) - phi_cmp = lat_geo(i) - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm2 = lat_cmp(jm2(i)) - phi_jm1 = lat_cmp(jm1(i)) - phi_jp0 = lat_cmp(jp0(i)) - phi_jp1 = lat_cmp(jp1(i)) - - if( jm2(i).eq.0 ) phi_jm2 = phi_jm1 - dphi(1) - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - endif - if( jp1(i).eq.jm+1 ) phi_jp1 = phi_jp0 + dphi(jm-1) - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - -c Interpolate Computational-Grid Quantities to Geophysical Grid -c ------------------------------------------------------------- - do L=1,lm - do i=1,irun - - if( lat_geo(i).le.lat_cmp(2) .or. - . lat_geo(i).ge.lat_cmp(jm-1) ) then - -c 1st Order Interpolation at Poles -c -------------------------------- - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - else - -c Cubic Interpolation away from Poles -c ----------------------------------- - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jp1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp1(i),L ).ne.undef .and. - . q_cmp( im2(i),jp1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm2(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm2(i),L ).ne.undef .and. - . q_cmp( im1(i),jm2(i),L ).ne.undef .and. - . q_cmp( im2(i),jm2(i),L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) - . + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) - . + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) - . + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) - . + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) - . + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) - . + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - deallocate ( lon_cmp ) - deallocate ( lat_cmp ) - deallocate ( q_tmp ) - return - end - - subroutine remap ( ple,u,v,thv,q,o3,phis_in,phis_out,ak,bk,im,jm,lm ) - -C*********************************************************************** -C -C Purpose -C Driver for remapping fields to new topography -C -C Argument Description -C ple ...... model edge pressure -C u ....... model zonal wind -C v ....... model meridional wind -C thv ..... model virtual potential temperature -C q ....... model specific humidity -C o3 ...... model ozone -C phis_in... model surface geopotential (input) -C phis_out.. model surface geopotential (output) -C ak ....... model vertical dimension -C bk ....... model vertical dimension -C -C im ....... zonal dimension -C jm ....... meridional dimension -C lm ....... meridional dimension -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer im,jm,lm - -c Input variables -c --------------- - real ple(im,jm,lm+1) - real u(im,jm,lm) - real v(im,jm,lm) - real thv(im,jm,lm) - real q(im,jm,lm) - real o3(im,jm,lm) - real phis_in (im,jm) - real phis_out(im,jm) - - real ak(lm+1) - real bk(lm+1) - -c Local variables -c --------------- - real, allocatable :: ps (:,:) - real, allocatable :: phi (:,:,:) - real, allocatable :: pke (:,:,:) - real, allocatable :: ple_out(:,:,:) - real, allocatable :: pke_out(:,:,:) - - real, allocatable :: delp(:,:,:) - real, allocatable :: u_out(:,:,:) - real, allocatable :: v_out(:,:,:) - real, allocatable :: thv_out(:,:,:) - real, allocatable :: q_in (:,:,:,:) - real, allocatable :: q_out(:,:,:,:) - - real kappa,cp,rgas,eps,rvap - integer i,j,L - - kappa = 2.0/7.0 - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - cp = rgas/kappa - - allocate( ps (im,jm) ) - allocate( phi (im,jm,lm+1) ) - allocate( pke (im,jm,lm+1) ) - allocate( ple_out(im,jm,lm+1) ) - allocate( pke_out(im,jm,lm+1) ) - - allocate( delp(im,jm,lm) ) - allocate( u_out(im,jm,lm) ) - allocate( v_out(im,jm,lm) ) - allocate( thv_out(im,jm,lm) ) - allocate( q_in (im,jm,lm,2) ) - allocate( q_out(im,jm,lm,2) ) - -c Construct Input Heights -c ----------------------- - pke(:,:,:) = ple(:,:,:)**kappa - - phi(:,:,lm+1) = phis_in(:,:) - do L=lm,1,-1 - phi(:,:,L) = phi(:,:,L+1) + cp*thv(:,:,L)*( pke(:,:,L+1)-pke(:,:,L) ) - enddo - -c Compute new surface pressure consistent with output topography -c -------------------------------------------------------------- - do j=1,jm - do i=1,im - L = lm - do while ( phi(i,j,L).lt.phis_out(i,j) ) - L = L-1 - enddo - ps(i,j) = ple(i,j,L+1)*( 1+(phi(i,j,L+1)-phis_out(i,j))/(cp*thv(i,j,L)*pke(i,j,L+1)) )**(1.0/kappa) - enddo - enddo - -c Construct fv pressure variables using new surface pressure -c ---------------------------------------------------------- - do L=1,lm+1 - do j=1,jm - do i=1,im - ple_out(i,j,L) = ak(L) + bk(L)*ps(i,j) - enddo - enddo - enddo - pke_out(:,:,:) = ple_out(:,:,:)**kappa - -c Map original fv state onto new eta grid -c --------------------------------------- - q_in(:,:,:,1) = q(:,:,:) - q_in(:,:,:,2) = o3(:,:,:) - - call gmap ( im,jm,2 , kappa, - . lm, pke ,ple ,u ,v ,thv ,q_in , - . lm, pke_out,ple_out,u_out,v_out,thv_out,q_out) - - ple(:,:,:) = ple_out(:,:,:) - u(:,:,:) = u_out(:,:,:) - v(:,:,:) = v_out(:,:,:) - thv(:,:,:) = thv_out(:,:,:) - q(:,:,:) = q_out(:,:,:,1) - o3(:,:,:) = q_out(:,:,:,2) - - deallocate( ps ) - deallocate( phi ) - deallocate( pke ) - deallocate( ple_out ) - deallocate( pke_out ) - - deallocate( delp ) - deallocate( u_out ) - deallocate( v_out ) - deallocate( thv_out ) - deallocate( q_in ) - deallocate( q_out ) - - return - end diff --git a/GEOS_Util/post/merra2scm.F b/GEOS_Util/post/merra2scm.F deleted file mode 100644 index baa58850..00000000 --- a/GEOS_Util/post/merra2scm.F +++ /dev/null @@ -1,1198 +0,0 @@ - - program main - - implicit none -c ********************************************************************** -c **** **** -c **** Program to create scm driving dataset from MERRA output **** -c **** **** -c ********************************************************************** - - integer begdate,begtime,enddate,endtime - real lonbegin,lonend,latbegin,latend -! parameter ( begdate = 19970618 ) -c parameter ( begdate = 19921220 ) -c parameter ( begdate = 19921228 ) -! parameter ( begtime = 000000 ) -! parameter ( enddate = 19970717) -c parameter ( enddate = 19921130) -c parameter ( enddate = 19930110) -c parameter ( enddate = 19930102) -c parameter ( enddate = 19930202) -! parameter ( endtime = 230000 ) - -! arm97 - -! parameter ( begdate = 19970618 ) -! parameter ( begtime = 000000 ) -! parameter ( enddate = 19970717) -! parameter ( endtime = 230000 ) -! parameter ( lonbegin = -100.000 ) -! parameter ( lonend = -95.0000 ) -! parameter ( latbegin = 34.0000 ) -! parameter ( latend = 38.0000 ) - -! coare -! parameter ( begdate = 19921101 ) -! parameter ( begtime = 000000 ) -! parameter ( enddate = 19930228) -! parameter ( endtime = 230000 ) - -! parameter ( lonbegin = 152.000 ) -! parameter ( lonend = 158.0000 ) -! parameter ( latbegin = -5.0000 ) -! parameter ( latend = 2.0000 ) - -! arm scsmex - - parameter ( begdate = 20130310) - parameter ( begtime = 000000 ) - parameter ( enddate = 20130601) -c parameter ( enddate = 20130320) - parameter ( endtime = 230000 ) -c parameter ( lonbegin = -158.000 ) -c parameter ( lonend = -156.0000 ) -c parameter ( latbegin = 70.0000 ) -c parameter ( latend = 72.0000 ) - -c parameter ( lonbegin = -158.000 ) -c parameter ( lonend = -156.0000 ) -c parameter ( latbegin = 50.0000 ) -c parameter ( latend = 52.0000 ) - - parameter ( lonbegin = -52.000 ) - parameter ( lonend = -50.0000 ) - parameter ( latbegin = 66.0000 ) - parameter ( latend = 68.0000 ) - - -c Generic Model Variables -c ----------------------- - real, allocatable :: ps(:,:) - real, allocatable :: ts(:,:) - real, allocatable :: eflux(:,:) - real, allocatable :: hflux(:,:) - real, allocatable :: prectot(:,:) - real, allocatable :: t(:,:,:) - real, allocatable :: qv(:,:,:) - real, allocatable :: u(:,:,:) - real, allocatable :: v(:,:,:) - real, allocatable :: omega(:,:,:) - real, allocatable :: dtdtdyn(:,:,:) - real, allocatable :: dqvdtdyn(:,:,:) - real, allocatable :: plevs(:) - real, allocatable :: lonN(:) - real, allocatable :: latN(:) - real, allocatable :: lonC(:) - real, allocatable :: latC(:) -c--------SVETA--------------- - real, allocatable :: dtdtana(:,:,:) - real, allocatable :: dqvdtana(:,:,:) -c------------------------------------- - real psscm(1000), tsscm(1000), efluxscm(1000), hfluxscm(1000), prectotscm(1000) - real tscm(1000,100), qvscm(1000,100), uscm(1000,100), vscm(1000,100) - real omegascm(1000,100), dtdtdynscm(1000,100), dqvdtdynscm(1000,100) -c------------SVETA------------------- - real dtdtanascm(1000,100), dqvdtanascm(1000,100) -c--------------------------------- - integer yearsscm(1000), monthsscm(1000), daysscm(1000), hoursscm(1000), minutesscm(1000) - real timesscm(1000),plevsscm(100) - integer modymd - real undef - - character*256 dsnprefix(5) - character*256 dirname - - integer id,id1,id2,id3,n,ntimes,nymd,nhms,nvars,rc - integer imN,jmN,lmN,imC,jmC,lmC - integer index - - dirname = '/discover/nobackup/aeichman/barrow/data/' - dsnprefix(1) = 'd5_merra_jan98.tavg1_2d_slv_Nx' - dsnprefix(2) = 'd5_merra_jan98.tavg1_2d_flx_Nx' - dsnprefix(3) = 'd5_merra_jan98.tavg3_3d_tdt_Cp' - dsnprefix(4) = 'd5_merra_jan98.tavg3_3d_qdt_Cp' - dsnprefix(5) = 'd5_merra_jan98.inst3_3d_asm_Cp' - -! dsnprefix(1) = 'd5_merra_jan98.tavg1_2d_slv_Nx' -! dsnprefix(2) = 'd5_merra_jan98.tavg1_2d_flx_Nx' -! dsnprefix(3) = 'd5_merra_jan98.tavg3_3d_tdt_Cp' -! dsnprefix(4) = 'd5_merra_jan98.tavg3_3d_qdt_Cp' -! dsnprefix(5) = 'd5_merra_jan98.inst3_3d_asm_Cp' - - - nymd = begdate - nhms = begtime - n = 0 - -CC Loop over all input times - - do while (nymd.le.enddate) - n = n+1 - print *,' nymd ',nymd,' nhms ',nhms - - yearsscm(n) = nymd/10000 - monthsscm(n) = (nymd - yearsscm(n)*10000)/100 - daysscm(n) = nymd - yearsscm(n)*10000 - monthsscm(n)*100 - hoursscm(n) = nhms/10000 - minutesscm(n) = (nhms - hoursscm(n)*10000)/100 - timesscm(n) = float(modymd(nymd)) + float(hoursscm(n))/24. - - call read_file_diminfo1(id,dirname,dsnprefix(5),nymd,nhms,imC,jmC,lmC,nvars,ntimes,rc) - allocate(t(imC,jmC,lmC)) - allocate(qv(imC,jmC,lmC)) - allocate(u(imC,jmC,lmC)) - allocate(v(imC,jmC,lmC)) - allocate(omega(imC,jmC,lmC)) - allocate(plevs(lmC)) - allocate(lonC(imC)) - allocate(latC(jmC)) - call read_asm_data (id,t,qv,u,v,omega,latC,lonC,imC,jmC,lmC,plevs,nvars,ntimes,undef,rc) - do index=1,lmC - plevsscm(index) = plevs(index) - enddo - deallocate(plevs) - - call tick(nymd,nhms,1800) - call read_file_diminfo3(id1,id2,id3,dirname,dsnprefix(1),nymd,nhms,imN,jmN,lmN,nvars,ntimes,rc) - allocate(lonN(imN)) - allocate(latN(jmN)) - allocate(ps(imN,jmN)) - allocate(ts(imN,jmN)) - allocate(plevs(1)) - call read_slv_data (id1,id2,id3,ps,ts,latN,lonN,imN,jmN,lmN,plevs,nvars,ntimes,rc) - - call read_file_diminfo3(id1,id2,id3,dirname,dsnprefix(2),nymd,nhms,imN,jmN,lmN,nvars,ntimes,rc) - allocate(eflux(imN,jmN)) - allocate(hflux(imN,jmN)) - allocate(prectot(imN,jmN)) - call read_flx_data (id1,id2,id3,eflux,hflux,prectot,latN,lonN,imN,jmN,lmN,plevs,nvars,ntimes,rc) - deallocate(plevs) - - call tick(nymd,nhms,3600) - call read_file_diminfo1(id,dirname,dsnprefix(3),nymd,nhms,imC,jmC,lmC,nvars,ntimes,rc) - allocate(dtdtdyn(imC,jmC,lmC)) - allocate(plevs(lmC)) - call read_tdt_data (id,dtdtdyn,latC,lonC,imC,jmC,lmC,plevs,nvars,ntimes,undef,rc) -c----------------------SVETA--------------------------- - - call read_file_diminfo1(id,dirname,dsnprefix(3),nymd,nhms,imC,jmC,lmC,nvars,ntimes,rc) - allocate(dtdtana(imC,jmC,lmC)) - call read_tdtana_data (id,dtdtana,latC,lonC,imC,jmC,lmC,plevs,nvars,ntimes,undef,rc) -c=========================================================================== - call read_file_diminfo1(id,dirname,dsnprefix(4),nymd,nhms,imC,jmC,lmC,nvars,ntimes,rc) - allocate(dqvdtdyn(imC,jmC,lmC)) - call read_qdt_data (id,dqvdtdyn,latC,lonC,imC,jmC,lmC,plevs,nvars,ntimes,undef,rc) -c-----------SVETA----------------------------------------- - call read_file_diminfo1(id,dirname,dsnprefix(4),nymd,nhms,imC,jmC,lmC,nvars,ntimes,rc) - allocate(dqvdtana(imC,jmC,lmC)) - call read_qdtana_data (id,dqvdtana,latC,lonC,imC,jmC,lmC,plevs,nvars,ntimes,undef,rc) -c----------------------------------------------------------------- - call getmylatlon2(latbegin,lonbegin,latend,lonend,latN,lonN,imN,jmN,ps,psscm(n)) - call getmylatlon2(latbegin,lonbegin,latend,lonend,latN,lonN,imN,jmN,ts,tsscm(n)) - call getmylatlon2(latbegin,lonbegin,latend,lonend,latN,lonN,imN,jmN,eflux,efluxscm(n)) - call getmylatlon2(latbegin,lonbegin,latend,lonend,latN,lonN,imN,jmN,hflux,hfluxscm(n)) - call getmylatlon2(latbegin,lonbegin,latend,lonend,latN,lonN,imN,jmN,prectot,prectotscm(n)) - call getmylatlon3(n,latbegin,lonbegin,latend,lonend,latC,lonC,imC,jmC,lmC,t,undef,tscm) - call getmylatlon3(n,latbegin,lonbegin,latend,lonend,latC,lonC,imC,jmC,lmC,qv,undef,qvscm) - call getmylatlon3(n,latbegin,lonbegin,latend,lonend,latC,lonC,imC,jmC,lmC,u,undef,uscm) - call getmylatlon3(n,latbegin,lonbegin,latend,lonend,latC,lonC,imC,jmC,lmC,v,undef,vscm) - call getmylatlon3(n,latbegin,lonbegin,latend,lonend,latC,lonC,imC,jmC,lmC,omega,undef,omegascm) - call getmylatlon3(n,latbegin,lonbegin,latend,lonend,latC,lonC,imC,jmC,lmC,dtdtdyn,undef,dtdtdynscm) - call getmylatlon3(n,latbegin,lonbegin,latend,lonend,latC,lonC,imC,jmC,lmC,dqvdtdyn,undef,dqvdtdynscm) -c------------------SVETA---------------------- - call getmylatlon3(n,latbegin,lonbegin,latend,lonend,latC,lonC,imC,jmC,lmC,dtdtana,undef,dtdtanascm) - call getmylatlon3(n,latbegin,lonbegin,latend,lonend,latC,lonC,imC,jmC,lmC,dqvdtana,undef,dqvdtanascm) -c---------------------------------- - call tick(nymd,nhms,5400) - - deallocate(t) - deallocate(qv) - deallocate(u) - deallocate(v) - deallocate(omega) - deallocate(lonC) - deallocate(latC) - deallocate(lonN) - deallocate(latN) - deallocate(plevs) - deallocate(ps) - deallocate(ts) - deallocate(eflux) - deallocate(hflux) - deallocate(prectot) - deallocate(dtdtdyn) - deallocate(dqvdtdyn) - deallocate(dtdtana) - deallocate(dqvdtana) - enddo - - print *,' number of time levels ',n - call writer_meta(n,lmC,plevsscm,timesscm,yearsscm,monthsscm,daysscm,hoursscm,minutesscm) -c call writer_upper(n,lmC,tscm,qvscm,uscm,vscm,omegascm,dtdtdynscm,dqvdtdynscm) - call writer_upper(n,lmC,tscm,qvscm,uscm,vscm,omegascm,dtdtdynscm,dqvdtdynscm,dtdtanascm,dqvdtanascm) - - call writer_surface(n,psscm,tsscm,efluxscm,hfluxscm,prectotscm) - - stop - end - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine read_file_diminfo1(id,dirname,dsnprefix,nymd,nhms,im,jm,lm,nvars,ntimes,rc) - implicit none - integer id,nymd,nhms,im,jm,lm,nvars,ntimes,rc - character * 256 dirname,dsnprefix - - character * 256 dsname - integer ngatts - character*8 date0 - character*4 time0 - character*2 hour0,mins0 - - write(date0,1000) nymd - write(hour0,2000) nhms/10000 - write(mins0,2000) (nhms-(nhms/10000)*10000)/100 - 1000 format(i8.8) - 2000 format(i2.2) - time0 = trim(hour0)//trim(mins0) - dsname = trim(dirname) // trim(dsnprefix) // "." // trim(date0) // "_" // trim(time0) // "z.hdf" - - call gfio_open(trim(dsname),1,id,rc) - - if( rc.ne.0) then - print *,' Something wrong with file open ',trim(dsname) - stop - endif - - call gfio_diminquire (id,im,jm,lm,ntimes,nvars,ngatts,rc ) - - end subroutine read_file_diminfo1 - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine read_file_diminfo3 (id1,id2,id3,dirname,dsnprefix,nymd,nhms,im,jm,lm,nvars,ntimes,rc) - implicit none - integer id1,id2,id3,nymd,nhms,im,jm,lm,nvars,ntimes,rc - character * 256 dirname,dsnprefix - - character * 256 dsname - integer ngatts - character*8 date0 - character*4 time0 - character*2 hour0,mins0 - integer locnymd, locnhms - - locnymd = nymd - locnhms = nhms - write(date0,1000) locnymd - write(hour0,2000) locnhms/10000 - write(mins0,2000) (locnhms-(locnhms/10000)*10000)/100 - 1000 format(i8.8) - 2000 format(i2.2) - time0 = trim(hour0)//trim(mins0) - dsname = trim(dirname) // trim(dsnprefix) // "." // trim(date0) // "_" // trim(time0) // "z.hdf" - - call gfio_open(trim(dsname),1,id1,rc) - - if( rc.ne.0) then - print *,' Something wrong with file open ',trim(dsname) - stop - endif - - call tick(locnymd,locnhms,3600) - write(date0,1000) locnymd - write(hour0,2000) locnhms/10000 - write(mins0,2000) (locnhms-(locnhms/10000)*10000)/100 - time0 = trim(hour0)//trim(mins0) - dsname = trim(dirname) // trim(dsnprefix) // "." // trim(date0) // "_" // trim(time0) // "z.hdf" - - call gfio_open(trim(dsname),1,id2,rc) - - if( rc.ne.0) then - print *,' Something wrong with file open ',trim(dsname) - stop - endif - - call tick(locnymd,locnhms,3600) - write(date0,1000) locnymd - write(hour0,2000) locnhms/10000 - write(mins0,2000) (locnhms-(locnhms/10000)*10000)/100 - time0 = trim(hour0)//trim(mins0) - dsname = trim(dirname) // trim(dsnprefix) // "." // trim(date0) // "_" // trim(time0) // "z.hdf" - - call gfio_open(trim(dsname),1,id3,rc) - - if( rc.ne.0) then - print *,' Something wrong with file open ',trim(dsname) - stop - endif - - call gfio_diminquire (id1,im,jm,lm,ntimes,nvars,ngatts,rc ) - - end subroutine read_file_diminfo3 - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine read_slv_data (id1,id2,id3,ps,ts,lats,lons,im,jm,lm,plevs,nvars,ntime,rc) - implicit none - - integer id1,id2,id3,im,jm,lm,nvars,ntime,rc - real ts(im,jm), ps(im,jm), lats(jm), lons(im), plevs(1) - real ts1(im,jm), ts2(im,jm), ts3(im,jm) - real ps1(im,jm), ps2(im,jm), ps3(im,jm) - - integer timinc - integer, allocatable :: yyyymmdd(:),hhmmss(:),kmvar(:) - character * 256 title,source,contact,levunits - real amiss - character * 256, allocatable :: vname(:),vtitle(:),vunits(:) - real, allocatable :: valrange(:,:),packrange(:,:) - - allocate ( yyyymmdd(1) ) - allocate ( hhmmss(1) ) - allocate ( kmvar(nvars) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( valrange(2,nvars) ) - allocate ( packrange(2,nvars) ) - -C ********************************************************************** -C **** Read HDF File for Some Info and the data **** -C ********************************************************************** - call gfio_inquire ( id1,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - call gfio_getvar ( id1,'PS',yyyymmdd(1),hhmmss(1),im,jm,0, 1,ps1,rc ) - call gfio_getvar ( id1,'TS',yyyymmdd(1),hhmmss(1),im,jm,0, 1,ts1,rc ) - -C ********************************************************************** - - call gfio_inquire ( id2,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - call gfio_getvar ( id2,'PS',yyyymmdd(1),hhmmss(1),im,jm,0, 1,ps2,rc ) - call gfio_getvar ( id2,'TS',yyyymmdd(1),hhmmss(1),im,jm,0, 1,ts2,rc ) - -C ********************************************************************** - call gfio_inquire ( id3,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - call gfio_getvar ( id3,'PS',yyyymmdd(1),hhmmss(1),im,jm,0, 1,ps3,rc ) - call gfio_getvar ( id3,'TS',yyyymmdd(1),hhmmss(1),im,jm,0, 1,ts3,rc ) -C ********************************************************************** - - ts = (ts1+ts2+ts3)/3. - ps = (ps1+ps2+ps3)/3. - - call gfio_close ( id1,rc ) - call gfio_close ( id2,rc ) - call gfio_close ( id3,rc ) - - deallocate ( yyyymmdd ) - deallocate ( hhmmss ) - deallocate ( kmvar ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( valrange ) - deallocate ( packrange ) - - return - end subroutine read_slv_data - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine read_flx_data (id1,id2,id3,eflux,hflux,prectot,lats,lons,im,jm,lm,plevs,nvars,ntime,rc) - implicit none - - integer id1,id2,id3,im,jm,lm,nvars,ntime,rc - real eflux(im,jm), hflux(im,jm), prectot(im,jm), lats(jm), lons(im), plevs(1) - real eflux1(im,jm), eflux2(im,jm), eflux3(im,jm) - real hflux1(im,jm), hflux2(im,jm), hflux3(im,jm) - real prectot1(im,jm), prectot2(im,jm), prectot3(im,jm) - - integer timinc - integer, allocatable :: yyyymmdd(:),hhmmss(:),kmvar(:) - character * 256 title,source,contact,levunits - character * 256, allocatable :: vname(:),vtitle(:),vunits(:) - real amiss - real, allocatable :: valrange(:,:),packrange(:,:) - - allocate ( yyyymmdd(1) ) - allocate ( hhmmss(1) ) - allocate ( kmvar(nvars) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( valrange(2,nvars) ) - allocate ( packrange(2,nvars) ) - -C ********************************************************************** -C **** Read HDF File for Some Info and Data **** -C ********************************************************************** - - call gfio_inquire ( id1,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - - call gfio_getvar ( id1,'EFLUX',yyyymmdd(1),hhmmss(1),im,jm,0, 1,eflux1,rc ) - call gfio_getvar ( id1,'HFLUX',yyyymmdd(1),hhmmss(1),im,jm,0, 1,hflux1,rc ) - call gfio_getvar ( id1,'PRECTOT',yyyymmdd(1),hhmmss(1),im,jm,0, 1,prectot1,rc ) -C ********************************************************************** - - call gfio_inquire ( id2,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - - call gfio_getvar ( id2,'EFLUX',yyyymmdd(1),hhmmss(1),im,jm,0, 1,eflux2,rc ) - call gfio_getvar ( id2,'HFLUX',yyyymmdd(1),hhmmss(1),im,jm,0, 1,hflux2,rc ) - call gfio_getvar ( id2,'PRECTOT',yyyymmdd(1),hhmmss(1),im,jm,0, 1,prectot2,rc ) -C ********************************************************************** - - call gfio_inquire ( id3,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - - call gfio_getvar ( id3,'EFLUX',yyyymmdd(1),hhmmss(1),im,jm,0, 1,eflux3,rc ) - call gfio_getvar ( id3,'HFLUX',yyyymmdd(1),hhmmss(1),im,jm,0, 1,hflux3,rc ) - call gfio_getvar ( id3,'PRECTOT',yyyymmdd(1),hhmmss(1),im,jm,0, 1,prectot3,rc ) -C ********************************************************************** - - eflux = (eflux1+eflux2+eflux3)/3. - hflux = (hflux1+hflux2+hflux3)/3. - prectot = (prectot1+prectot2+prectot3)/3. - - call gfio_close ( id1,rc ) - call gfio_close ( id2,rc ) - call gfio_close ( id3,rc ) - - deallocate ( yyyymmdd ) - deallocate ( hhmmss ) - deallocate ( kmvar ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( valrange ) - deallocate ( packrange ) - - return - end subroutine read_flx_data - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine read_tdt_data (id,tdt,lats,lons,im,jm,lm,plevs,nvars,ntime,amiss,rc) - implicit none - - integer id,im,jm,lm,nvars,ntime,rc - real tdt(im,jm,lm), lats(jm), lons(im), plevs(lm) - real amiss - - integer timinc - integer, allocatable :: yyyymmdd(:),hhmmss(:),kmvar(:) - character * 256 title,source,contact,levunits - character * 256, allocatable :: vname(:),vtitle(:),vunits(:) - real, allocatable :: valrange(:,:),packrange(:,:) - -C ********************************************************************** -C **** Read HDF File for Some Info **** -C ********************************************************************** - - allocate ( yyyymmdd(1) ) - allocate ( hhmmss(1) ) - allocate ( kmvar(nvars) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( valrange(2,nvars) ) - allocate ( packrange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - -C ********************************************************************** -C **** Read HDF File for Data **** -C ********************************************************************** - - call gfio_getvar ( id,'DTDTDYN',yyyymmdd(1),hhmmss(1),im,jm,1,lm,tdt,rc ) - - call gfio_close ( id,rc ) - - deallocate ( yyyymmdd ) - deallocate ( hhmmss ) - deallocate ( kmvar ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( valrange ) - deallocate ( packrange ) - - return - end subroutine read_tdt_data - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine read_tdtana_data (id,tdtana,lats,lons,im,jm,lm,plevs,nvars,ntime,amiss,rc) - implicit none - - integer id,im,jm,lm,nvars,ntime,rc - real tdtana(im,jm,lm), lats(jm), lons(im), plevs(lm) - real amiss - - integer timinc - integer, allocatable :: yyyymmdd(:),hhmmss(:),kmvar(:) - character * 256 title,source,contact,levunits - character * 256, allocatable :: vname(:),vtitle(:),vunits(:) - real, allocatable :: valrange(:,:),packrange(:,:) - - -C ********************************************************************** -C **** Read HDF File for Some Info **** -C ********************************************************************** - - allocate ( yyyymmdd(1) ) - allocate ( hhmmss(1) ) - allocate ( kmvar(nvars) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( valrange(2,nvars) ) - allocate ( packrange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - -C ********************************************************************** -C **** Read HDF File for Data **** -C ********************************************************************** - - call gfio_getvar ( id,'DTDTANA',yyyymmdd(1),hhmmss(1),im,jm,1,lm,tdtana,rc ) - - call gfio_close ( id,rc ) - - deallocate ( yyyymmdd ) - deallocate ( hhmmss ) - deallocate ( kmvar ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( valrange ) - deallocate ( packrange ) - - return - end subroutine read_tdtana_data - - - - -c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine read_qdt_data (id,qdt,lats,lons,im,jm,lm,plevs,nvars,ntime,amiss,rc) - implicit none - - integer id,im,jm,lm,nvars,ntime,rc - real qdt(im,jm,lm), lats(jm), lons(im), plevs(lm) - real amiss - - integer timinc - integer, allocatable :: yyyymmdd(:),hhmmss(:),kmvar(:) - character * 256 title,source,contact,levunits - character * 256, allocatable :: vname(:),vtitle(:),vunits(:) - real, allocatable :: valrange(:,:),packrange(:,:) - -C ********************************************************************** -C **** Read HDF File for Some Info **** -C ********************************************************************** - - allocate ( yyyymmdd(1) ) - allocate ( hhmmss(1) ) - allocate ( kmvar(nvars) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( valrange(2,nvars) ) - allocate ( packrange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - -C ********************************************************************** -C **** Read HDF File for Data **** -C ********************************************************************** - - call gfio_getvar ( id,'DQVDTDYN',yyyymmdd(1),hhmmss(1),im,jm,1,lm,qdt,rc ) - - call gfio_close ( id,rc ) - - deallocate ( yyyymmdd ) - deallocate ( hhmmss ) - deallocate ( kmvar ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( valrange ) - deallocate ( packrange ) - - return - end subroutine read_qdt_data - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine read_qdtana_data (id,qdtana,lats,lons,im,jm,lm,plevs,nvars,ntime,amiss,rc) - implicit none - - integer id,im,jm,lm,nvars,ntime,rc - real qdtana(im,jm,lm), lats(jm), lons(im), plevs(lm) - real amiss - - integer timinc - integer, allocatable :: yyyymmdd(:),hhmmss(:),kmvar(:) - character * 256 title,source,contact,levunits - character * 256, allocatable :: vname(:),vtitle(:),vunits(:) - real, allocatable :: valrange(:,:),packrange(:,:) - -C ********************************************************************** -C **** Read HDF File for Some Info **** -C ********************************************************************** - - allocate ( yyyymmdd(1) ) - allocate ( hhmmss(1) ) - allocate ( kmvar(nvars) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( valrange(2,nvars) ) - allocate ( packrange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - -C ********************************************************************** -C **** Read HDF File for Data **** -C ********************************************************************** - - call gfio_getvar ( id,'DQVDTANA',yyyymmdd(1),hhmmss(1),im,jm,1,lm,qdtana,rc ) - - call gfio_close ( id,rc ) - - deallocate ( yyyymmdd ) - deallocate ( hhmmss ) - deallocate ( kmvar ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( valrange ) - deallocate ( packrange ) - - return - end subroutine read_qdtana_data - - - -c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine read_asm_data (id,t,qv,u,v,omega,lats,lons,im,jm,lm,plevs,nvars,ntime,amiss,rc) - implicit none - - integer id,im,jm,lm,nvars,ntime,rc - real t(im,jm,lm), qv(im,jm,lm), u(im,jm,lm), v(im,jm,lm), omega(im,jm,lm) - real lats(jm), lons(im), plevs(lm) - real amiss - - integer timinc - integer, allocatable :: yyyymmdd(:),hhmmss(:),kmvar(:) - character * 256 title,source,contact,levunits - character * 256, allocatable :: vname(:),vtitle(:),vunits(:) - real, allocatable :: valrange(:,:),packrange(:,:) - - -C ********************************************************************** -C **** Read HDF File for Some Info **** -C ********************************************************************** - - allocate ( yyyymmdd(1) ) - allocate ( hhmmss(1) ) - allocate ( kmvar(nvars) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( valrange(2,nvars) ) - allocate ( packrange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, - . title,source,contact,amiss, - . lons,lats,plevs,levunits, - . yyyymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . valrange,packrange,rc ) - -C ********************************************************************** -C **** Read HDF File for Data **** -C ********************************************************************** - - call gfio_getvar ( id,'T',yyyymmdd(1),hhmmss(1),im,jm,1,lm,t,rc ) - call gfio_getvar ( id,'QV',yyyymmdd(1),hhmmss(1),im,jm,1,lm,qv,rc ) - call gfio_getvar ( id,'U',yyyymmdd(1),hhmmss(1),im,jm,1,lm,u,rc ) - call gfio_getvar ( id,'V',yyyymmdd(1),hhmmss(1),im,jm,1,lm,v,rc ) - call gfio_getvar ( id,'OMEGA',yyyymmdd(1),hhmmss(1),im,jm,1,lm,omega,rc ) - - call gfio_close ( id,rc ) - - deallocate ( yyyymmdd ) - deallocate ( hhmmss ) - deallocate ( kmvar ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( valrange ) - deallocate ( packrange ) - - return - end subroutine read_asm_data - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine getmylatlon2(latbegin,lonbegin,latend,lonend,lats,lons, - . imN,jmN,fieldin,fieldscm) - implicit none - real latbegin,lonbegin,latend,lonend - integer imN,jmN - real lats(jmN),lons(imN) - real fieldin(imN,jmN),fieldscm - - real dlat, dlon - integer ii,jj,ibegin,iend,jbegin,jend,itot - - dlat = abs(lats(1)-lats(2)) - dlon = abs(lons(1)-lons(2)) - ibegin = nint( abs(-180.-lonbegin)/dlon ) - iend = nint( abs(-180.-lonend)/dlon ) - jbegin = nint( abs(-90.-latbegin)/dlat ) - jend = nint( abs(-90.-latend)/dlat ) - itot = (iend-ibegin+1) * (jend-jbegin+1) - fieldscm = 0. - - do ii=ibegin,iend - do jj=jbegin,jend - fieldscm = fieldscm + fieldin(ii,jj)/itot - enddo - enddo - - return - end subroutine getmylatlon2 - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine getmylatlon3(n,latbegin,lonbegin,latend,lonend,lats,lons, - . imC,jmC,lmC,fieldin,undef,fieldscm) - implicit none - real latbegin,lonbegin,latend,lonend - integer n,imC,jmC,lmC - real lats(jmC),lons(imC) - real fieldin(imC,jmC,lmC),fieldscm(1000,100) - real undef - - integer ii,jj,kk,ibegin,iend,jbegin,jend,itot - real dlat, dlon - logical undefs - - undefs = .false. - dlat = abs(lats(1)-lats(2)) - dlon = abs(lons(1)-lons(2)) - ibegin = nint( abs(-180.-lonbegin)/dlon ) - iend = nint( abs(-180.-lonend)/dlon ) - jbegin = nint( abs(-90.-latbegin)/dlat ) - jend = nint( abs(-90.-latend)/dlat ) - itot = (iend-ibegin+1) * (jend-jbegin+1) - do kk = 1,lmC - fieldscm(n,kk) = 0. - enddo - - do kk = 1,lmC - do ii=ibegin,iend - do jj=jbegin,jend - fieldscm(n,kk) = fieldscm(n,kk) + fieldin(ii,jj,kk)/itot - enddo - enddo - if(fieldscm(n,kk).gt.undef/1000.) then - fieldscm(n,kk)=undef - undefs = .true. - endif - enddo - - if(undefs) call extrap(n,lmC,undef,fieldscm) - - return - end subroutine getmylatlon3 - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine writer_meta(n,lmC,plevsscm,timesscm,yearsscm,monthsscm,daysscm,hoursscm,minutesscm) - implicit none - integer n,lmC - real plevsscm(lmC),timesscm(n) - integer yearsscm(n),monthsscm(n),daysscm(n),hoursscm(n),minutesscm(n) - - integer ii - - open (20,file='merra_scm.dat',form='formatted',access='sequential') - - write(20,1000) - write(20,*) n - write(20,1001) - write(20,*) lmC - write(20,1002) - write(20,*) 'mb' - write(20,3000)(plevsscm(ii),ii=1,lmC) - write(20,*) 'time TIME(nt)' - write(20,3000)(timesscm(ii),ii=1,n) - write(20,*) 'year YY(nt)' - write(20,3000)(float(yearsscm(ii)),ii=1,n) - write(20,*) 'month MO(nt)' - write(20,3000)(float(monthsscm(ii)),ii=1,n) - write(20,*) 'day DD(nt)' - write(20,3000)(float(daysscm(ii)),ii=1,n) - write(20,*) 'hour HH(nt)' - write(20,3000)(float(hoursscm(ii)),ii=1,n) - write(20,*) 'minute MM(nt)' -! write(20,1008) - write(20,3000)(float(minutesscm(ii)),ii=1,n) - - 1000 format(' time length (nt)') - 1001 format(' number of pressure levels (np)') - 1002 format(' pressure levels P(np)') - 1003 format('Time t(nt):') - 1004 format('Year yy(nt):') - 1005 format('Month mo(nt):') - 1006 format('Day day(nt):') - 1007 format('Hour hh(nt):') - 1008 format('Minutes mm(nt):') - 2000 format(5e15.7) - 3000 format(1es15.7) - - return - end subroutine writer_meta - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine writer_upper(n,lmC,tscm,qvscm,uscm,vscm,omegascm,dtdtdynscm,dqvdtdynscm,dtdtanascm,dqvdtanascm) - implicit none - integer n,lmC - real tscm(1000,100),qvscm(1000,100),uscm(1000,100),vscm(1000,100),omegascm(1000,100) - real dtdtdynscm(1000,100),dqvdtdynscm(1000,100),dtdtanascm(1000,100),dqvdtanascm(1000,100) - - integer ii,kk - integer numlev,numtim - real zeros(1000,100) - - numlev=lmC - numtim=n - - zeros = 0. - - write(20,*) "Number of Multi-Level Fields: " - write(20,*) " 11" - - write(20,*) 1, " & Temp_(K)" - write(20,*) "K" - do kk=1,numtim - write(20,*) "nt=", kk - write(20,2000)(tscm(kk,ii),ii=1,numlev) - enddo - -c write(20,*) 2, " & H2O_Mixing_Ratio_(g/kg)" - write(20,*) 2, " & H2O_Mixing_Ratio_(kg/kg)" - write(20,*) "g/kg" - do kk=1,numtim - write(20,*) "nt=", kk -c write(20,2000)(qvscm(kk,ii)*1000.,ii=1,numlev) - write(20,2000)(qvscm(kk,ii),ii=1,numlev) - enddo - - write(20,*) 3, " & U_wind_(m/sec)" - write(20,*) "m/sec" - do kk=1,numtim - write(20,*) "nt=", kk - write(20,2000)(uscm(kk,ii),ii=1,numlev) - enddo - - write(20,*) 4, " & V_wind_(m/sec)" - write(20,*) "m/sec" - do kk=1,numtim - write(20,*) "nt=", kk - write(20,2000)(vscm(kk,ii),ii=1,numlev) - enddo - - write(20,*) 5, " & Omega_(mb/hour)" - write(20,*) "mb/hour" - do kk=1,numtim - write(20,*) "nt=", kk - write(20,2000)(omegascm(kk,ii)*36.,ii=1,numlev) - enddo - - write(20,*) 6, " & Horizontal_Temp_Advec_(K/hour) dtdtdynscm" - write(20,*) "K/hour" - do kk=1,numtim - write(20,*) "nt=", kk - write(20,2000)(dtdtdynscm(kk,ii)*3600.,ii=1,numlev) - enddo - - write(20,*) 7, " & Vertical_Temp_Advec_(K/hour)" - write(20,*) "K/hour" - do kk=1,numtim - write(20,*) "nt=", kk - write(20,2000)(zeros(kk,ii),ii=1,numlev) - enddo - - write(20,*) 8, " & Horizontal_q_Advec_(g/kg/hour)dqvdtdynscm" - write(20,*) "K/hour" - do kk=1,numtim - write(20,*) "nt=", kk - write(20,2000)(dqvdtdynscm(kk,ii)*3600000.,ii=1,numlev) - enddo - - write(20,*) 9, " & Vertical_q_Advec_(g/kg/hour)" - write(20,*) "K/hour" - do kk=1,numtim - write(20,*) "nt=", kk - write(20,2000)(zeros(kk,ii),ii=1,numlev) - enddo - -c---------------SVETA------------- - write(20,*) 10, " & Horizontal_Temp_Advec_(K/hour) dtdtanascm" - write(20,*) "K/hour" - do kk=1,numtim - write(20,*) "nt=", kk - write(20,2000)(dtdtanascm(kk,ii)*3600.,ii=1,numlev) - enddo - - write(20,*) 11, " & Horizontal_q_Advec_(g/kg/hour)dqvdtanascm" - write(20,*) "K/hour" - do kk=1,numtim - write(20,*) "nt=", kk - write(20,2000)(dqvdtanascm(kk,ii)*3600.,ii=1,numlev) - enddo - - 2000 format(1es15.7) - - return - end subroutine writer_upper - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine writer_surface(n,psscm,tsscm,efluxscm,hfluxscm,prectotscm) - implicit none - integer n - real psscm(n),tsscm(n),efluxscm(n),hfluxscm(n),prectotscm(n) - - integer ii - -! write(20,1000) -! write(20,1001) -! write(20,1002) - write(20,*) 'Number of Single-Level Fields:' - write(20,*) 5 - - - write(20,*) 1, " & SH_(W/m**2)" - write(20,*) "W/m**2" - do ii = 1,n - write(20,2000)hfluxscm(ii) - enddo - - write(20,*) 2, " & LH_(W/m**2)" - write(20,*) "W/m**2" - do ii = 1,n - write(20,2000)efluxscm(ii) - enddo - - write(20,*) 3, " & TS_(K)" - write(20,*) "K" - do ii = 1,n - write(20,2000)tsscm(ii) - enddo - - write(20,*) 4, " & PS_(mb)" - write(20,*) "mb" - do ii = 1,n - write(20,2000)psscm(ii)/100. - enddo - - write(20,*) 5, " & Prec_(mm/hour)" - write(20,*) "mm/hour" - do ii = 1,n - write(20,2000)prectotscm(ii)*3600. - enddo - - -! 1000 format('Number of Single-Level Fields:') -! 1001 format(' 5 ') -! 1002 format(' SH_(W/m**2) ',' LH_(W/m**2) ',' TS_(K) ',' PS_(mb) ',' Prec_(mm/hour)') -! 2000 format(5e15.7) - 2000 format(1es15.7) - - return - end subroutine writer_surface - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - subroutine extrap(n,lmC,undef,fieldscm) - implicit none - integer n,lmC - real undef,fieldscm(1000,100) - - integer kk - real valabove - - valabove=fieldscm(n,lmC) - do kk=lmC-1,1,-1 - if(fieldscm(n,kk).eq.undef) then - fieldscm(n,kk)=valabove - else - valabove = fieldscm(n,kk) - endif - enddo - - return - end subroutine extrap - -c %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - function nsecf (nhms) -C*********************************************************************** -C Converts NHMS format to Total Seconds -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end function nsecf - - function nhmsf (nsec) -C*********************************************************************** -C Converts Total Seconds to NHMS format -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end function nhmsf - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - end subroutine tick - - function incymd (NYMD,M) -C*********************************************************************** -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - DATA NY00 / 1900 / - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (NY.NE.0 .OR. MOD(NY00,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - RETURN - end function incymd diff --git a/GEOS_Util/post/mpi_util.F b/GEOS_Util/post/mpi_util.F deleted file mode 100644 index 6744af4c..00000000 --- a/GEOS_Util/post/mpi_util.F +++ /dev/null @@ -1,1532 +0,0 @@ -#include "unused_dummy.H" -C ********************************************************************** - subroutine init_dynamics_lattice ( lattice,comm,imglobal,jmglobal,lm ) -C ********************************************************************** - use dynamics_lattice_module - implicit none - include 'mymalloc_interface' - type ( dynamics_lattice_type ) lattice - integer comm,imglobal,jmglobal,lm - real dummy - -#if mpi - include 'mpif.h' -#else - integer mpi_real,mpi_double_precision -#endif - integer myid,ierror,im,jm,i,j,m,n,npes,rm - integer isum,jsum,imx,nx, img, ppe(imglobal) - -#if (mpi) - call mpi_comm_rank ( comm,myid,ierror ) -#else - myid = 0 - mpi_real = 4 - mpi_double_precision = 8 -#endif - - call mymalloc ( lattice%ppeg,imglobal ) - - lattice%comm = comm - lattice%myid = myid - lattice%nx = size( lattice%im ) - lattice%ny = size( lattice%jm ) - - npes = lattice%nx*lattice%ny - - lattice%imglobal = imglobal - lattice%jmglobal = jmglobal - lattice%lm = lm - - if( kind(dummy).eq.4 ) lattice%mpi_rkind = mpi_real - if( kind(dummy).eq.8 ) lattice%mpi_rkind = mpi_double_precision - -c Initialize lattice%im -c --------------------- - im = imglobal/lattice%nx - rm = imglobal-lattice%nx*im - lattice%imax = im - do n=0,lattice%nx-1 - lattice%im(n) = im - if( n.le.rm-1 ) lattice%im(n) = im+1 - lattice%imax = max( lattice%imax,lattice%im(n) ) - enddo - -c Initialize lattice%jm -c --------------------- - jm = jmglobal/lattice%ny - rm = jmglobal-lattice%ny*jm - lattice%jmax = jm - do n=0,lattice%ny-1 - lattice%jm(n) = jm - if( n.le.rm-1 ) lattice%jm(n) = jm+1 - lattice%jmax = max( lattice%jmax,lattice%jm(n) ) - enddo - -c Initialize relative PE address -c ------------------------------ - lattice%pei = mod(myid,lattice%nx) - lattice%pej = myid/lattice%nx - -c Initialize global index for local locations -c ------------------------------------------- - call mymalloc ( lattice%iglobal,lattice%im(lattice%pei) ) - call mymalloc ( lattice%jglobal,lattice%jm(lattice%pej) ) - - isum = 0 - do n=0,lattice%nx-1 - if ( n.eq.lattice%pei ) then - do i=1,lattice%im(n) - lattice%iglobal(i) = i+isum - enddo - endif - isum = isum + lattice%im(n) - enddo - - jsum = 0 - do m=0,lattice%ny-1 - if ( m.eq.lattice%pej ) then - do j=1,lattice%jm(m) - lattice%jglobal(j) = j+jsum - enddo - endif - jsum = jsum + lattice%jm(m) - enddo - -c Initialize local index for global locations -c ------------------------------------------- - call mymalloc ( lattice%ilocal,lattice%imglobal ) - call mymalloc ( lattice%jlocal,lattice%jmglobal ) - - n = 0 - isum = 0 - do i = 1,imglobal - if(i.gt.isum+lattice%im(n) ) then - isum = isum+lattice%im(n) - n = n + 1 - endif - lattice%ilocal(i) = i-isum - enddo - - m = 0 - jsum = 0 - do j = 1,jmglobal - if(j.gt.jsum+lattice%jm(m) ) then - jsum = jsum+lattice%jm(m) - m = m + 1 - endif - lattice%jlocal(j) = j-jsum - enddo - -c Initialize relative PE address for global i-j locations -c ------------------------------------------------------- - call mymalloc ( lattice%peiglobal,imglobal ) - call mymalloc ( lattice%pejglobal,jmglobal ) - - isum = 0 - do n=0,lattice%nx-1 - do i=1,lattice%im(n) - lattice%peiglobal( i+isum ) = n - enddo - isum = isum + lattice%im(n) - enddo - - jsum = 0 - do m=0,lattice%ny-1 - do j=1,lattice%jm(m) - lattice%pejglobal( j+jsum ) = m - enddo - jsum = jsum + lattice%jm(m) - enddo - -c Initialize Pole PE ghosts for each iglobal -c ------------------------------------------ - isum = 0 - do nx=0,lattice%nx-1 - imx = lattice%im(nx) - do i=1,imx - ppe(i+isum) = nx - enddo - isum = isum + imx - enddo - - do i=1,imglobal/2 - lattice%ppeg(i) = ppe(i+imglobal/2) - lattice%ppeg(i+imglobal/2) = ppe(i) - enddo - -c Allocate Lattice%img -c -------------------- - if(.not.associated(lattice%img)) then - allocate ( lattice%img(0:nx-1,imglobal) ) - do m=1,imglobal - do n=0,nx-1 - lattice%img(n,m) = 0 - enddo - enddo - else - m=size(lattice%img) - if(m.ne.nx*imglobal) then - print *, 'Allocated Lattice Size (',m,') does not match request (',nx*imglobal,') for lattice%img!' - call my_finalize - call my_exit (101) - endif - endif - -c Allocate Lattice%im0 -c -------------------- - if(.not.associated(lattice%im0)) then - allocate ( lattice%im0(0:nx-1,imglobal) ) - do m=1,imglobal - do n=0,nx-1 - lattice%im0(n,m) = 0 - enddo - enddo - else - m=size(lattice%im0) - if(m.ne.nx*imglobal) then - print *, 'Allocated Lattice Size (',m,') does not match request (',nx*imglobal,') for lattice%im0!' - call my_finalize - call my_exit (101) - endif - endif - -c Determine Pole PE ghosts for each Processor -c ------------------------------------------- - isum = 0 - do nx=0,lattice%nx-1 - imx = lattice%im(nx) - lattice%npeg(nx) = 1 - lattice% im0(nx,1) = 1 - img = 1 - lattice%img (nx,lattice%npeg(nx)) = img - do i=2,imx - if( lattice%ppeg(i+isum) .eq. lattice%ppeg(i-1+isum) ) then - img = img + 1 - lattice%img (nx,lattice%npeg(nx)) = img - else - lattice%npeg(nx) = lattice%npeg(nx) + 1 - lattice%im0 (nx,lattice%npeg(nx)) = i - img = 1 - lattice%img (nx,lattice%npeg(nx)) = img - endif - enddo - isum = isum + imx - enddo - -c Print Lattice Characteristics -c ----------------------------- - if( myid.eq.0 ) then - print *, 'Number of Processors in X: ',lattice%nx - print *, 'Number of Processors in Y: ',lattice%ny - print * - endif -#if (mpi) - do n=0,npes-1 - if( n.eq.myid ) then - write(6,1000) myid,lattice%pei,lattice%pej,lattice%im(lattice%pei),lattice%jm(lattice%pej) - endif - call mpi_barrier (lattice%comm,ierror) - enddo - if( myid.eq.npes-1 ) print * -#endif - - 1000 format(1x,'absolute PE id: ',i4,' relative PE (i,j): (',i4,',',i4,') (im,jm) = (',i4,',',i4,')') - return - end - -C ********************************************************************** - subroutine scatter_1d ( qglobal,qlocal,lattice ) -C ********************************************************************** - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - real qglobal( lattice%imglobal ) - real qlocal ( lattice%im(lattice%myid) ) -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - integer comm - integer i,n,loc,im,imx,imglobal,myid,npes,ierror,mpi_rkind - real, allocatable :: buf(:) - - comm = lattice%comm - myid = lattice%myid - npes = lattice%nx - im = lattice%im(myid) - imglobal = lattice%imglobal - mpi_rkind = lattice%mpi_rkind - - if( myid.eq.0 ) then - do i=1,im - qlocal(i) = qglobal(i) - enddo -#if (mpi) - loc = im - do n=1,npes-1 - imx = lattice%im(n) - allocate ( buf(imx) ) - do i=1,imx - loc = loc + 1 - buf(i) = qglobal(loc) - enddo - call mpi_send ( buf,imx,mpi_rkind,n,n,comm,ierror ) - deallocate ( buf ) - enddo - else - call mpi_recv ( qlocal,im,mpi_rkind,0,myid,comm,status,ierror ) -#endif - endif - - return - end - -C ********************************************************************** - subroutine scatter_2d ( qglobal,qlocal,lattice ) -C ********************************************************************** - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - real qglobal( lattice%imglobal,lattice%jmglobal ) - real qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - integer comm - integer myid,npe,ierror,mpi_rkind - integer nx,i,iloc,im,imx,imglobal,isum - integer ny,j,jloc,jm,jmy,jmglobal,jsum - real, allocatable :: buf(:,:) - - comm = lattice%comm - myid = lattice%myid - iloc = lattice%pei - jloc = lattice%pej - im = lattice%im(iloc) - jm = lattice%jm(jloc) - imglobal = lattice%imglobal - jmglobal = lattice%jmglobal - mpi_rkind = lattice%mpi_rkind - - if( myid.eq.0 ) then - jsum = 0 - do ny=0,lattice%ny-1 - jmy = lattice%jm(ny) - isum = 0 - do nx=0,lattice%nx-1 - imx = lattice%im(nx) - - if( nx.eq.0 .and. ny.eq.0 ) then - do j=1,jmy - do i=1,imx - qlocal(i,j) = qglobal(i,j) - enddo - enddo - isum = isum + imx - else -#if (mpi) - allocate ( buf(imx,jmy) ) - do j=1,jmy - do i=1,imx - buf(i,j) = qglobal(i+isum,j+jsum) - enddo - enddo - isum = isum + imx - - npe = nx + ny*lattice%nx - call mpi_send ( buf,imx*jmy,mpi_rkind,npe,npe,comm,ierror ) - deallocate ( buf ) -#endif - endif - enddo - jsum = jsum + jmy - enddo - else -#if (mpi) - call mpi_recv ( qlocal,im*jm,mpi_rkind,0,myid,comm,status,ierror ) -#endif - endif - -#if (mpi) - call mpi_barrier ( comm,ierror ) -#endif - return - end - -C ********************************************************************** - subroutine iscatter_2d ( qglobal,qlocal,lattice ) -C ********************************************************************** - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer qglobal( lattice%imglobal,lattice%jmglobal ) - integer qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - integer comm - integer myid,npe,ierror - integer nx,i,iloc,im,imx,imglobal,isum - integer ny,j,jloc,jm,jmy,jmglobal,jsum - integer, allocatable :: buf(:,:) - - comm = lattice%comm - myid = lattice%myid - iloc = lattice%pei - jloc = lattice%pej - im = lattice%im(iloc) - jm = lattice%jm(jloc) - imglobal = lattice%imglobal - jmglobal = lattice%jmglobal - - if( myid.eq.0 ) then - jsum = 0 - do ny=0,lattice%ny-1 - jmy = lattice%jm(ny) - isum = 0 - do nx=0,lattice%nx-1 - imx = lattice%im(nx) - - if( nx.eq.0 .and. ny.eq.0 ) then - do j=1,jmy - do i=1,imx - qlocal(i,j) = qglobal(i,j) - enddo - enddo - isum = isum + imx - else -#if (mpi) - allocate ( buf(imx,jmy) ) - do j=1,jmy - do i=1,imx - buf(i,j) = qglobal(i+isum,j+jsum) - enddo - enddo - isum = isum + imx - - npe = nx + ny*lattice%nx - call mpi_send ( buf,imx*jmy,mpi_integer,npe,npe,comm,ierror ) - deallocate ( buf ) -#endif - endif - enddo - jsum = jsum + jmy - enddo - else -#if (mpi) - call mpi_recv ( qlocal,im*jm,mpi_integer,0,myid,comm,status,ierror ) -#endif - endif - -#if (mpi) - call mpi_barrier ( comm,ierror ) -#endif - return - end - -C ********************************************************************** - subroutine scatter_3d ( qglobal,qlocal,lattice ) -C ********************************************************************** - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - real qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) - real qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - integer comm,lm,L - integer myid,npe,ierror,mpi_rkind - integer nx,i,iloc,im,imx,imglobal,isum - integer ny,j,jloc,jm,jmy,jmglobal,jsum - real, allocatable :: buf(:,:,:) - - comm = lattice%comm - myid = lattice%myid - iloc = lattice%pei - jloc = lattice%pej - im = lattice%im(iloc) - jm = lattice%jm(jloc) - lm = lattice%lm - imglobal = lattice%imglobal - jmglobal = lattice%jmglobal - mpi_rkind = lattice%mpi_rkind - - if( myid.eq.0 ) then - jsum = 0 - do ny=0,lattice%ny-1 - jmy = lattice%jm(ny) - isum = 0 - do nx=0,lattice%nx-1 - imx = lattice%im(nx) - - if( nx.eq.0 .and. ny.eq.0 ) then - do L=1,lm - do j=1,jmy - do i=1,imx - qlocal(i,j,L) = qglobal(i,j,L) - enddo - enddo - enddo - isum = isum + imx - else -#if (mpi) - allocate ( buf(imx,jmy,lm) ) - do L=1,lm - do j=1,jmy - do i=1,imx - buf(i,j,L) = qglobal(i+isum,j+jsum,L) - enddo - enddo - enddo - isum = isum + imx - - npe = nx + ny*lattice%nx - call mpi_send ( buf,imx*jmy*lm,mpi_rkind,npe,npe,comm,ierror ) - deallocate ( buf ) -#endif - endif - enddo - jsum = jsum + jmy - enddo - else -#if (mpi) - call mpi_recv ( qlocal,im*jm*lm,mpi_rkind,0,myid,comm,status,ierror ) -#endif - endif - -#if (mpi) - call mpi_barrier ( comm,ierror ) -#endif - return - end - -C ********************************************************************** - subroutine gather_1d ( qglobal,qlocal,lattice ) -C ********************************************************************** - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - real qglobal( lattice%imglobal ) - real qlocal ( lattice%im(lattice%myid) ) -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - integer comm, mpi_rkind - integer i,n,loc,im,imx,myid,npes,ierror - - mpi_rkind = lattice%mpi_rkind - comm = lattice%comm - myid = lattice%myid - npes = lattice%nx - im = lattice%im(myid) - - if( myid.eq.0 ) then - do i=1,im - qglobal(i) = qlocal(i) - enddo -#if (mpi) - loc = im - do n=1,npes-1 - imx = lattice%im(n) - call mpi_recv ( qglobal(1+loc),imx,mpi_rkind,n,n,comm,status,ierror ) - loc = loc + imx - enddo - else - call mpi_send ( qlocal,im,mpi_rkind,0,myid,comm,ierror ) -#endif - endif - -#if (mpi) - call mpi_barrier ( comm,ierror ) -#endif - return - end - -C ********************************************************************** - subroutine gather_2d ( qglobal,qlocal,lattice ) -C ********************************************************************** - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - real qglobal( lattice%imglobal,lattice%jmglobal ) - real qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej) ) -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - integer comm, mpi_rkind - integer myid,npe,ierror - integer nx,i,iloc,im,imx,imglobal,isum - integer ny,j,jloc,jm,jmy,jmglobal,jsum - real, allocatable :: buf(:,:) - - mpi_rkind = lattice%mpi_rkind - comm = lattice%comm - myid = lattice%myid - iloc = lattice%pei - jloc = lattice%pej - im = lattice%im(iloc) - jm = lattice%jm(jloc) - imglobal = lattice%imglobal - jmglobal = lattice%jmglobal - - if( myid.eq.0 ) then - jsum = 0 - do ny=0,lattice%ny-1 - jmy = lattice%jm(ny) - isum = 0 - do nx=0,lattice%nx-1 - imx = lattice%im(nx) - - if( nx.eq.0 .and. ny.eq.0 ) then - do j=1,jmy - do i=1,imx - qglobal(i,j) = qlocal(i,j) - enddo - enddo - isum = isum + imx - else -#if (mpi) - allocate ( buf(imx,jmy) ) - npe = nx + ny*lattice%nx - call mpi_recv ( buf,imx*jmy,mpi_rkind,npe,npe,comm,status,ierror ) - do j=1,jmy - do i=1,imx - qglobal(i+isum,j+jsum) = buf(i,j) - enddo - enddo - isum = isum + imx - deallocate ( buf ) -#endif - endif - enddo - jsum = jsum + jmy - enddo - else -#if (mpi) - call mpi_send ( qlocal,im*jm,mpi_rkind,0,myid,comm,ierror ) -#endif - endif - -#if (mpi) - call mpi_barrier ( comm,ierror ) -#endif - return - end - -C ********************************************************************** - subroutine gather_3d ( qglobal,qlocal,lattice ) -C ********************************************************************** - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - real qglobal( lattice%imglobal,lattice%jmglobal,lattice%lm ) - real qlocal ( lattice%im(lattice%pei),lattice%jm(lattice%pej),lattice%lm ) -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - integer comm,lm,L - integer myid,npe,ierror, mpi_rkind - integer nx,i,iloc,im,imx,imglobal,isum - integer ny,j,jloc,jm,jmy,jmglobal,jsum - real, allocatable :: buf(:,:,:) - - mpi_rkind = lattice%mpi_rkind - comm = lattice%comm - myid = lattice%myid - iloc = lattice%pei - jloc = lattice%pej - im = lattice%im(iloc) - jm = lattice%jm(jloc) - lm = lattice%lm - imglobal = lattice%imglobal - jmglobal = lattice%jmglobal - - if( myid.eq.0 ) then - jsum = 0 - do ny=0,lattice%ny-1 - jmy = lattice%jm(ny) - isum = 0 - do nx=0,lattice%nx-1 - imx = lattice%im(nx) - - if( nx.eq.0 .and. ny.eq.0 ) then - do L=1,lm - do j=1,jmy - do i=1,imx - qglobal(i,j,L) = qlocal(i,j,L) - enddo - enddo - enddo - isum = isum + imx - else -#if (mpi) - allocate ( buf(imx,jmy,lm) ) - npe = nx + ny*lattice%nx - call mpi_recv ( buf,imx*jmy*lm,mpi_rkind,npe,npe,comm,status,ierror ) - do L=1,lm - do j=1,jmy - do i=1,imx - qglobal(i+isum,j+jsum,L) = buf(i,j,L) - enddo - enddo - enddo - isum = isum + imx - deallocate ( buf ) -#endif - endif - enddo - jsum = jsum + jmy - enddo - else -#if (mpi) - call mpi_send ( qlocal,im*jm*lm,mpi_rkind,0,myid,comm,ierror ) -#endif - endif - -#if (mpi) - call mpi_barrier ( comm,ierror ) -#endif - return - end - -C ********************************************************************** - subroutine ghostx (a,b,im,jm,lm,n,lattice,flag) -C ********************************************************************** -C **** **** -C **** This program fills GHOST values in the Y-direction **** -C **** **** -C **** a ....... Input Array Non-Ghosted **** -C **** b ....... Output Array Ghosted **** -C **** im ...... Local Zonal Dimension **** -C **** jm ...... Local Meridional Dimension **** -C **** lm ...... Local Vertical Dimension **** -C **** n ....... Number of GHOST values **** -C **** lattice . Grid Lattice for MPI **** -C **** flag .... Character*(*) to do 'east' or 'west' only **** -C **** **** -C ********************************************************************** - use MAPL_BaseMod, only: MAPL_UNDEF - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice -#if mpi - include 'mpif.h' - integer stat(mpi_status_size,4) -#endif - integer myid, nx, comm, ierror, mpi_rkind - integer send_reqeast, send_reqwest - integer recv_reqeast, recv_reqwest - character*(*) flag - - integer im,jm,lm,n,i,j,L - integer east,west - real undef - - real a(1 :im ,1:jm,lm) - real b(1-n:im+n,1:jm,lm) - real bufs(n,jm,lm,2) - real bufr(n,jm,lm,2) - - call timebeg (' ghostx ') - mpi_rkind = lattice%mpi_rkind - comm = lattice%comm - myid = lattice%myid - nx = lattice%nx - undef = MAPL_UNDEF - - if( n.gt.im ) then - print * - print *, 'Processor ',myid,' does not contain enough grid-points in X (',im,') to perform ',n,' point ghosting!' - call my_finalize - call my_exit (101) - endif - - east = mod( myid+nx+1,nx ) + (myid/nx)*nx - west = mod( myid+nx-1,nx ) + (myid/nx)*nx - - do L=1,lm - do j=1,jm - do i=1,im - b(i,j,L) = a(i,j,L) - enddo - do i=1,n - bufs(i,j,L,1) = a(i,j,L) - bufs(i,j,L,2) = a(im-n+i,j,L) - bufr(i,j,L,1) = undef - bufr(i,j,L,2) = undef - b( 1-i,j,L) = undef ! Initialize ghost regions - b(im+i,j,L) = undef ! Initialize ghost regions - enddo - enddo - enddo - - if( nx.gt.1 ) then -#if (mpi) - if( east.eq.west ) then - call mpi_sendrecv( bufs,2*n*jm*lm,mpi_rkind,east,east, - . bufr,2*n*jm*lm,mpi_rkind,west,myid,comm,stat,ierror ) - else - - if( flag.ne.'east' ) then - call mpi_isend ( bufs(1,1,1,2),n*jm*lm,mpi_rkind,east,east,comm,send_reqeast,ierror ) - call mpi_irecv ( bufr(1,1,1,2),n*jm*lm,mpi_rkind,west,myid,comm,recv_reqwest,ierror ) - endif - if( flag.ne.'west' ) then - call mpi_isend ( bufs(1,1,1,1),n*jm*lm,mpi_rkind,west,west,comm,send_reqwest,ierror ) - call mpi_irecv ( bufr(1,1,1,1),n*jm*lm,mpi_rkind,east,myid,comm,recv_reqeast,ierror ) - endif - if( flag.ne.'east' ) then - call mpi_wait ( send_reqeast,stat(1,1),ierror ) - call mpi_wait ( recv_reqwest,stat(1,2),ierror ) - endif - if( flag.ne.'west' ) then - call mpi_wait ( send_reqwest,stat(1,3),ierror ) - call mpi_wait ( recv_reqeast,stat(1,4),ierror ) - endif - - endif -#endif - else - do L=1,lm - do j=1,jm - do i=1,n - bufr(i,j,L,1) = bufs(i,j,L,1) - bufr(i,j,L,2) = bufs(i,j,L,2) - enddo - enddo - enddo - endif - - do L=1,lm - do j=1,jm - do i=-n+1,0 - b(i,j,L) = bufr(i+n,j,L,2) - enddo - do i=im+1,im+n - b(i,j,L) = bufr(i-im,j,L,1) - enddo - enddo - enddo - - call timeend (' ghostx ') - return - end - -C ********************************************************************** - subroutine ghosty (a,b,im,jm,lm,shift,msgn,n,lattice,flag) -C ********************************************************************** -C **** **** -C **** This program fills GHOST values in the Y-direction **** -C **** **** -C **** a ....... Input Array Non-Ghosted **** -C **** b ....... Output Array Ghosted **** -C **** im ...... Local Zonal Dimension **** -C **** jm ...... Local Meridional Dimension **** -C **** lm ...... Local Vertical Dimension **** -C **** shift ... Integer Flag: 0 for A-Grid, 1 for C-Grid VWND **** -C **** msgn .... Integer Flag for Scaler (1) or Vector (-1) **** -C **** n ....... Number of GHOST values **** -C **** lattice . Grid Lattice for MPI **** -C **** flag .... Character*(*) to do 'north', 'south', or 'pole' **** -C **** **** -C ********************************************************************** - use MAPL_BaseMod, only: MAPL_UNDEF - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - integer myid, nx, comm, ierror, mpi_rkind - character*(*) flag - - integer im,jm,lm,shift,n,i,j,L - integer north,south,request,msgn - real undef - - real a(1:im, 1:jm ,lm) - real b(1:im,1-n:jm+n,lm) - - real, allocatable :: apls(:,:,:) - real, allocatable :: amns(:,:,:) - real, allocatable :: buf(:,:) - - call timebeg (' ghosty ') - mpi_rkind = lattice%mpi_rkind - comm = lattice%comm - myid = lattice%myid - nx = lattice%nx - undef = MAPL_UNDEF - - _UNUSED_DUMMY(msgn) - if( (lattice%pej.eq.0 .and. n.gt.jm-1) .or. ! Pole values cannot be used for ghosting - . (lattice%pej.eq.lattice%ny-1 .and. n.gt.jm-1) .or. ! Pole values cannot be used for ghosting - . (n.gt.jm) ) then - print * - print *, 'Processor ',myid,' does not contain enough grid-points in Y (',jm,') to perform ',n,' point ghosting!' - call my_finalize - call my_exit (101) - endif - - do L=1,lm - do j=1,jm - do i=1,im - b(i,j,L) = a(i,j,L) - enddo - enddo - b(:, 1-n:0 ,L) = undef ! Initialize ghost regions - b(:,jm+1:jm+n,L) = undef ! Initialize ghost regions - enddo - -c Ghost South Pole -c ---------------- - if( lattice%pej.eq.0 .and. flag.ne.'north' ) then - do L=1,lm - do j=1,n - do i=1,im - b(i,1-j,L) = a(i,1+j-shift,L) - enddo - enddo - enddo - endif - -c Ghost North Pole -c ---------------- - if( lattice%pej.eq.lattice%ny-1 .and. flag.ne.'south' ) then - do L=1,lm - do j=1,n - do i=1,im - b(i,jm+j-shift,L) = a(i,jm-j,L) - enddo - enddo - enddo - endif - -c Ghost Non-Pole Points North -c --------------------------- - if( flag.ne.'south' .and. flag.ne.'pole' ) then - if( lattice%pej.eq.lattice%ny-1 .and. lattice%pej.ne.0 ) then - south = myid - nx - allocate ( buf(im*n*lm,1) ) - do L=1,lm - do j=1,n - do i=1,im - buf(i+(j-1)*im+(L-1)*im*n,1) = a(i,j,L) - enddo - enddo - enddo -#if (mpi) - call mpi_isend( buf,n*im*lm,mpi_rkind,south,south,comm,request,ierror ) - call mpi_wait ( request,status,ierror ) -#endif - deallocate ( buf ) - endif - if( lattice%pej.eq.0 .and. lattice%pej.ne.lattice%ny-1 ) then - north = myid + nx - allocate ( apls(im,n,lm) ) -#if (mpi) - call mpi_recv ( apls,n*im*lm,mpi_rkind,north,myid,comm,status,ierror ) -#else - do L=1,lm - do j=1,n - do i=1,im - apls(i,j,L) = buf(i+(j-1)*im+(L-1)*im*n,1) - enddo - enddo - enddo -#endif - do L=1,lm - do j=1,n - do i=1,im - b(i,jm+j,L) = apls(i,j,L) - enddo - enddo - enddo - deallocate ( apls ) - endif - if( lattice%pej.ne.0 .and. lattice%pej.ne.lattice%ny-1 ) then - north = myid + nx - south = myid - nx - allocate ( apls(im,n,lm) ) - allocate ( buf(im*n*lm,1) ) - do L=1,lm - do j=1,n - do i=1,im - buf(i+(j-1)*im+(L-1)*im*n,1) = a(i,j,L) - enddo - enddo - enddo -#if (mpi) - call mpi_isend( buf,n*im*lm,mpi_rkind,south,south,comm,request,ierror ) - call mpi_recv ( apls,n*im*lm,mpi_rkind,north,myid,comm,status,ierror ) - call mpi_wait ( request,status,ierror ) -#else - do L=1,lm - do j=1,n - do i=1,im - apls(i,j,L) = buf(i+(j-1)*im+(L-1)*im*n,1) - enddo - enddo - enddo -#endif - do L=1,lm - do j=1,n - do i=1,im - b(i,jm+j,L) = apls(i,j,L) - enddo - enddo - enddo - deallocate ( apls ) - deallocate ( buf ) - endif - endif - -c Ghost Non-Pole Points South -c --------------------------- - if( flag.ne.'north' .and. flag.ne.'pole' ) then - if( lattice%pej.eq.0 .and. lattice%pej.ne.lattice%ny-1 ) then - north = myid + nx - allocate ( buf(im*n*lm,1) ) - do L=1,lm - do j=1,n - do i=1,im - buf(i+(j-1)*im+(L-1)*im*n,1) = a(i,jm-n+j,L) - enddo - enddo - enddo -#if (mpi) - call mpi_isend( buf,n*im*lm,mpi_rkind,north,north,comm,request,ierror ) - call mpi_wait ( request,status,ierror ) -#endif - deallocate ( buf ) - endif - if( lattice%pej.eq.lattice%ny-1 .and. lattice%pej.ne.0 ) then - south = myid - nx - allocate ( amns(im,n,lm) ) -#if (mpi) - call mpi_recv ( amns,n*im*lm,mpi_rkind,south,myid,comm,status,ierror ) -#else - do L=1,lm - do j=1,n - do i=1,im - amns(i,j,L) = buf(i+(j-1)*im+(L-1)*im*n,1) - enddo - enddo - enddo -#endif - do L=1,lm - do j=1,n - do i=1,im - b(i,j-n,L) = amns(i,j,L) - enddo - enddo - enddo - deallocate ( amns ) - endif - if( lattice%pej.ne.0 .and. lattice%pej.ne.lattice%ny-1 ) then - north = myid + nx - south = myid - nx - allocate ( amns(im,n,lm) ) - allocate ( buf(im*n*lm,1) ) - do L=1,lm - do j=1,n - do i=1,im - buf(i+(j-1)*im+(L-1)*im*n,1) = a(i,jm-n+j,L) - enddo - enddo - enddo -#if (mpi) - call mpi_isend( buf,n*im*lm,mpi_rkind,north,north,comm,request,ierror ) - call mpi_recv ( amns,n*im*lm,mpi_rkind,south,myid,comm,status,ierror ) - call mpi_wait ( request,status,ierror ) -#else - do L=1,lm - do j=1,n - do i=1,im - amns(i,j,L) = buf(i+(j-1)*im+(L-1)*im*n,1) - enddo - enddo - enddo -#endif - do L=1,lm - do j=1,n - do i=1,im - b(i,j-n,L) = amns(i,j,L) - enddo - enddo - enddo - deallocate ( amns ) - deallocate ( buf ) - endif - endif - - call timeend (' ghosty ') - return - end - - subroutine par_dot ( q1,q2,qdot,im,jm,lattice ) -C*********************************************************************** -C PURPOSE -C Compute dot product for MPI grid -C -C q1 .... Input First Vector -C q2 .... Input Second Vector -C qdot .. Output Dot Product -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm - real q1(im,jm),q2(im,jm) - real qdot(jm) - real q12(lattice%imglobal,jm) - real, allocatable :: buf(:,:) -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - - real sum - integer i,j,n,i0,peid,peid0,ierror, mpi_rkind - - mpi_rkind = lattice%mpi_rkind - -c Compute Local Product -c --------------------- - do j=1,jm - do i=1,im - q12(i,j) = q1(i,j)*q2(i,j) - enddo - enddo - -c Get Data from other PEs to ensure reproducibility -c ------------------------------------------------- -#if (mpi) - peid0 = lattice%pej*lattice%nx - if( lattice%pei.eq.0 ) then - i0 = im - do n=1,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - allocate ( buf( lattice%im(n),jm ) ) - call mpi_recv ( buf,lattice%im(n)*jm,mpi_rkind,peid,peid,lattice%comm,status,ierror ) - do j=1,jm - do i=1,lattice%im(n) - q12(i+i0,j) = buf(i,j) - enddo - enddo - deallocate ( buf ) - i0 = i0 + lattice%im(n) - enddo - else - call mpi_send ( q12,im*jm,mpi_rkind,peid0,lattice%myid,lattice%comm,ierror ) - endif - -c Begin Dot Product Calculation -c ----------------------------- - if( lattice%pei.eq.0 ) then -#endif - - do j=1,jm - sum = q12(1,j) - do i=2,lattice%imglobal - sum = sum + q12(i,j) - enddo - qdot(j) = sum - enddo - -c Send Dot Product to other PEs -c ----------------------------- -#if (mpi) - do n=1,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - call mpi_send ( qdot,jm,mpi_rkind,peid,peid0,lattice%comm,ierror ) - enddo - else - call mpi_recv ( qdot,jm,mpi_rkind,peid0,peid0,lattice%comm,status,ierror ) - - endif ! End PEI Check -#endif - - return - end - - subroutine par_sum ( q,qsum,im,jm,lattice ) -C*********************************************************************** -C PURPOSE -C Compute sum for MPI grid -C -C q ..... Input Vector -C qsum .. Output Sum -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm - real q(im,jm) - real qsum(jm) - real qg(lattice%imglobal,jm) - real, allocatable :: buf(:,:) -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - - real sum - integer i,j,n,i0,peid,peid0,ierror, mpi_rkind - - mpi_rkind = lattice%mpi_rkind - -c Get Data from other PEs to ensure reproducibility -c ------------------------------------------------- - peid0 = lattice%pej*lattice%nx - if( lattice%pei.eq.0 ) then - do j=1,jm - do i=1,im - qg(i,j) = q(i,j) - enddo - enddo -#if (mpi) - i0 = im - do n=1,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - allocate ( buf( lattice%im(n),jm ) ) - call mpi_recv ( buf,lattice%im(n)*jm,mpi_rkind,peid,peid,lattice%comm,status,ierror ) - do j=1,jm - do i=1,lattice%im(n) - qg(i+i0,j) = buf(i,j) - enddo - enddo - deallocate ( buf ) - i0 = i0 + lattice%im(n) - enddo - else - call mpi_send ( q,im*jm,mpi_rkind,peid0,lattice%myid,lattice%comm,ierror ) - endif - -c Begin Sum Calculation -c --------------------- - if( lattice%pei.eq.0 ) then -#endif - - do j=1,jm - sum = qg(1,j) - do i=2,lattice%imglobal - sum = sum + qg(i,j) - enddo - qsum(j) = sum - enddo - -c Send Dot Product to other PEs -c ----------------------------- -#if (mpi) - do n=1,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - call mpi_send ( qsum,jm,mpi_rkind,peid,peid0,lattice%comm,ierror ) - enddo - else - call mpi_recv ( qsum,jm,mpi_rkind,peid0,peid0,lattice%comm,status,ierror ) -#endif - - endif ! End PEI Check - - return - end - - subroutine zmean ( q,qz,im,jm,undef,lattice ) -C*********************************************************************** -C PURPOSE -C Compute zonal mean for generalized MPI grid -C -C Note: m=0 Mass Point -C m=1 U-Wind Point -C lcheck Flag for UNDEF check -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm - real q(im,jm) - real qz(jm) - real qg(lattice%imglobal,jm) - real, allocatable :: buf(:,:) -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - - real isum,qsum,undef - integer i,j,n,i0,peid,peid0,ierror, mpi_rkind - - mpi_rkind = lattice%mpi_rkind - -c Get Data from other PEs to ensure reproducibility -c ------------------------------------------------- - peid0 = lattice%pej*lattice%nx - - if( lattice%pei.eq.0 ) then - do j=1,jm - do i=1,im - qg(i,j) = q(i,j) - enddo - enddo -#if (mpi) - i0 = im - do n=1,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - allocate ( buf( lattice%im(n),jm ) ) - call mpi_recv ( buf,lattice%im(n)*jm,mpi_rkind,peid,peid,lattice%comm,status,ierror ) - do j=1,jm - do i=1,lattice%im(n) - qg(i+i0,j) = buf(i,j) - enddo - enddo - deallocate ( buf ) - i0 = i0 + lattice%im(n) - enddo - else - call mpi_send ( q,im*jm,mpi_rkind,peid0,lattice%myid,lattice%comm,ierror ) -#endif - endif - -c Begin Zonal Mean Calculation -c ---------------------------- - if( lattice%pei.eq.0 ) then - - do j=1,jm - qsum = 0.0 - isum = 0.0 - do i=1,lattice%imglobal - if( qg(i,j).ne.undef ) then - qsum = qsum + qg(i,j) - isum = isum + 1 - endif - enddo - if( isum.ne.0.0 ) then - qz(j) = qsum/isum - else - qz(j) = undef - endif - enddo - -c Send Zonal Mean Data to other PEs -c --------------------------------- -#if (mpi) - do n=1,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - call mpi_send ( qz,jm,mpi_rkind,peid,peid0,lattice%comm,ierror ) - enddo - else - call mpi_recv ( qz,jm,mpi_rkind,peid0,peid0,lattice%comm,status,ierror ) -#endif - - endif ! End PEI Check - - return - end - - subroutine my_barrier (comm) - implicit none - integer comm,ierror -#if (mpi) - call timebeg (' barrier ' ) - call mpi_barrier ( comm,ierror ) - call timeend (' barrier ' ) -#endif - return - end - - subroutine my_finalize - implicit none - integer ierror -#if (mpi) - call mpi_finalize (ierror ) -#endif - return - end - - subroutine my_exit (irc) - implicit none - integer irc -#if (mpi) - integer ierror - call execute_command_line ('touch gcm_error') - call mpi_finalize (ierror) -#endif - error stop irc - return - end - - subroutine printchar (string,lattice) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - character*(*) string - integer i - do i=0,lattice%nx*lattice%ny-1 - if( i.eq.lattice%myid ) print *, 'myid: ',i,string - call my_barrier (lattice%comm) - enddo - return - end - - subroutine printint (string,n,lattice) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - character*(*) string - integer i,n - do i=0,lattice%nx*lattice%ny-1 - if( i.eq.lattice%myid ) print *, 'myid: ',i,string,n - call my_barrier (lattice%comm) - enddo - return - end - - subroutine printreal (string,q,num,lattice) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - character*(*) string - integer i,num,n - real q(num) - do i=0,lattice%nx*lattice%ny-1 - if( i.eq.lattice%myid ) print *, 'myid: ',i,string,(q(n),n=1,num) - call my_barrier (lattice%comm) - enddo - return - end - - subroutine timepri2 (ku,lattice) -C*********************************************************************** -C Purpose -C ------- -C Utility to Print Task Timings -C -C Argument Description -C -------------------- -C ku ........ Output Unit Number -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - include 'timer.com' - integer , allocatable :: ntasksg(:) - character*10, allocatable :: tasksg(:,:) - real , allocatable :: cputotg(:,:) - real , allocatable :: dum0(:) - real , allocatable :: dum1(:) - - integer ku - -c MPI Utilities -c ------------- -#if mpi - include 'mpif.h' - integer status(mpi_status_size) -#endif - integer ierror,peid - - integer npes,maxt,i,j,n,k, mpi_rkind - - _UNUSED_DUMMY(ku) - mpi_rkind = lattice%mpi_rkind - -#if mpi -c Get total number of tasks from each processor -c --------------------------------------------- - npes = lattice%nx*lattice%ny - allocate ( ntasksg(0:npes-1) ) - if( lattice%myid.ne.0 ) then - call mpi_send ( ntasks,1,mpi_integer,0,lattice%myid,lattice%comm,ierror ) - else - ntasksg(0) = ntasks - do peid = 1,lattice%nx*lattice%ny-1 - call mpi_recv ( ntasksg(peid),1,mpi_logical,peid,peid,lattice%comm,status,ierror ) - enddo - endif - call my_barrier (lattice%comm) - - if( lattice%myid.eq.0 ) then - maxt = ntasksg(0) - do peid = 1,lattice%nx*lattice%ny-1 - if( ntasksg(peid).gt.maxt ) maxt = ntasksg(peid) - enddo - allocate ( tasksg(maxt,0:npes-1) ) - allocate ( cputotg(maxt,0:npes-1) ) - endif - call my_barrier (lattice%comm) - - if( lattice%myid.ne.0 ) then - call mpi_send ( tasks,ntasks*10,mpi_character,0,lattice%myid,lattice%comm,ierror ) - else - tasksg(1:ntasks,0) = tasks(1:ntasks) - do peid = 1,lattice%nx*lattice%ny-1 - call mpi_recv ( tasksg(1,peid),ntasksg(peid)*10,mpi_character,peid,peid,lattice%comm,status,ierror ) - enddo - endif - call my_barrier (lattice%comm) - - if( lattice%myid.ne.0 ) then - call mpi_send ( cputot,ntasks,mpi_rkind,0,lattice%myid,lattice%comm,ierror ) - else - cputotg(1:ntasks,0) = cputot(1:ntasks) - do peid = 1,lattice%nx*lattice%ny-1 - call mpi_recv ( cputotg(1,peid),ntasksg(peid),mpi_rkind,peid,peid,lattice%comm,status,ierror ) - enddo - endif - call my_barrier (lattice%comm) - - if( lattice%myid.eq.0 ) then - allocate ( dum0(0:lattice%nx-1) ) - allocate ( dum1(0:lattice%nx-1) ) - do n=1,ntasks - print *, tasks(n) - do j=lattice%ny-1,0,-1 - do i=0,lattice%nx-1 - dum1(i) = 0 - peid = i+j*lattice%nx - do k=1,ntasksg(peid) - if( tasksg(k,peid).eq.tasks(n) ) dum1(i) = cputotg(k,peid) - enddo - enddo - if( n.eq.1 ) dum0(:) = dum1(:) - write(6,1001) ( int(dum1(i)),int(dum1(i)/dum0(i)*100),i=0,lattice%nx-1 ) - enddo - enddo - deallocate ( dum0 ) - deallocate ( dum1 ) - endif - call my_barrier (lattice%comm) - - deallocate ( ntasksg ) - 1001 format(1x,20(i5,1x,'(',i3,')',2x)) -#endif - - return - end diff --git a/GEOS_Util/post/ncep_prs2fv.F b/GEOS_Util/post/ncep_prs2fv.F deleted file mode 100644 index 2160eec6..00000000 --- a/GEOS_Util/post/ncep_prs2fv.F +++ /dev/null @@ -1,4777 +0,0 @@ - program main - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to create fv restarts from Pressure Level Data **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm - real pbelow,pabove,ptop,pint - real rgas,eps,rvap - - real dum - integer niter,i0,j0 - parameter ( niter = 5 ) - -! GEOS Restart Variables -! ---------------------- - real*4, allocatable :: dum4(:,:) - real*8, allocatable :: dum8(:,:) - real*8, allocatable :: ak(:) - real*8, allocatable :: bk(:) - - integer headr1(6) - integer headr2(5) - - real, allocatable :: phis(:,:) - -c Set analysis, fvdas, date and time -c ---------------------------------- - character*2 clm,cnhms - character*8 cnymd - - character*256 dynrst, mstrst, prsdata, topog, tag, ext - character*256 dynrst2, mstrst2 - - real :: phibg, phifg, thbr1, thbr2, delth, cp - real :: kappa = 2.0/7.0 - real :: grav = 9.80 - - integer nymd,nhms - integer Lbeg,Lend - -c fv restart variables and topography -c ----------------------------------- - real, allocatable :: ps(:,:) - real, allocatable :: dp(:,:,:) - real, allocatable :: pl(:,:,:) - real, allocatable :: ple(:,:,:) - real, allocatable :: er(:,:,:) - real, allocatable :: u(:,:,:), ud(:,:,:) - real, allocatable :: v(:,:,:), vd(:,:,:) - real, allocatable :: tv(:,:,:) - real, allocatable :: th(:,:,:) - real, allocatable :: thv(:,:,:) - real, allocatable :: pke(:,:,:) - real, allocatable :: pk (:,:,:) - real, allocatable :: q(:,:,:) - - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - integer timinc - real undef - -c Analysis variables -c ------------------ - real, allocatable :: phis_ana(:,:) - real, allocatable :: slp_ana(:,:) - real, allocatable :: ps_ana(:,:) - real, allocatable :: u_ana(:,:,:) - real, allocatable :: v_ana(:,:,:) - real, allocatable :: z_ana(:,:,:) - real, allocatable :: er_ana(:,:,:) - real, allocatable :: q_ana(:,:,:) - real, allocatable :: rh_ana(:,:,:) - real, allocatable :: p_ana(:,:,:) - real, allocatable :: dp_ana(:,:,:) - real, allocatable :: pl_ana(:,:,:) - real, allocatable :: t_ana(:,:,:) - real, allocatable :: t_ec(:,:,:) - real, allocatable :: h_ana(:,:,:) - real, allocatable :: ple_ana(:,:,:) - real, allocatable :: logp (:,:,:) - real, allocatable :: logpl(:,:,:) - real, allocatable :: qdum (:,:,:) - integer id,rc - integer ks - integer imax,jmax - integer nvars, ngatts, ntime - - character*120, allocatable :: arg(:) - character*120 eta_fname - character*120 rs_fname - - logical :: agrid = .false. - logical :: dgrid = .false. - logical :: u_agrid = .false. - logical :: v_agrid = .false. - logical :: u_dgrid = .false. - logical :: v_dgrid = .false. - logical :: tvflag = .false. - logical :: thvflag = .false. - logical :: lwiflag = .false. - - logical recon - logical ihavetv,agridw - integer precision - integer i,j,k,L,n,nargs - -c Analysis Grads CTL File Variables -c --------------------------------- - character*256 ctlfile,format - integer imana,jmana,lmana - - character*256, pointer :: names (:) - character*256, pointer :: descs (:) - integer, pointer :: lmvars(:) - real, pointer :: levs(:) - real, pointer :: plevs(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - -C ********************************************************************** -C **** Initialize Filenames, Methods, etc. **** -C ********************************************************************** - - i0 = 0 - j0 = 0 - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - recon = .true. - - pabove = 10.00 ! 10 mb - pbelow = 30.00 ! 30 mb - precision = 0 ! 32-bit - ctlfile = 'xxx' - nymd = -999 - nhms = -999 - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-dyn' ) dynrst = trim(arg(n+1)) - if( trim(arg(n)).eq.'-moist' ) mstrst = trim(arg(n+1)) - if( trim(arg(n)).eq.'-ncep' ) prsdata = trim(arg(n+1)) - if( trim(arg(n)).eq.'-topo' ) topog = trim(arg(n+1)) - if( trim(arg(n)).eq.'-tag' ) tag = trim(arg(n+1)) - if( trim(arg(n)).eq.'-plow ' ) read(arg(n+1), * ) pbelow - if( trim(arg(n)).eq.'-phigh' ) read(arg(n+1), * ) pabove - if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1), * ) nymd - if( trim(arg(n)).eq.'-nhms' ) read(arg(n+1), * ) nhms - if( trim(arg(n)).eq.'-i0' ) read(arg(n+1), * ) i0 - if( trim(arg(n)).eq.'-j0' ) read(arg(n+1), * ) j0 - if( trim(arg(n)).eq.'-recon' ) read(arg(n+1), * ) recon - enddo - if( pbelow.lt.pabove ) then - dum = pbelow - pbelow = pabove - pabove = dum - endif - endif - pabove = pabove*100 - pbelow = pbelow*100 - - if( trim(tag).ne.'' ) tag = trim(tag) // '.' - ext = 'nc4' - -! ********************************************************************** -! **** Read dycore internal Restart **** -! ********************************************************************** - - open (10,file=trim(dynrst),form='unformatted',access='sequential') - read (10) headr1 - read (10) headr2 - - if( nymd.eq.-999 ) nymd = headr1(1)*10000 + headr1(2)*100 + headr1(3) - if( nhms.eq.-999 ) nhms = headr1(4)*10000 + headr1(5)*100 + headr1(6) - - im = headr2(1) - jm = headr2(2) - lm = headr2(3) - - allocate ( dum8(im,jm) ) - allocate ( u(im,jm,lm) ) - allocate ( ud(im,jm,lm) ) - allocate ( v(im,jm,lm) ) - allocate ( vd(im,jm,lm) ) - allocate ( th(im,jm,lm) ) - allocate ( thv(im,jm,lm) ) - allocate ( dp(im,jm,lm) ) - allocate ( pk(im,jm,lm) ) - allocate ( ple(im,jm,lm+1) ) - allocate ( pke(im,jm,lm+1) ) - allocate ( ps(im,jm) ) - allocate ( ak(lm+1) ) - allocate ( bk(lm+1) ) - - read (10) ak - read (10) bk - - do L=1,lm - read(10) dum8 ; ud(:,:,L) = dum8 - enddo - do L=1,lm - read(10) dum8 ; vd(:,:,L) = dum8 - enddo - do L=1,lm - read(10) dum8 ; th(:,:,L) = dum8 ! Note: GEOS-5 variable is DRY potential temperature - enddo - do L=1,lm+1 - read(10) dum8 ; ple(:,:,L) = dum8 - enddo - do L=1,lm - read(10) dum8 ; pk(:,:,L) = dum8 - enddo - - close (10) - - call dtoa_winds ( ud,vd,u,v,im,jm,lm ) - -! Construct Pressure Variables -! ---------------------------- - - ps(:,:) = ple(:,:,lm+1) - do L=lm,1,-1 - dp(:,:,L) = ple(:,:,L+1)-ple(:,:,L) - pl(:,:,L) = (ple(:,:,L+1)+ple(:,:,L))*0.5 - enddo - -c call set_eta ( lm,ks,ptop,pint,ak,bk ) -c do L=1,lm+1 -c ple(:,:,L) = ak(L) + ps(:,:)*bk(L) -c enddo -c do L=1,lm -c pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) -c . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) -c enddo - -! ********************************************************************** -! **** Read moist internal Restart **** -! ********************************************************************** - - allocate ( q(im,jm,lm) ) - allocate ( dum4(im,jm) ) - - open (10,file=trim(mstrst),form='unformatted',access='sequential') - do L=1,lm - read(10) dum4 - q(:,:,L) = dum4(:,:) ! First moist variable is SPHU - enddo - close (10) - -! Construct THV for REMAPPING -! --------------------------- - thv = th*(1+eps*q) - -! ********************************************************************** -! **** Read Topography Dataset **** -! ********************************************************************** - - allocate ( phis(im,jm) ) - - print *, 'Reading Topography Dataset: ',trim(topog) - open (10,file=trim(topog),form='unformatted',access='sequential') - read (10) phis - close(10) - - phis = phis*grav -#ifdef DEBUG - call writit ( phis,im,jm,1,65 ) -#endif - -C ********************************************************************** -C **** Read ANA MetaData **** -C ********************************************************************** - - call gfio_open ( trim(prsdata),1,id,rc ) - call gfio_diminquire ( id,imana,jmana,lmana,ntime,nvars,ngatts,rc ) - - allocate ( lon(imana) ) - allocate ( lat(jmana) ) - allocate ( lev(lmana) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,imana,jmana,lmana,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,rc ) - - allocate ( plevs(lmana) ) - do L=1,lmana - plevs(L) = lev(lmana-L+1) - enddo - - print * - print *, ' GEOS Resolution: ',im,jm,lm - print *, ' nymd: ',nymd - print *, ' nhms: ',nhms - print * - print *, ' ANA File: ',trim(prsdata) - print *, ' rslv: ',imana,jmana,lmana - print *, ' lon(1): ',lon(1)*180.0/3.14159 - print *, ' Reconcile Heights: ',recon - print * - print *, ' Number of Variables: ',nvars - print * - do n=1,nvars - write(6,1001) n,trim(vname(n)),trim(vtitle(n)),kmvar(n) - enddo - 1001 format(1x,i2,3x,a16,2x,a32,2x,i3) - print * - L = 1 - print *, ' Pressure Levels: ',L,plevs(L) - do L=2,lmana - print *, ' ',L,plevs(L) - enddo - print * - print *, ' Blending between: ',pbelow/100,' and ',pabove/100,' mb' - print * - - write( cnymd,200 ) nymd - write( cnhms,300 ) nhms/10000 - 200 format(i8.8) - 300 format(i2.2) - 400 format('dset ^',a) - 600 format(a1,i2.2) - -C ********************************************************************** -C **** Get Analysis **** -C ********************************************************************** - - allocate ( p_ana(im,jm,lmana) ) - allocate ( er_ana(im,jm,lmana) ) - allocate ( z_ana(im,jm,lmana) ) - allocate ( u_ana(im,jm,lmana) ) - allocate ( v_ana(im,jm,lmana) ) - allocate ( t_ana(im,jm,lmana) ) - allocate ( t_ec (im,jm,lmana) ) - allocate ( h_ana(im,jm,lmana) ) - allocate ( q_ana(im,jm,lmana) ) - allocate ( ps_ana(im,jm) ) - allocate (phis_ana(im,jm) ) - - print *, 'Reading Analysis for Date: ',nymd,' Time: ',nhms - print * - - call get_ana_data ( id,ps_ana,u_ana,v_ana,t_ana,q_ana,h_ana,phis_ana, - . im,jm,lmana,nymd,nhms,lon(1), - . imana,jmana,lmana,nvars,names,lmvars,undef,plevs ) - t_ec = t_ana - - allocate( dp_ana(im,jm,lm) ) - allocate( pl_ana(im,jm,lm) ) - allocate( ple_ana(im,jm,lm+1) ) - allocate( logp (im,jm,lm) ) - allocate( logpl(im,jm,lm) ) - do L=1,lm+1 - ple_ana(:,:,L) = ak(L) + ps_ana(:,:)*bk(L) - enddo - do L=1,lm - dp_ana(:,:,L) = ple_ana(:,:,L+1)-ple_ana(:,:,L) - pl_ana(:,:,L) = 0.5*(ple_ana(:,:,L+1)+ple_ana(:,:,L)) - logp(:,:,L) = log( 0.5*(ple_ana(:,:,L+1)+ple_ana(:,:,L)) ) - enddo - - if( i0.ne.0 .and. j0.ne.0 ) then - print *, 'Sample ANA Data at GEOS-5 Location: (',i0,',',j0,')' - print *, ' ANA_PS: ',ps_ana(i0,j0)/100,' ANA_PHIS: ',phis_ana(i0,j0) - print *, ' ANA_UNDEF: ',undef - print *, ' ANA Temperature and Wind Profile:' - else - print *, 'Sample ANA Data:' - print *, ' ANA_PS: ',ps_ana(1,jm/2)/100,' ANA_PHIS: ',phis_ana(1,jm/2) - print *, ' ANA_UNDEF: ',undef - print *, ' ANA_Temperature and Wind Profile:' - endif - do L=1,lmana - p_ana(:,:,L) = 100.0*plevs(L) - logpl(:,:,L) = log( 100.0*plevs(L) ) - if( i0.ne.0 .and. j0.ne.0 ) then - print *, L,plevs(L),t_ana(i0,j0,L),u_ana(i0,j0,L) - else - print *, L,plevs(L),t_ana(1,jm/2,L),u_ana(1,jm/2,L) - endif - enddo - print * - - allocate ( qdum(im,jm,lm) ) - - call interp ( qdum,u_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'UWND',niter,i0,j0,1 ) - deallocate ( u_ana ) - allocate ( u_ana(im,jm,lm) ) - u_ana = qdum - - call interp ( qdum,v_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'VWND',niter,i0,j0,1 ) - deallocate ( v_ana ) - allocate ( v_ana(im,jm,lm) ) - v_ana = qdum - - call interp ( qdum,t_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'TMPU',niter,i0,j0,1 ) - deallocate ( t_ana ) - allocate ( t_ana(im,jm,lm) ) - t_ana = qdum - - call interp ( qdum,q_ana,logp,logpl,p_ana,pl_ana,ple_ana,im,jm,lm,lmana,undef,'SPHU',niter,i0,j0,-1 ) - deallocate ( q_ana ) - allocate ( q_ana(im,jm,lm) ) - q_ana = qdum - -C ********************************************************************** -C **** Remap for Analysis **** -C ********************************************************************** - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'Before REMAP: ' - print *, 'GEOS5 PHIS/grav: ',phis(i0,j0)/grav,' ps: ',ps(i0,j0)/100 - print *, 'ANA PHIS/grav: ',phis_ana(i0,j0)/grav,' ps: ',ps_ana(i0,j0)/100 - print * - endif - - print *, 'Calling Remap' - call remap ( ps,dp,u,v,thv,q,phis,lm, - . ps_ana,dp_ana,u_ana,v_ana,t_ana,q_ana,phis_ana,lm,im,jm,1,pbelow,pabove ) - print *, ' Fini Remap' - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'AFter REMAP: ' - print *, 'GEOS5 PHIS/grav: ',phis(i0,j0)/grav,' ps: ',ps(i0,j0)/100 - print *, 'ANA PHIS/grav: ',phis_ana(i0,j0)/grav,' ps: ',ps_ana(i0,j0)/100 - print * - endif - -C ********************************************************************** -C **** Reconcile Heights **** -C ********************************************************************** - - cp = MAPL_CP - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - pke(:,:,:) = ple(:,:,:)**kappa - do L=1,lm - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - - if( recon ) then - do j=1,jm - do i=1,im - - Lbeg = lm - phifg = phis(i,j) - phibg = phifg - - do k=lmana,1,-1 - if( i.eq.i0 .and. j.eq.j0 ) then - write(6,5001) k,p_ana(i,j,k)/100,h_ana(i,j,k),t_ec(i,j,k) - 5001 format(1x,'k: ',i3,3x,'ANA_PMAN: ',f8.3,3x,'ANA_HGHT: ',f9.3,3x,'ANA_TMPU: ',f7.3) - endif - - if( p_ana(i,j,k).lt.ps(i,j) .and. ! p_ana is above GEOS Surface Pressure - . h_ana(i,j,k)-phibg/grav.gt.10.0 .and. ! h_ana is at least 10-meters above previous level - . h_ana(i,j,k)-phis_ana(i,j)/grav.gt.10.0 .and. ! h_ana is at least 10-meters above Topography - . p_ana(i,j,k).gt.pabove ) then ! p_ana is below Blending Region - if( i.eq.i0 .and. j.eq.j0 ) print * - - do L=Lbeg,1,-1 - if( ple(i,j,L).gt.p_ana(i,j,k) ) then - phifg = phifg + cp*thv(i,j,L)*( pke(i,j,L+1)-pke(i,j,L) ) - if( i.eq.i0 .and. j.eq.j0 ) then - write(6,5002) L,ple(i,j,L)/100,phifg/grav,thv(i,j,L)*pk(i,j,L) - 5002 format(1x,'L: ',i3,3x,' G5_PLE: ',f8.3,3x,'G5_HGHT: ',f9.3,3x,'G5_TMPU: ',f7.3) - endif - else - exit - endif - enddo - Lend = L - if( Lbeg-Lend.le.2 ) then - phifg = phibg - cycle - endif - - phifg = phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-p_ana(i,j,k)**kappa ) - - if( i.eq.i0 .and. j.eq.j0 ) then - print * - print *, ' Lbeg: ',Lbeg,' Lend: ',Lend,' ple(Lend): ',ple(i,j,Lend)/100 - print *, 'ANA_HGHT: ',h_ana(i,j,k),' G5_HGHT: ',phifg/grav,' G5_HGHT0: ',phibg/grav - print *, 'ANA_TMPU: ',t_ec (i,j,k),' G5_TMPU: ',thv(i,j,Lend)*pk(i,j,LEND) - endif - - thbr1 = ( grav*h_ana(i,j,k)-phibg )/( pke(i,j,Lbeg+1)-p_ana(i,j,k)**kappa )/cp - thbr2 = ( phifg -phibg )/( pke(i,j,Lbeg+1)-p_ana(i,j,k)**kappa )/cp - delth = thbr1-thbr2 - - if( i.eq.i0 .and. j.eq.j0 ) then - print *, 'ANA_THETA_BR: ',thbr1,' G5_THETA_BR: ',thbr2 - print *, ' ANA_T_TOP: ',thbr1*p_ana(i,j,k)**kappa,' G5_T_TOP: ',thbr2*p_ana(i,j,k)**kappa - print *, ' ANA_T_BOT: ',thbr1*pke(i,j,Lbeg+1),' G5_T_BOT: ',thbr2*pke(i,j,Lbeg+1) - endif - - do L=Lbeg,Lend,-1 - thv(i,j,L) = thv(i,j,L) + delth - enddo - - phifg = phibg - do L=Lbeg,Lend+1,-1 - phifg = phifg + cp*thv(i,j,L)*( pke(i,j,L+1)-pke(i,j,L) ) - enddo - - if( i.eq.i0 .and. j.eq.j0 ) print *, 'ANA_HGHT: ',h_ana(i,j,k),' G5_HGHT: ', - . (phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-p_ana(i,j,k)**kappa ))/grav - - phifg = phifg + cp*thv(i,j,Lend)*( pke(i,j,Lend+1)-pke(i,j,Lend) ) - Lbeg = Lend-1 - phibg = phifg - endif - enddo - - enddo - enddo - endif - -! ********************************************************************** -! **** Write dycore internal Restart **** -! ********************************************************************** - - call atod_winds ( u,v,ud,vd,im,jm,lm ) - - th = thv/(1+eps*q) - - dynrst2 = trim(dynrst) // '.ncep' - print * - print *, 'Creating GEOS-5 fvcore_internal_restart' - - open (20,file=trim(dynrst2),form='unformatted',access='sequential') - write(20) headr1 - write(20) headr2 - write(20) ak - write(20) bk - do L=1,lm - dum8(:,:) = ud(:,:,L) - write(20) dum8 - enddo - do L=1,lm - dum8(:,:) = vd(:,:,L) - write(20) dum8 - enddo - do L=1,lm - dum8(:,:) = th(:,:,L) - write(20) dum8 - enddo - do L=1,lm+1 - dum8(:,:) = ple(:,:,L) - write(20) dum8 - enddo - do L=1,lm - dum8(:,:) = pk(:,:,L) - write(20) dum8 - enddo - close (20) - -! ********************************************************************** -! **** Write Moist Internal Restart **** -! ********************************************************************** - - mstrst2 = trim(mstrst) // '.ncep' - - open (10,file=trim(mstrst) ,form='unformatted',access='sequential') - open (20,file=trim(mstrst2),form='unformatted',access='sequential') - - print *, 'Creating GEOS-5 moist_internal_restart' - do L=1,lm - read(10) dum4 - dum4 = q(:,:,L) ! First moist variable is SPHU - write(20) dum4 - enddo - - rc = 0 - dowhile (rc.eq.0) - read (10,iostat=rc) dum4 - if( rc.eq.0 ) write(20) dum4 - enddo - - stop - end - - subroutine interp ( q,qana,logp,logpl,pana,pl,ple,im,jm,lm,lmana,undef,name,niter,i0,j0,flag ) - implicit none - integer im,jm,lm,lmana,niter,i0,j0,flag - real undef - real q (im,jm,lm) - real pl (im,jm,lm) - real ple (im,jm,lm+1) - real er (im,jm,lm) - real logp (im,jm,lm) - real pana (im,jm,lmana) - real qana (im,jm,lmana) - real zana (im,jm,lmana) - real erana(im,jm,lmana) - real logpl(im,jm,lmana) - character*8 name - - integer i,j,L,n - -c Interpolate Analysis to GEOS Model Levels -c ----------------------------------------- - do L=1,lm - do j=1,jm - do i=1,im - call sigtopl( q(i,j,L),qana(i,j,:),logpl(i,j,:),logp(i,j,L),1,1,lmana,undef ) - enddo - enddo - enddo - if( flag.eq.-1 ) then - q = max( q,0.0 ) - endif - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'Initial ANA ',trim(name),' Profile at GEOS-5 Levels:' - do L=1,lm - print *, L,exp(logp(i0,j0,L))/100.,q(i0,j0,L) - enddo - print * - else - print *, 'Interpolating ',trim(name),' ...' - endif - -#ifdef DEBUG - call writit (q,im,jm,lm,66) -#endif - do n=1,niter -c Interpolate GEOS Model Back to EC Levels and Compute Error -c ---------------------------------------------------------- - do L=1,lmana - do j=1,jm - do i=1,im - call sigtopl( zana(i,j,L),q(i,j,:),logp(i,j,:),logpl(i,j,L),1,1,lm,undef ) - erana(i,j,L) = zana(i,j,L)-qana(i,j,L) - enddo - enddo - enddo - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'ANA ',trim(name),' Profile Comparison, ITER: ',n - print *, '----------------------------------------------' - do L=1,lmana - print *, L,exp(logpl(i0,j0,L))/100.,zana(i0,j0,L),qana(i0,j0,L),erana(i0,j0,L) - enddo - print * - endif - -c Interpolate and Add Error to GEOS Model Levels -c ---------------------------------------------- - call interp3 ( erana,pana,im,jm,lmana, er,pl,lm,ple(1,1,lm+1) ) - q = q - er - if( flag.eq.-1 ) then - q = max( q,0.0 ) - endif -#ifdef DEBUG - call writit (q,im,jm,lm,66) -#endif - enddo - - if( i0.ne.0 .and. j0.ne.0 ) then - print * - print *, 'Final ANA ',trim(name),' Profile at GEOS-5 Levels:' - do L=1,lm - print *, L,exp(logp(i0,j0,L))/100.,q(i0,j0,L) - enddo - print * - endif - - return - end - - subroutine get_ana_data ( id,ps,u,v,t,q,h,phis, - . im,jm,lm,nymd,nhms,lonbeg, - . imana,jmana,lmana,nvars,names,lmvars,undef,plevs ) - use MAPL_ConstantsMod - implicit none - integer id,im,jm,lm,nymd,nhms,rc - integer imana,jmana,lmana - integer nvars - integer lmvars(nvars) - character*256 names(nvars) - character*256 filename, format - - real lonbeg - real ps(im,jm) - real u(im,jm,lm) - real v(im,jm,lm) - real t(im,jm,lm) - real h(im,jm,lm) - real rh(im,jm,lm) - real q(im,jm,lm) - real phis(im,jm) - real plevs(lm) - real phis2(im,jm) - real slp(im,jm) - real thv(im,jm) - - real, allocatable :: vor (:,:) - real, allocatable :: div (:,:) - real, allocatable :: chi (:,:) - real, allocatable :: psi (:,:) - real, allocatable :: dchidx(:,:) - real, allocatable :: dchidy(:,:) - real, allocatable :: dpsidx(:,:) - real, allocatable :: dpsidy(:,:) - - real, allocatable :: dum2d(:,:) - real, allocatable :: dum3d(:,:,:) - real, allocatable :: dumu (:,:,:) - real, allocatable :: dumv (:,:,:) - - real undef,kappa,grav,dum,beta,cp,rgas,gamma,dp - integer L,i,j,n,LM1 - - allocate ( vor (imana,jmana) ) - allocate ( div (imana,jmana) ) - allocate ( chi (imana,jmana) ) - allocate ( psi (imana,jmana) ) - allocate ( dchidx(imana,jmana) ) - allocate ( dchidy(imana,jmana) ) - allocate ( dpsidx(imana,jmana) ) - allocate ( dpsidy(imana,jmana) ) - - allocate ( dum2d(imana,jmana) ) - allocate ( dum3d(imana,jmana,lmana) ) - allocate ( dumu (imana,jmana,lmana) ) - allocate ( dumv (imana,jmana,lmana) ) - - rgas = MAPL_RGAS - kappa = MAPL_KAPPA - grav = MAPL_GRAV - cp = MAPL_CP - beta = 6.5e-3 - -c Read ANA Variables -c ------------------ - call gfio_getvar ( id,'slp',nymd,nhms,imana,jmana,0,1 ,dum2d,rc ) - if( lonbeg.eq.0.0 ) call hflip( dum2d,imana,jmana,1 ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum2d,imana,jmana,slp,im,jm,1,undef ) - else - slp = dum2d - endif - - call gfio_getvar ( id,'ps',nymd,nhms,imana,jmana,0,1 ,dum2d ,rc ) - if( rc.ne.0 ) then - print *, 'Could not find NCEP Surface Pressure variable' - error stop 7 - endif - if( lonbeg.eq.0.0 ) call hflip( dum2d,imana,jmana,1 ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum2d,imana,jmana,ps,im,jm,1,undef ) - else - ps = dum2d - endif - - call gfio_getvar ( id,'hght',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find NCEP Height variable' - error stop 7 - endif - if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,h,im,jm,lm,undef ) - else - h = dum3d - endif - -c Winds -c ----- - call gfio_getvar ( id,'uwnd',nymd,nhms,imana,jmana,1,lmana,dumu,rc ) - if( rc.ne.0 ) then - print *, 'Could not find NCEP U-Wind variable' - error stop 7 - endif - call gfio_getvar ( id,'vwnd',nymd,nhms,imana,jmana,1,lmana,dumv,rc ) - if( rc.ne.0 ) then - print *, 'Could not find NCEP V-Wind variable' - error stop 7 - endif - -#if 0 - do L=1,lmana - call getvordiv( dumu(1,1,L),dumv(1,1,L),vor,div,imana,jmana ) - call laplacian( vor,psi,imana,jmana ) - call laplacian( div,chi,imana,jmana ) - call gradq ( chi,dchidx,dchidy,imana,jmana ) - call gradq ( psi,dpsidx,dpsidy,imana,jmana ) - dumu(:,:,L) = dchidx - dpsidy - dumv(:,:,L) = dpsidx + dchidy - enddo -#endif - - if( lonbeg.eq.0.0 ) call hflip( dumu,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dumu,imana,jmana,u,im,jm,lm,undef ) - else - u = dumu - endif - - if( lonbeg.eq.0.0 ) call hflip( dumv,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dumv,imana,jmana,v,im,jm,lm,undef ) - else - v = dumv - endif - -c Temperature -c ----------- - call gfio_getvar ( id,'tmpu',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find NCEP Temperature variable' - error stop 7 - endif - if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,t,im,jm,lm,undef ) - else - t = dum3d - endif - -c Relative Humidity -c ----------------- - call gfio_getvar ( id,'rh',nymd,nhms,imana,jmana,1,lmana,dum3d,rc ) - if( rc.ne.0 ) then - print *, 'Could not find NCEP Rel.Hum. variable' - error stop 7 - endif - if( lonbeg.eq.0.0 ) call hflip( dum3d,imana,jmana,lmana ) - if( im.ne.imana .or. jm.ne.jmana ) then - call hinterp ( dum3d,imana,jmana,rh,im,jm,lm,undef ) - else - rh = dum3d - endif - where( rh.ne.undef ) - rh = min( max( rh,0.0 ),100.0 ) - elsewhere - rh = 20.0 - endwhere - -c do n=1,nvars -c if( lmvars(n).gt.1 .and. mlev.gt.lmana ) then -c do L=1,mlev-lmana -c qdum(:,:,L) = qdum(:,:,mlev-lmana+1) -c enddo -c endif -c enddo - -c Compute PHIS -c ------------ - do j=1,jm - do i=1,im - L=1 - do while( L.lt.lm .and. plevs(L).lt.ps(i,j)/100.0 ) - L=L+1 - enddo - LM1 = L-1 - phis(i,j) = h(i,j,L) - ( h(i,j,L)-h(i,j,LM1) )*log( 100*plevs(L)/ps(i,j) )/log( plevs(L)/plevs(LM1) ) - enddo - enddo - phis = phis*grav -#ifdef DEBUG - call writit ( phis,im,jm,1,65 ) -#endif - - do j=1,jm - do i=1,im - L=lm - do while( L.gt.1 .and. plevs(L).gt.ps(i,j)/100.0 ) - L=L-1 - enddo - dp = ps(i,j)/100.0 - plevs(L) - do while( dp.le.150.0 ) - L=L-1 - dp = ps(i,j)/100.0 - plevs(L) - enddo - L=L+1 - gamma = kappa * (0.01*ps(i,j))**kappa * log( slp(i,j)/ps(i,j) ) - . / ( 1.0 - 0.5*beta*rgas/grav * log( slp(i,j)/ps(i,j) ) ) - phis2(i,j) = grav*h(i,j,L)*gamma / ( gamma - plevs(L)**kappa + (0.01*ps(i,j))**kappa ) - enddo - enddo -#ifdef DEBUG - call writit ( phis2,im,jm,1,65 ) -#endif - - do j=1,jm - do i=1,im - L=lm - do while( L.gt.1 .and. plevs(L).gt.ps(i,j)/100.0 ) - L=L-1 - enddo - gamma = rgas * log( slp(i,j)/ps(i,j) ) - phis2(i,j) = gamma * ( t(i,j,L)+beta*h(i,j,L) ) / ( 1+0.5*beta*gamma/grav ) - enddo - enddo -#ifdef DEBUG - call writit ( phis2,im,jm,1,65 ) -#endif - -c Load GMAO Variables -c ------------------- - do L=1,lm - do j=1,jm - do i=1,im - call qsat (t(i,j,L),plevs(L),q(i,j,L),dum,.false.) - q(i,j,L) = rh(i,j,L)*q(i,j,L)*0.01 - enddo - enddo - enddo - - return - end - - subroutine hflip ( q,im,jm,lm ) - implicit none - integer im,jm,lm,i,j,L - real*4 z(im,jm,lm) - real*4 q(im,jm,lm),dum(im) - do L=1,lm - do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j,L) - dum(i+im/2) = q(i,j,L) - enddo - z(:,j,lm-L+1) = dum(:) - enddo - enddo - q = z - return - end - - subroutine writit (q,im,jm,lm,ku) - real q (im,jm,lm) - real*4 q2(im,jm) - do L=lm,1,-1 - q2(:,:) = q(:,:,L) - write(ku) q2 - enddo - return - end - - subroutine qsat (tt,p,q,dqdt,ldqdt) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute Saturation Specific Humidity -C -C INPUT: -C ====== -C TT ......... Temperature (Kelvin) -C P .......... Pressure (mb) -C LDQDT ...... Logical Flag to compute QSAT Derivative -C -C OUTPUT: -C ======= -C Q .......... Saturation Specific Humidity -C DQDT ....... Saturation Specific Humidity Derivative wrt Temperature -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IMPLICIT NONE - REAL TT, P, Q, DQDT - LOGICAL LDQDT - REAL AIRMW, H2OMW - - PARAMETER ( AIRMW = 28.97 ) - PARAMETER ( H2OMW = 18.01 ) - - REAL ESFAC, ERFAC - PARAMETER ( ESFAC = H2OMW/AIRMW ) - PARAMETER ( ERFAC = (1.0-ESFAC)/ESFAC ) - - real aw0, aw1, aw2, aw3, aw4, aw5, aw6 - real bw0, bw1, bw2, bw3, bw4, bw5, bw6 - real ai0, ai1, ai2, ai3, ai4, ai5, ai6 - real bi0, bi1, bi2, bi3, bi4, bi5, bi6 - - real d0, d1, d2, d3, d4, d5, d6 - real e0, e1, e2, e3, e4, e5, e6 - real f0, f1, f2, f3, f4, f5, f6 - real g0, g1, g2, g3, g4, g5, g6 - -c ******************************************************** -c *** Polynomial Coefficients WRT Water (Lowe, 1977) **** -c *** (Valid +50 C to -50 C) **** -c ******************************************************** - - parameter ( aw0 = 6.107799961e+00 * esfac ) - parameter ( aw1 = 4.436518521e-01 * esfac ) - parameter ( aw2 = 1.428945805e-02 * esfac ) - parameter ( aw3 = 2.650648471e-04 * esfac ) - parameter ( aw4 = 3.031240396e-06 * esfac ) - parameter ( aw5 = 2.034080948e-08 * esfac ) - parameter ( aw6 = 6.136820929e-11 * esfac ) - - parameter ( bw0 = +4.438099984e-01 * esfac ) - parameter ( bw1 = +2.857002636e-02 * esfac ) - parameter ( bw2 = +7.938054040e-04 * esfac ) - parameter ( bw3 = +1.215215065e-05 * esfac ) - parameter ( bw4 = +1.036561403e-07 * esfac ) - parameter ( bw5 = +3.532421810e-10 * esfac ) - parameter ( bw6 = -7.090244804e-13 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice (Lowe, 1977) **** -c *** (Valid +0 C to -50 C) **** -c ******************************************************** - - parameter ( ai0 = +6.109177956e+00 * esfac ) - parameter ( ai1 = +5.034698970e-01 * esfac ) - parameter ( ai2 = +1.886013408e-02 * esfac ) - parameter ( ai3 = +4.176223716e-04 * esfac ) - parameter ( ai4 = +5.824720280e-06 * esfac ) - parameter ( ai5 = +4.838803174e-08 * esfac ) - parameter ( ai6 = +1.838826904e-10 * esfac ) - - parameter ( bi0 = +5.030305237e-01 * esfac ) - parameter ( bi1 = +3.773255020e-02 * esfac ) - parameter ( bi2 = +1.267995369e-03 * esfac ) - parameter ( bi3 = +2.477563108e-05 * esfac ) - parameter ( bi4 = +3.005693132e-07 * esfac ) - parameter ( bi5 = +2.158542548e-09 * esfac ) - parameter ( bi6 = +7.131097725e-12 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -40 C to -70 C) **** -c ******************************************************** - - - parameter ( d0 = 0.535098336e+01 * esfac ) - parameter ( d1 = 0.401390832e+00 * esfac ) - parameter ( d2 = 0.129690326e-01 * esfac ) - parameter ( d3 = 0.230325039e-03 * esfac ) - parameter ( d4 = 0.236279781e-05 * esfac ) - parameter ( d5 = 0.132243858e-07 * esfac ) - parameter ( d6 = 0.314296723e-10 * esfac ) - - parameter ( e0 = 0.469290530e+00 * esfac ) - parameter ( e1 = 0.333092511e-01 * esfac ) - parameter ( e2 = 0.102164528e-02 * esfac ) - parameter ( e3 = 0.172979242e-04 * esfac ) - parameter ( e4 = 0.170017544e-06 * esfac ) - parameter ( e5 = 0.916466531e-09 * esfac ) - parameter ( e6 = 0.210844486e-11 * esfac ) - - -c ******************************************************** -c *** Polynomial Coefficients WRT Ice **** -c *** Starr and Cox (1985) (Valid -65 C to -95 C) **** -c ******************************************************** - - parameter ( f0 = 0.298152339e+01 * esfac ) - parameter ( f1 = 0.191372282e+00 * esfac ) - parameter ( f2 = 0.517609116e-02 * esfac ) - parameter ( f3 = 0.754129933e-04 * esfac ) - parameter ( f4 = 0.623439266e-06 * esfac ) - parameter ( f5 = 0.276961083e-08 * esfac ) - parameter ( f6 = 0.516000335e-11 * esfac ) - - parameter ( g0 = 0.312654072e+00 * esfac ) - parameter ( g1 = 0.195789002e-01 * esfac ) - parameter ( g2 = 0.517837908e-03 * esfac ) - parameter ( g3 = 0.739410547e-05 * esfac ) - parameter ( g4 = 0.600331350e-07 * esfac ) - parameter ( g5 = 0.262430726e-09 * esfac ) - parameter ( g6 = 0.481960676e-12 * esfac ) - - REAL TMAX, TICE - PARAMETER ( TMAX=323.15, TICE=273.16) - - REAL T, D, W, QX, DQX - T = MIN(TT,TMAX) - TICE - DQX = 0. - QX = 0. - -c Fitting for temperatures above 0 degrees centigrade -c --------------------------------------------------- - if(t.gt.0.) then - qx = aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6))))) - if (ldqdt) then - dqx = bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6))))) - endif - endif - -c Fitting for temperatures between 0 and -40 -c ------------------------------------------ - if( t.le.0. .and. t.gt.-40.0 ) then - w = (40.0 + t)/40.0 - qx = w *(aw0+T*(aw1+T*(aw2+T*(aw3+T*(aw4+T*(aw5+T*aw6)))))) - . + (1.-w)*(ai0+T*(ai1+T*(ai2+T*(ai3+T*(ai4+T*(ai5+T*ai6)))))) - if (ldqdt) then - dqx = w *(bw0+T*(bw1+T*(bw2+T*(bw3+T*(bw4+T*(bw5+T*bw6)))))) - . + (1.-w)*(bi0+T*(bi1+T*(bi2+T*(bi3+T*(bi4+T*(bi5+T*bi6)))))) - endif - endif - -c Fitting for temperatures between -40 and -70 -c -------------------------------------------- - if( t.le.-40.0 .and. t.ge.-70.0 ) then - qx = d0+T*(d1+T*(d2+T*(d3+T*(d4+T*(d5+T*d6))))) - if (ldqdt) then - dqx = e0+T*(e1+T*(e2+T*(e3+T*(e4+T*(e5+T*e6))))) - endif - endif - -c Fitting for temperatures less than -70 -c -------------------------------------- - if(t.lt.-70.0) then - qx = f0+t*(f1+t*(f2+t*(f3+t*(f4+t*(f5+t*f6))))) - if (ldqdt) then - dqx = g0+t*(g1+t*(g2+t*(g3+t*(g4+t*(g5+t*g6))))) - endif - endif - -c Compute Saturation Specific Humidity -c ------------------------------------ - D = (P-ERFAC*QX) - IF(D.LT.0.) THEN - Q = 1.0 - IF (LDQDT) DQDT = 0. - ELSE - D = 1.0 / D - Q = MIN(QX * D,1.0) - IF (LDQDT) DQDT = (1.0 + ERFAC*Q) * D * DQX - ENDIF - RETURN - END - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*abs(undef) - return - end - - subroutine getchar (name,num) - character*2 num2 - character*3 num3 - integer num - character*1 junk(256) - character*1 name(256) - data junk /256*' '/ - equivalence ( num2,junk ) - equivalence ( num3,junk ) - - num2 = ' ' - num3 = ' ' - - if( num.lt.100 ) then - write(num2,102) num - else if( num.lt.1000 ) then - write(num3,103) num - endif - - name = junk - - 102 format(i2.2) - 103 format(i3.3) - - return - end - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end - - function nsecf2 (nhhmmss,nmmdd,nymd) -C*********************************************************************** -C Purpose -C Computes the Total Number of seconds from NYMD using NHHMMSS & NMMDD -C -C Arguments Description -C NHHMMSS IntervaL Frequency (HHMMSS) -C NMMDD Interval Frequency (MMDD) -C NYMD Current Date (YYMMDD) -C -C NOTE: -C IF (NMMDD.ne.0), THEN HOUR FREQUENCY HH MUST BE < 24 -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - PARAMETER ( NSDAY = 86400 ) - PARAMETER ( NCYCLE = 1461*24*3600 ) - - INTEGER YEAR, DAY, SEC, YEAR0, DAY0, SEC0 - - DIMENSION MNDY(12,4) - DATA MNDY /0,31,60,91,121,152,182,213,244,274,305,335,366, - . 397,34*0 / - -C*********************************************************************** -C* COMPUTE # OF SECONDS FROM NHHMMSS * -C*********************************************************************** - - nsecf2 = nsecf( nhhmmss ) - - if( nmmdd.eq.0 ) return - -C*********************************************************************** -C* COMPUTE # OF DAYS IN A 4-YEAR CYCLE * -C*********************************************************************** - - DO 100 I=15,48 - MNDY(I,1) = MNDY(I-12,1) + 365 -100 CONTINUE - -C*********************************************************************** -C* COMPUTE # OF SECONDS FROM NMMDD * -C*********************************************************************** - - nsegm = nmmdd/100 - nsegd = mod(nmmdd,100) - - YEAR = NYMD / 10000 - MONTH = MOD(NYMD,10000) / 100 - DAY = MOD(NYMD,100) - SEC = NSECF(NHMS) - - IDAY = MNDY( MONTH ,MOD(YEAR ,4)+1 ) - month = month + nsegm - If( month.gt.12 ) then - month = month - 12 - year = year + 1 - endif - IDAY2 = MNDY( MONTH ,MOD(YEAR ,4)+1 ) - - nday = iday2-iday - if(nday.lt.0) nday = nday + 1461 - nday = nday + nsegd - - nsecf2 = nsecf2 + nday*nsday - - return - end - - subroutine remap ( ps1,dp1,u1,v1,thv1,q1,phis1,lm1, - . ps2,dp2,u2,v2,t2 ,q2,phis2,lm2,im,jm,nq,pbelow,pabove ) - -C*********************************************************************** -C -C Purpose -C Driver for remapping of target analysis to fv model levels -C -C Argument Description -C ps1 ...... model surface pressure -C dp1 ...... model pressure thickness -C u1 ....... model zonal wind -C v1 ....... model meridional wind -C thv1 ..... model virtual potential temperature -C q1 ....... model specific humidity -C oz1 ...... model ozone -C phis1 .... model surface geopotential -C lm1 ...... model vertical dimension -C -C ps2 ...... analysis surface pressure -C dp2 ...... analysis pressure thickness -C u2 ....... analysis zonal wind -C v2 ....... analysis meridional wind -C t2 . ..... analysis dry-bulb temperature -C q2 ....... analysis specific humidity -C oz2 ...... analysis ozone -C phis2 .... analysis surface geopotential -C lm2 ...... analysis vertical dimension -C -C im ....... zonal dimension -C jm ....... meridional dimension -C nq ....... number of trancers -C pbelow ... pressure below which analysis is used completely -C pabove ... pressure above which model is used completely -C Note: a blend is used in-between pbelow and pabove -C If pbelow=pabove, blending code is disabled -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - integer im,jm,nq,lm1,lm2 - -c fv-DAS variables -c ---------------- - real dp1(im,jm,lm1), dp0(im,jm,lm1) - real u1(im,jm,lm1), u0(im,jm,lm1) - real v1(im,jm,lm1), v0(im,jm,lm1) - real thv1(im,jm,lm1), thv0(im,jm,lm1) - real q1(im,jm,lm1,nq), q0(im,jm,lm1,nq) - real ps1(im,jm), ps0(im,jm) - - real phis1(im,jm) - real ak(lm1+1) - real bk(lm1+1) - -c Target analysis variables -c ------------------------- - real dp2(im,jm,lm2) - real u2(im,jm,lm2) - real v2(im,jm,lm2) - real t2(im,jm,lm2) - real thv2(im,jm,lm2) - real q2(im,jm,lm2,nq) - real ps2(im,jm) - real phis2(im,jm) - -c Local variables -c --------------- - real pe0(im,jm,lm1+1) - real pe1(im,jm,lm1+1) - real pe2(im,jm,lm2+1) - real pk (im,jm,lm2 ) - real pke0(im,jm,lm1+1) - real pke1(im,jm,lm1+1) - real pke2(im,jm,lm2+1) - real phi2(im,jm,lm2+1) - - real kappa,cp,ptop,pbelow,pabove,pl,alf,pint - real rgas,pref,tref,pkref,tstar,eps,rvap,grav - integer i,j,L,n,ks - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - - call set_eta ( lm1,ks,ptop,pint,ak,bk ) - -c Compute edge-level pressures -c ---------------------------- - pe1(:,:,lm1+1) = ps1(:,:) - do L=lm1,1,-1 - pe1(:,:,L) = pe1(:,:,L+1)-dp1(:,:,L) - enddo - -c Copy input fv state into local variables -c ---------------------------------------- - ps0(:,:) = ps1(:,:) - dp0(:,:,:) = dp1(:,:,:) - u0(:,:,:) = u1(:,:,:) - v0(:,:,:) = v1(:,:,:) - thv0(:,:,:) = thv1(:,:,:) - q0(:,:,:,:) = q1(:,:,:,:) - pe0(:,:,:) = pe1(:,:,:) - pke0(:,:,:) = pe0(:,:,:)**kappa - -c Construct target analysis pressure variables -c -------------------------------------------- - do j=1,jm - do i=1,im - pe2(i,j,lm2+1) = ps2(i,j) - enddo - enddo - - do L=lm2,1,-1 - do j=1,jm - do i=1,im - pe2(i,j,L) = pe2(i,j,L+1) - dp2(i,j,L) - enddo - enddo - enddo - - do j=1,jm - do i=1,im - pe2(i,j,1) = 1.0 ! Set ptop = 0.01 mb - enddo - enddo - - do L=1,lm2+1 - do j=1,jm - do i=1,im - pke2(i,j,L) = pe2(i,j,L)**kappa - enddo - enddo - enddo - -c Construct target virtual potential temperature -c ---------------------------------------------- - do L=1,lm2 - do j=1,jm - do i=1,im - pk (i,j,L) = ( pke2(i,j,L+1)-pke2(i,j,L) )/( kappa*log(pe2(i,j,L+1)/pe2(i,j,L)) ) - thv2(i,j,L) = t2(i,j,L)*( 1.0+eps*max(0.0,q2(i,j,L,1)) )/pk(i,j,L) - enddo - enddo - enddo - -c Construct target analysis heights -c --------------------------------- - phi2(:,:,lm2+1) = phis2(:,:) - do L=lm2,1,-1 - phi2(:,:,L) = phi2(:,:,L+1) + cp*thv2(:,:,L)*( pke2(:,:,L+1)-pke2(:,:,L) ) - enddo - -c Compute new surface pressure consistent with fv topography -c ---------------------------------------------------------- - do j=1,jm - do i=1,im - L = lm2 - do while ( phi2(i,j,L).lt.phis1(i,j) ) - L = L-1 - enddo - ps1(i,j) = pe2(i,j,L+1)*( 1 + (phi2(i,j,L+1)-phis1(i,j))/(cp*thv2(i,j,L)*pke2(i,j,L+1)) )**(1.0/kappa) - enddo - enddo - -c Construct fv pressure variables using new surface pressure -c ---------------------------------------------------------- - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1(i,j,L) = ak(L) + bk(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -c Map original fv state onto new eta grid -c --------------------------------------- - print *, ' ReMapping Original FV-State onto New Eta Grid' - call gmap ( im,jm,nq, kappa, - . lm1, pke0, pe0, u1, v1, thv1, q1, - . lm1, pke1, pe1, u0, v0, thv0, q0) - -c Map target analysis onto fv grid -c -------------------------------- - print *, ' Mapping Analysis-State onto New Eta Grid' - call gmap ( im,jm,nq, kappa, - . lm2, pke2, pe2, u2, v2, thv2, q2, - . lm1, pke1, pe1, u1, v1, thv1, q1) - -c Blend result with original fv state -c ----------------------------------- - if( pbelow.ne.pabove ) then - print *, ' Blending FV and Analysis States' - do L=1,lm1 - do j=1,jm - do i=1,im - pl=0.5*(pe1(i,j,L+1)+pe1(i,j,L)) - alf=(pl-pabove)/(pbelow-pabove) - if( pl.lt.pabove ) then - u1(i,j,L) = u0(i,j,L) - v1(i,j,L) = v0(i,j,L) - thv1(i,j,L) = thv0(i,j,L) - else if( pl.lt.pbelow ) then - u1(i,j,L) = u1(i,j,L)*alf + u0(i,j,L)*(1-alf) - v1(i,j,L) = v1(i,j,L)*alf + v0(i,j,L)*(1-alf) - thv1(i,j,L) = thv1(i,j,L)*alf + thv0(i,j,L)*(1-alf) - endif - enddo - enddo - enddo - do n=1,nq - do L=1,lm1 - do j=1,jm - do i=1,im - pl=0.5*(pe1(i,j,L+1)+pe1(i,j,L)) - alf=(pl-pabove)/(pbelow-pabove) - if( pl.lt.pabove ) then - q1(i,j,L,n) = q0(i,j,L,n) - else if( pl.lt.pbelow ) then - q1(i,j,L,n) = q1(i,j,L,n)*alf + q0(i,j,L,n)*(1-alf) - endif - enddo - enddo - enddo - enddo - endif - - return - end - - subroutine gauss_lat_nmc(gaul,k) - implicit double precision (a-h,o-z) - dimension a(500) - real gaul(1) - save - esp=1.d-14 - c=(1.d0-(2.d0/3.14159265358979d0)**2)*0.25d0 - fk=k - kk=k/2 - call bsslz1(a,kk) - do 30 is=1,kk - xz=cos(a(is)/sqrt((fk+0.5d0)**2+c)) - iter=0 - 10 pkm2=1.d0 - pkm1=xz - iter=iter+1 - if(iter.gt.10) go to 70 - do 20 n=2,k - fn=n - pk=((2.d0*fn-1.d0)*xz*pkm1-(fn-1.d0)*pkm2)/fn - pkm2=pkm1 - 20 pkm1=pk - pkm1=pkm2 - pkmrk=(fk*(pkm1-xz*pk))/(1.d0-xz**2) - sp=pk/pkmrk - xz=xz-sp - avsp=abs(sp) - if(avsp.gt.esp) go to 10 - a(is)=xz - 30 continue - if(k.eq.kk*2) go to 50 - a(kk+1)=0.d0 - pk=2.d0/fk**2 - do 40 n=2,k,2 - fn=n - 40 pk=pk*fn**2/(fn-1.d0)**2 - 50 continue - do 60 n=1,kk - l=k+1-n - a(l)=-a(n) - 60 continue - radi=180./(4.*atan(1.)) - do 211 n=1,k - gaul(n)=acos(a(n))*radi-90.0 - 211 continue - return - 70 write(6,6000) - 6000 format(//5x,14herror in gauaw//) - stop - end - - subroutine bsslz1(bes,n) - implicit double precision (a-h,o-z) - dimension bes(n) - dimension bz(50) - data pi/3.14159265358979d0/ - data bz / 2.4048255577d0, 5.5200781103d0, - $ 8.6537279129d0,11.7915344391d0,14.9309177086d0,18.0710639679d0, - $ 21.2116366299d0,24.3524715308d0,27.4934791320d0,30.6346064684d0, - $ 33.7758202136d0,36.9170983537d0,40.0584257646d0,43.1997917132d0, - $ 46.3411883717d0,49.4826098974d0,52.6240518411d0,55.7655107550d0, - $ 58.9069839261d0,62.0484691902d0,65.1899648002d0,68.3314693299d0, - $ 71.4729816036d0,74.6145006437d0,77.7560256304d0,80.8975558711d0, - $ 84.0390907769d0,87.1806298436d0,90.3221726372d0,93.4637187819d0, - $ 96.6052679510d0,99.7468198587d0,102.888374254d0,106.029930916d0, - $ 109.171489649d0,112.313050280d0,115.454612653d0,118.596176630d0, - $ 121.737742088d0,124.879308913d0,128.020877005d0,131.162446275d0, - $ 134.304016638d0,137.445588020d0,140.587160352d0,143.728733573d0, - $ 146.870307625d0,150.011882457d0,153.153458019d0,156.295034268d0/ - nn=n - if(n.le.50) go to 12 - bes(50)=bz(50) - do 5 j=51,n - 5 bes(j)=bes(j-1)+pi - nn=49 - 12 do 15 j=1,nn - 15 bes(j)=bz(j) - return - end - - - subroutine get_ozone ( ozone,pl,im,jm,lm,nymd,nhms ) - implicit none - - integer nlats - integer nlevs - parameter ( nlats = 37 ) ! 37 Latitudes - parameter ( nlevs = 34 ) ! 34 Pressure Levels - - real o3(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - -c Input Variables -c --------------- - integer im,jm,lm,nymd,nhms - real ozone(im,jm,lm) - real pl(im,jm,lm) - -c Local Variables -c --------------- - real xlat(im,jm) - integer i,j,L,koz - - real voltomas - PARAMETER ( VOLTOMAS = 1.655E-6 ) - - koz = 40 - - do j=1,jm - do i=1,im - xlat(i,j) = -90. + (j-1)*180./(jm-1) - enddo - enddo - - call chemistry (koz,nymd,nhms,o3,lats,levs,nlats,nlevs) - call interp_oz (o3,lats,levs,nlats,nlevs,im*jm,xlat,lm,pl,ozone) - - ozone(:,:,:) = ozone(:,:,:) * VOLTOMAS - - return - end - - subroutine chemistry (koz,nymd,nhms,ozone,lats,levs,nlats,nlevs) -C*********************************************************************** -C PURPOSE -C Chemistry Model -C -C ARGUMENTS DESCRIPTION -C koz Unit to read Stratospheric Ozone -C kqz Unit to read Stratospheric Moisture -C nymd Current Date -C nhms Current Time -C -C chemistry .. Chemistry State Data Structure -C grid ....... Dynamics Grid Data Structure -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer koz - integer nymd,nhms - - integer nlats - integer nlevs - real ozone(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - real o3(nlats,nlevs,12) - -c Local Variables -c --------------- - integer j,L - integer nymd1,nhms1,nymd2,nhms2,ipls,imns - real facm,facp - -C ********************************************************************** -C **** Read Ozone and Moisture Data (12 Monthly Means) **** -C ********************************************************************** - - call read_oz (koz,o3,lats,levs,nlats,nlevs,12) - -C ********************************************************************** -C **** Update Chemistry State to Current Time **** -C ********************************************************************** - - call time_bound ( nymd,nhms, nymd1,nhms1, nymd2,nhms2, imns,ipls ) - call interp_time ( nymd,nhms, nymd1,nhms1, nymd2,nhms2, facm,facp ) - - do L = 1,nlevs - do j = 1,nlats - ozone(j,L) = o3(j,L,imns)*facm + o3(j,L,ipls)*facp - enddo - enddo - - return - end - - subroutine read_oz (ku,oz,lats,levs,nlat,nlev,ntime) -C*********************************************************************** -C PURPOSE -C To Read Ozone Value -C -C ARGUMENTS DESCRIPTION -C ku ...... Unit to Read Ozone Data -C oz ...... Ozone Data -C lats .... Ozone Data Latitudes (degrees) -C levs .... Ozone Data Levels (mb) -C nlat .... Number of ozone latitudes -C nlev .... Number of ozone levels -C ntime ... Number of ozone time values -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer ku,nlat,nlev,ntime - - real oz(nlat,nlev,ntime) - real*4 o3(nlat) - real lats(nlat) - real levs(nlev) - - integer time - integer lat - integer lev - integer nrec - - real plevs(34) - data plevs/ 0.003, 0.005, 0.007, 0.01, 0.015, 0.02, 0.03, 0.05, - . 0.07, 0.1, 0.15, 0.2, 0.3, 0.5, 0.7, 1.0, 1.5, 2.0, - . 3.0, 5.0, 7.0, 10.0, 15.0, 20.0, 30.0, 50.0, 70.0, - . 100.0, 150.0, 200.0, 300.0, 500.0, 700.0, 1000.0 / - - rewind ku - -c Set Ozone Data Latitudes -c ------------------------ - do lat = 1,nlat - lats(lat) = -90. + (lat-1)*5. - enddo - -c Set Ozone Data Levels -c ------------------------ - do lev = 1,nlev - levs(lev) = plevs(lev)*100 - enddo - -c Read Ozone Amounts by Month and Level -c ------------------------------------- - close (ku) - open (ku, file="/home/ltakacs/data/bcs/TSMo3.v02.gra", - . form='unformatted', access='direct', recl=nlat*4) - - do time=1,ntime - do lev=1,nlev - nrec = lev+(time-1)*nlev*2 ! Note: 2 quantities in Ozone Dataset - read(ku,rec=nrec) o3 - do lat=1,nlat - oz(lat,nlev-lev+1,time) = o3(lat) - enddo - enddo - enddo - - close (ku) - return - end - - subroutine interp_oz (ozone,lats,levs,nlats,nlevs,irun ,xlat,km,plevs,ozrad) - -c Declare Modules and Data Structures -c ----------------------------------- - implicit none - integer nlats,nlevs - real ozone(nlats,nlevs) - real lats(nlats) - real levs(nlevs) - - integer irun,km - real xlat (irun) - real plevs (irun,km) - real ozrad (irun,km) - -c Local Variables -c --------------- - real zero,one,o3min - PARAMETER ( ZERO = 0.0 ) - PARAMETER ( ONE = 1.0 ) - PARAMETER ( O3MIN = 1.0E-10 ) - - integer i,k,L1,L2,LM,LP - integer jlat,jlatm,jlatp - real O3INT1(IRUN,nlevs) - real QPR1(IRUN), QPR2(IRUN), SLOPE(IRUN) - real PR1(IRUN), PR2(IRUN) - -C ********************************************************************** -C **** INTERPOLATE ozone data to model latitudes *** -C ********************************************************************** - - DO 32 K=1,nlevs - DO 34 I=1,IRUN - - DO 36 jlat = 1,nlats - IF( lats(jlat).gt.xlat(i) ) THEN - IF( jlat.EQ.1 ) THEN - jlatm = 1 - jlatp = 1 - slope(i) = zero - ELSE - jlatm = jlat-1 - jlatp = jlat - slope(i) = ( XLAT(I) -lats(jlat-1) ) - . / ( lats(jlat)-lats(jlat-1) ) - ENDIF - GOTO 37 - ENDIF - 36 CONTINUE - jlatm = nlats - jlatp = nlats - slope(i) = one - 37 CONTINUE - QPR1(I) = ozone(jlatm,k) - QPR2(I) = ozone(jlatp,k) - 34 CONTINUE - - DO 38 I=1,IRUN - o3int1(i,k) = qpr1(i) + slope(i)*( qpr2(i)-qpr1(i) ) - 38 CONTINUE - - 32 CONTINUE - -C ********************************************************************** -C **** INTERPOLATE latitude ozone data to model pressures *** -C ********************************************************************** - - DO 40 L2 = 1,km - - DO 44 I = 1,IRUN - DO 46 L1 = 1,nlevs - IF( levs(L1).GT.PLEVS(I,L2) ) THEN - IF( L1.EQ.1 ) THEN - LM = 1 - LP = 2 - ELSE - LM = L1-1 - LP = L1 - ENDIF - GOTO 47 - ENDIF - 46 CONTINUE - LM = nlevs-1 - LP = nlevs - 47 CONTINUE - PR1(I) = levs (LM) - PR2(I) = levs (LP) - QPR1(I) = O3INT1(I,LM) - QPR2(I) = O3INT1(I,LP) - 44 CONTINUE - - DO 48 I=1,IRUN - SLOPE(I) = ( QPR1(I)-QPR2(I) ) - . / ( PR1(I)- PR2(I) ) - ozrad(I,L2) = QPR2(I) + ( PLEVS(I,L2)-PR2(I) )*SLOPE(I) - - if( ozrad(i,l2).lt.o3min ) then - ozrad(i,l2) = o3min - endif - - 48 CONTINUE - 40 CONTINUE - - RETURN - END - - subroutine interp_time ( nymd ,nhms , - . nymd1,nhms1, nymd2,nhms2, fac1,fac2 ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute interpolation factors, fac1 & fac2, to be used in the -C calculation of the instantanious boundary conditions, ie: -C -C q(i,j) = fac1*q1(i,j) + fac2*q2(i,j) -C where: -C q(i,j) => Boundary Data valid at (nymd , nhms ) -C q1(i,j) => Boundary Data centered at (nymd1 , nhms1) -C q2(i,j) => Boundary Data centered at (nymd2 , nhms2) -C -C INPUT: -C ====== -C nymd : Date (yymmdd) of Current Timestep -C nhms : Time (hhmmss) of Current Timestep -C nymd1 : Date (yymmdd) of Boundary Data 1 -C nhms1 : Time (hhmmss) of Boundary Data 1 -C nymd2 : Date (yymmdd) of Boundary Data 2 -C nhms2 : Time (hhmmss) of Boundary Data 2 -C -C OUTPUT: -C ======= -C fac1 : Interpolation factor for Boundary Data 1 -C fac2 : Interpolation factor for Boundary Data 2 -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER YEAR , MONTH , DAY , SEC - INTEGER YEAR1, MONTH1, DAY1, SEC1 - INTEGER YEAR2, MONTH2, DAY2, SEC2 - - real fac1, fac2 - real time, time1, time2 - - INTEGER DAYSCY - PARAMETER (DAYSCY = 365*4+1) - - REAL MNDY(12,4) - - LOGICAL FIRST - DATA FIRST/.TRUE./ - - DATA MNDY /0,31,60,91,121,152,182,213,244,274,305,335,366, - . 397,34*0 / - -C*********************************************************************** -C* SET TIME BOUNDARIES * -C*********************************************************************** - - YEAR = NYMD / 10000 - MONTH = MOD(NYMD,10000) / 100 - DAY = MOD(NYMD,100) - SEC = NSECF(NHMS) - - YEAR1 = NYMD1 / 10000 - MONTH1 = MOD(NYMD1,10000) / 100 - DAY1 = MOD(NYMD1,100) - SEC1 = NSECF(NHMS1) - - YEAR2 = NYMD2 / 10000 - MONTH2 = MOD(NYMD2,10000) / 100 - DAY2 = MOD(NYMD2,100) - SEC2 = NSECF(NHMS2) - -C*********************************************************************** -C* COMPUTE DAYS IN 4-YEAR CYCLE * -C*********************************************************************** - - IF(FIRST) THEN - DO I=15,48 - MNDY(I,1) = MNDY(I-12,1) + 365 - ENDDO - FIRST=.FALSE. - ENDIF - -C*********************************************************************** -C* COMPUTE INTERPOLATION FACTORS * -C*********************************************************************** - - time = DAY + MNDY(MONTH ,MOD(YEAR ,4)+1) + float(sec )/86400. - time1 = DAY1 + MNDY(MONTH1,MOD(YEAR1,4)+1) + float(sec1)/86400. - time2 = DAY2 + MNDY(MONTH2,MOD(YEAR2,4)+1) + float(sec2)/86400. - - if( time .lt.time1 ) time = time + dayscy - if( time2.lt.time1 ) time2 = time2 + dayscy - - fac1 = (time2-time)/(time2-time1) - fac2 = (time-time1)/(time2-time1) - - RETURN - END - - subroutine time_bound ( nymd,nhms,nymd1,nhms1,nymd2,nhms2, imnm,imnp ) -C*********************************************************************** -C PURPOSE -C Compute Date and Time boundaries. -C -C ARGUMENTS DESCRIPTION -C nymd .... Current Date -C nhms .... Current Time -C nymd1 ... Previous Date Boundary -C nhms1 ... Previous Time Boundary -C nymd2 ... Subsequent Date Boundary -C nhms2 ... Subsequent Time Boundary -C -C imnm .... Previous Time Index for Interpolation -C imnp .... Subsequent Time Index for Interpolation -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - integer nymd,nhms, nymd1,nhms1, nymd2,nhms2 - -c Local Variables -c --------------- - integer month,day,nyear,midmon1,midmon,midmon2 - integer imnm,imnp - INTEGER DAYS(14), daysm, days0, daysp - DATA DAYS /31,31,28,31,30,31,30,31,31,30,31,30,31,31/ - - integer nmonf,ndayf,n - NMONF(N) = MOD(N,10000)/100 - NDAYF(N) = MOD(N,100) - -C********************************************************************* -C**** Find Proper Month and Time Boundaries for Climatological Data ** -C********************************************************************* - - MONTH = NMONF(NYMD) - DAY = NDAYF(NYMD) - - daysm = days(month ) - days0 = days(month+1) - daysp = days(month+2) - -c Check for Leap Year -c ------------------- - nyear = nymd/10000 - if( 4*(nyear/4).eq.nyear ) then - if( month.eq.3 ) daysm = daysm+1 - if( month.eq.2 ) days0 = days0+1 - if( month.eq.1 ) daysp = daysp+1 - endif - - MIDMON1 = daysm/2 + 1 - MIDMON = days0/2 + 1 - MIDMON2 = daysp/2 + 1 - - - IF(DAY.LT.MIDMON) THEN - imnm = month - imnp = month + 1 - nymd2 = (nymd/10000)*10000 + month*100 + midmon - nhms2 = 000000 - nymd1 = nymd2 - nhms1 = nhms2 - call tick ( nymd1,nhms1, -midmon *86400 ) - call tick ( nymd1,nhms1,-(daysm-midmon1)*86400 ) - ELSE - IMNM = MONTH + 1 - IMNP = MONTH + 2 - nymd1 = (nymd/10000)*10000 + month*100 + midmon - nhms1 = 000000 - nymd2 = nymd1 - nhms2 = nhms1 - call tick ( nymd2,nhms2,(days0-midmon)*86400 ) - call tick ( nymd2,nhms2, midmon2*86400 ) - ENDIF - -c ------------------------------------------------------------- -c Note: At this point, imnm & imnp range between 01-14, where -c 01 -> Previous years December -c 02-13 -> Current years January-December -c 14 -> Next years January -c ------------------------------------------------------------- - - imnm = imnm-1 - imnp = imnp-1 - - if( imnm.eq.0 ) imnm = 12 - if( imnp.eq.0 ) imnp = 12 - if( imnm.eq.13 ) imnm = 1 - if( imnp.eq.13 ) imnp = 1 - - return - end - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - END - - FUNCTION INCYMD (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - - RETURN - END - - subroutine usage() - print *, "Usage: " - print * - print *, " ec2fv.x [-ncep ncep.data]" - print *, " [-ctl ncep.ctl]" - print *, " [-bkg bkg.data]" - print *, " [-nymd nymd]" - print *, " [-nhms nhms]" - print *, " [-plow plow]" - print *, " [-phigh phigh]" - print *, " [-tag tag]" - print *, " [-ozone]" - print * - print *, "where:" - print * - print *, " -ncep ncep.data: Filename of NCEP Pressure-Level analysis data" - print *, " -ctl ncep.ctl : Filename of NCEP Pressure-Level analysis ctl" - print *, " -bkg bkg.data: Filename of GMAO Background Data (ana.eta format)" - print * - print *, " -plow plow: Pressure Level to begin blending" - print *, " -phigh phigh: Pressure Level to end blending" - print * - print *, " -nymd nymd: Desired date in yyyymmdd format" - print *, " -nhms nhms: Desired time in hhmmss format" - print * - print *, " -tag tag: Optional Prefix tag for output files" - print *, " -ozone Optional Flag to add ozone" - print * - error stop 7 - end - - subroutine get_slp ( ps,phis,slp,pe,pk,tv,rgas,grav,im,jm,km ) - implicit none - integer im,jm,km - real grav - real rgas - real pk(im,jm,km) ! layer-mean P**kappa - real tv(im,jm,km) ! layer-mean virtual Temperature - real pe(im,jm,km+1) ! press at layer edges (Pa) - real ps(im,jm) ! surface pressure (Pa) - real phis(im,jm) ! surface geopotential - real slp(im,jm) ! sea-level pressure (hPa) - - real p_offset - real p_bot - real tstar ! extrapolated temperature (K) - real tref ! Reference virtual temperature (K) - real pref ! Reference pressure level (Pa) - real pkref ! Reference pressure level (Pa) ** kappa - real dp1, dp2 - real factor, yfactor - real gg - real gamma - integer k_bot, k, k1, k2, i,j - - gamma = 6.5e-3 - gg = gamma / grav - factor = grav / ( Rgas * gamma ) - yfactor = Rgas * gg - p_offset = 15000. ! 150 hPa above surface - - do j=1,jm - do i=1,im - p_bot = ps(i,j) - p_offset - k_bot = -1 - do k = km, 2, -1 - if ( pe(i,j,k+1) .lt. p_bot ) then - k_bot = k - go to 123 - endif - enddo -123 continue - k1 = k_bot - 1 - k2 = k_bot - dp1 = pe(i,j,k_bot) - pe(i,j,k_bot-1) - dp2 = pe(i,j,k_bot+1) - pe(i,j,k_bot) - pkref = ( pk(i,j,k1)*dp1 + pk(i,j,k2)*dp2 ) / (dp1+dp2) - tref = ( tv(i,j,k1)*dp1 + tv(i,j,k2)*dp2 ) / (dp1+dp2) - pref = 0.5 * ( pe(i,j,k_bot+1) + pe(i,j,k_bot-1) ) - tstar = tref*( ps(i,j)/pref )**yfactor - slp(i,j) = ps(i,j)*( 1.0+gg*phis(i,j)/tstar )**factor - enddo - enddo - - return - end - -C ********************************************************************** -C **** Read Grads CTL File for Meta Data **** -C ********************************************************************** - - subroutine read_ctl ( ctlfile,im,jm,lm,undef,format, - . nvars,names,descs,lmvars, - . lats,lons,levs ) - implicit none - - character*256, pointer :: names(:) - character*256, pointer :: descs(:) - integer, pointer :: lmvars(:) - real, pointer :: lats(:) - real, pointer :: lons(:) - real, pointer :: levs(:) - - character*256 ctlfile, format - integer im,jm,lm,nvars - real undef,dx,dy,dz - integer i,j,L,m,n,ndum - character*256 dummy,name - character*256, allocatable :: dum(:) - - open (10,file=trim(ctlfile),form='formatted') - format = 'direct' - do - read(10,*,end=500) dummy - -c OPTIONS -c ------- - if( trim(dummy).eq.'options' ) then - ndum = 1 - do - backspace(10) - allocate ( dum(ndum) ) - read(10,*,err=101) dummy - if( trim(dummy).eq.'options' ) then - backspace(10) - read(10,*,end=101) dummy,( dum(n),n=1,ndum ) - else - goto 101 - endif - if( trim(dum(ndum)).eq.'sequential' ) format = 'sequential' - deallocate ( dum ) - ndum = ndum + 1 - enddo - 100 format(a5) - 101 continue - deallocate ( dum ) - endif - -c XDEF -c ---- - if( trim(dummy).eq.'xdef' ) then - backspace(10) - read(10,*) dummy,im - allocate( lons(im) ) - backspace(10) - read(10,*) dummy,im,dummy,lons(1),dx - if( trim(dummy).eq.'linear' ) then - do i=2,im - lons(i) = lons(i-1) + dx - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lons(i),i=1,im) - endif - endif - -c YDEF -c ---- - if( trim(dummy).eq.'ydef' ) then - backspace(10) - read(10,*) dummy,jm - allocate( lats(jm) ) - backspace(10) - read(10,*) dummy,jm,dummy,lats(1),dy - if( trim(dummy).eq.'linear' ) then - do j=2,jm - lats(j) = lats(j-1) + dy - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(lats(j),j=1,jm) - endif - endif - -c ZDEF -c ---- - if( trim(dummy).eq.'zdef' ) then - backspace(10) - read(10,*) dummy,lm -#if 1 - allocate( levs(lm) ) - backspace(10) - if( lm.eq.1 ) then - read(10,*) dummy,lm,dummy,levs(1) - else - read(10,*) dummy,lm,dummy,levs(1),dz - endif - if( trim(dummy).eq.'linear' ) then - do L=2,lm - levs(L) = levs(L-1) + dz - enddo - else - backspace(10) - read(10,*) dummy,n,dummy,(levs(L),L=1,lm) - endif -#endif - endif - -c UNDEF -c ----- - if( trim(dummy).eq.'undef' ) then - backspace(10) - read(10,*) dummy,undef - endif - - if( trim(dummy).eq.'vars' ) then - backspace(10) - read(10,*) dummy,nvars - allocate( names(nvars) ) - allocate( descs(nvars) ) - allocate( lmvars(nvars) ) - - do n=1,nvars - read(10,*) names(n),lmvars(n),m,descs(n) - if( lmvars(n).eq.0 ) lmvars(n) = 1 - enddo - - endif - enddo - 500 continue - rewind(10) - - if( nvars.eq.0 ) then - print *, 'Warning, nvars = 0!' - stop - endif - - return - end subroutine read_ctl - - subroutine atod_winds ( ua,va,ud,vd,im,jm,lm ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded winds **** -C **** to 'D' gridded winds **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C ****************************************************************** - - real ua(im,jm,lm), ud(im,jm,lm) - real va(im,jm,lm), vd(im,jm,lm) - - call atod ( ua,ud,im,jm,lm,2 ) - call atod ( va,vd,im,jm,lm,1 ) - - return - end - - subroutine dtoa_winds ( ud,vd,ua,va,im,jm,lm ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded winds **** -C **** to 'A' gridded winds **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C ****************************************************************** - - real ua(im,jm,lm), ud(im,jm,lm) - real va(im,jm,lm), vd(im,jm,lm) - - real sinx(im/2) - real cosx(im/2) - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - do i=1,imh - sinx(i) = sin( -pi + (i-1)*dx ) - cosx(i) = cos( -pi + (i-1)*dx ) - enddo - -C ********************************************************* -C **** Average D-Grid Winds **** -C ********************************************************* - - call dtoa ( ud,ua,im,jm,lm,2 ) - call dtoa ( vd,va,im,jm,lm,1 ) - -C ********************************************************* -C **** Fix A-Grid Pole Winds **** -C ********************************************************* - - do L=1,lm - - do m=1,2 - n = (-1)**m - jpole = 1 + (m-1)*(jm-1) - jstar = 2 + (m-1)*(jm-3) - - upole = 0.0 - vpole = 0.0 - do i=1,imh - upole = upole + ( ua(i+imh,jstar,L)-ua(i,jstar,L) )*sinx(i) - . + n*( va(i+imh,jstar,L)-va(i,jstar,L) )*cosx(i) - vpole = vpole - n*( ua(i+imh,jstar,L)-ua(i,jstar,L) )*cosx(i) - . + ( va(i+imh,jstar,L)-va(i,jstar,L) )*sinx(i) - enddo - upole = upole / im - vpole = vpole / im - do i=1,imh - ua(i ,jpole,L) = - upole*sinx(i) + n*vpole*cosx(i) - va(i ,jpole,L) = - n*upole*cosx(i) - vpole*sinx(i) - ua(i+imh,jpole,L) = - ua(i,jpole,L) - va(i+imh,jpole,L) = - va(i,jpole,L) - enddo - enddo - - enddo - - return - end - - subroutine atod ( qa,qd,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded data **** -C **** to 'D' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted left (westward), **** -C **** u is shifted down (southward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real,allocatable :: qax(:,:) - real,allocatable :: cx(:,:) - real,allocatable :: qay(:,:) - real,allocatable :: cy(:,:) - - real,allocatable :: sinx(:) - real,allocatable :: cosx(:) - real,allocatable :: siny(:) - real,allocatable :: cosy(:) - real,allocatable :: trigx(:) - real,allocatable :: trigy(:) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - - allocate( qax ( im+2 ,lm) ) - allocate( cx (2*(im+2),lm) ) - allocate( qay ( 2*jm ,lm) ) - allocate( cy (2*(2*jm),lm) ) - - allocate( cosx(im/2) ) - allocate( sinx(im/2) ) - allocate( cosy(jm) ) - allocate( siny(jm) ) - allocate( trigx(3*(im+1)) ) - allocate( trigy(3*(2*jm)) ) - -C ********************************************************* -C **** shift left (-dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qa(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) + qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) - qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qd(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift down (-dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qa(i,j+1,L) - qay(j+jmm1,L) = -qa(i+imh,jm-j,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) + qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) - qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qd(i,j+1,L) = qay(j,L) - qd(i+imh,jm-j+1,L) = -qay(j+jmm1,L) - enddo - enddo - enddo - - endif - - deallocate( qax ) - deallocate( cx ) - deallocate( qay ) - deallocate( cy ) - - deallocate( cosx ) - deallocate( sinx ) - deallocate( cosy ) - deallocate( siny ) - deallocate( trigx ) - deallocate( trigy ) - - return - end - - subroutine dtoa ( qd,qa,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real,allocatable :: qax(:,:) - real,allocatable :: cx(:,:) - real,allocatable :: qay(:,:) - real,allocatable :: cy(:,:) - - real,allocatable :: sinx(:) - real,allocatable :: cosx(:) - real,allocatable :: siny(:) - real,allocatable :: cosy(:) - real,allocatable :: trigx(:) - real,allocatable :: trigy(:) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - - allocate( qax ( im+2 ,lm) ) - allocate( cx (2*(im+2),lm) ) - allocate( qay ( 2*jm ,lm) ) - allocate( cy (2*(2*jm),lm) ) - - allocate( cosx(im/2) ) - allocate( sinx(im/2) ) - allocate( cosy(jm) ) - allocate( siny(jm) ) - allocate( trigx(3*(im+1)) ) - allocate( trigy(3*(2*jm)) ) - -C ********************************************************* -C **** shift right (dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qd(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) - qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) + qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qa(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift up (dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qd(i,j+1,L) - qay(j+jmm1,L) = -qd(i+imh,jm-j+1,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) - qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) + qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qa(i,j+1,L) = qay(j,L) - qa(i+imh,jm-j,L) = -qay(j+jmm1,L) - enddo - enddo - - enddo - - do L=1,lm - do i=1,imh - qa(i+imh,jm,L) = -qa(i,jm,L) - qa(i,1,L) = -qa(i+imh,1,L) - enddo - enddo - endif - - deallocate( qax ) - deallocate( cx ) - deallocate( qay ) - deallocate( cy ) - - deallocate( cosx ) - deallocate( sinx ) - deallocate( cosy ) - deallocate( siny ) - deallocate( trigx ) - deallocate( trigy ) - - return - end - - subroutine rfftmlt (a,work,trigs,ifax,inc,jump,n,lot,isign) - integer INC, JUMP, N, LOT, ISIGN - real(kind=KIND(1.0)) A(N),WORK(N),TRIGS(N) - integer IFAX(*) -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR -! CALL Q8QST4 ( 4HXLIB, 6HFFT99F, 6HFFT991, 10HVERSION 01) -!FPP$ NOVECTOR R - integer NFAX, NH, NX, INK - integer I, J, IBASE, JBASE, L, IGO, IA, LA, K, M, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, - * INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, - * 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 -!DIR$ IVDEP - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END - - subroutine fftfax (n,ifax,trigs) - integer IFAX(13) - integer N - REAL(kind=KIND(1.0)) TRIGS(*) -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - integer I, MODE - DATA MODE /3/ -!FPP$ NOVECTOR R - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) WRITE(6,FMT="(//5X, ' FFTFAX -- INVALID N =', I5,/)") N - IF (IFAX(1) .LE. 0 ) STOP 999 - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END - - subroutine fft99a (a,work,trigs,inc,jump,n,lot) - integer inc, jump, N, lot - real(kind=KIND(1.0)) A(N),WORK(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 -! (SPECTRAL TO GRIDPOINT TRANSFORM) -! -!FPP$ NOVECTOR R - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) C, S - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - IA=1 - IB=N*INC+1 - JA=1 - JB=2 -!DIR$ IVDEP - DO 10 L=1,LOT - WORK(JA)=A(IA)+A(IB) - WORK(JB)=A(IA)-A(IB) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 10 CONTINUE -! -! REMAINING WAVENUMBERS - IABASE=2*INC+1 - IBBASE=(N-2)*INC+1 - JABASE=3 - JBBASE=N-1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - WORK(JA)=(A(IA)+A(IB))- - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JB)=(A(IA)+A(IB))+ - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+ - * (A(IA+INC)-A(IB+INC)) - WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))- - * (A(IA+INC)-A(IB+INC)) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 20 CONTINUE - IABASE=IABASE+INK - IBBASE=IBBASE-INK - JABASE=JABASE+2 - JBBASE=JBBASE-2 - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE -!DIR$ IVDEP - DO 40 L=1,LOT - WORK(JA)=2.0*A(IA) - WORK(JA+1)=-2.0*A(IA+INC) - IA=IA+JUMP - JA=JA+NX - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fft99b (work,a,trigs,inc,jump,n,lot) - integer INC, JUMP, N, LOT - real(kind=KIND(1.0)) WORK(N),A(N) - REAL(kind=KIND(1.0)) TRIGS(N) - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) SCALE - real(kind=KIND(1.0)) C, S -! -! SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 -! (GRIDPOINT TO SPECTRAL TRANSFORM) -! -!FPP$ NOVECTOR R - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - SCALE=1.0/FLOAT(N) - IA=1 - IB=2 - JA=1 - JB=N*INC+1 -!DIR$ IVDEP - DO 10 L=1,LOT - A(JA)=SCALE*(WORK(IA)+WORK(IB)) - A(JB)=SCALE*(WORK(IA)-WORK(IB)) - A(JA+INC)=0.0 - A(JB+INC)=0.0 - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 10 CONTINUE -! -! REMAINING WAVENUMBERS - SCALE=0.5*SCALE - IABASE=3 - IBBASE=N-1 - JABASE=2*INC+1 - JBBASE=(N-2)*INC+1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - A(JA)=SCALE*((WORK(IA)+WORK(IB)) - * +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JB)=SCALE*((WORK(IA)+WORK(IB)) - * -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * +(WORK(IB+1)-WORK(IA+1))) - A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * -(WORK(IB+1)-WORK(IA+1))) - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 20 CONTINUE - IABASE=IABASE+2 - IBBASE=IBBASE-2 - JABASE=JABASE+INK - JBBASE=JBBASE-INK - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - SCALE=2.0*SCALE -!DIR$ IVDEP - DO 40 L=1,LOT - A(JA)=SCALE*WORK(IA) - A(JA+INC)=-SCALE*WORK(IA+1) - IA=IA+NX - JA=JA+JUMP - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fax (ifax,n,mode) - integer IFAX(10) - integer N, MODE -!FPP$ NOVECTOR R - integer NN, K, L, INC, II, ISTOP, ITEM, NFAX, I - NN=N - IF (IABS(MODE).EQ.1) GO TO 10 - IF (IABS(MODE).EQ.8) GO TO 10 - NN=N/2 - IF ((NN+NN).EQ.N) GO TO 10 - IFAX(1)=-99 - RETURN - 10 K=1 -! TEST FOR FACTORS OF 4 - 20 IF (MOD(NN,4).NE.0) GO TO 30 - K=K+1 - IFAX(K)=4 - NN=NN/4 - IF (NN.EQ.1) GO TO 80 - GO TO 20 -! TEST FOR EXTRA FACTOR OF 2 - 30 IF (MOD(NN,2).NE.0) GO TO 40 - K=K+1 - IFAX(K)=2 - NN=NN/2 - IF (NN.EQ.1) GO TO 80 -! TEST FOR FACTORS OF 3 - 40 IF (MOD(NN,3).NE.0) GO TO 50 - K=K+1 - IFAX(K)=3 - NN=NN/3 - IF (NN.EQ.1) GO TO 80 - GO TO 40 -! NOW FIND REMAINING FACTORS - 50 L=5 - INC=2 -! INC ALTERNATELY TAKES ON VALUES 2 AND 4 - 60 IF (MOD(NN,L).NE.0) GO TO 70 - K=K+1 - IFAX(K)=L - NN=NN/L - IF (NN.EQ.1) GO TO 80 - GO TO 60 - 70 L=L+INC - INC=6-INC - GO TO 60 - 80 IFAX(1)=K-1 -! IFAX(1) CONTAINS NUMBER OF FACTORS - NFAX=IFAX(1) -! SORT FACTORS INTO ASCENDING ORDER - IF (NFAX.EQ.1) GO TO 110 - DO 100 II=2,NFAX - ISTOP=NFAX+2-II - DO 90 I=2,ISTOP - IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 - ITEM=IFAX(I) - IFAX(I)=IFAX(I+1) - IFAX(I+1)=ITEM - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN - END - - subroutine fftrig (trigs,n,mode) - REAL(kind=KIND(1.0)) TRIGS(*) - integer N, MODE -!FPP$ NOVECTOR R - real(kind=KIND(1.0)) PI - integer IMODE, NN, L, I, NH, LA - real(kind=KIND(1.0)) DEL, ANGLE - PI=2.0*ASIN(1.0) - IMODE=IABS(MODE) - NN=N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 - DEL=(PI+PI)/FLOAT(NN) - L=NN+NN - DO 10 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(I)=COS(ANGLE) - TRIGS(I+1)=SIN(ANGLE) - 10 CONTINUE - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - DEL=0.5*DEL - NH=(NN+1)/2 - L=NH+NH - LA=NN+NN - DO 20 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(LA+I)=COS(ANGLE) - TRIGS(LA+I+1)=SIN(ANGLE) - 20 CONTINUE - IF (IMODE.LE.3) RETURN - DEL=0.5*DEL - LA=LA+NN - IF (MODE.EQ.5) GO TO 40 - DO 30 I=2,NN - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=2.0*SIN(ANGLE) - 30 CONTINUE - RETURN - 40 CONTINUE - DEL=0.5*DEL - DO 50 I=2,N - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=SIN(ANGLE) - 50 CONTINUE - RETURN - END - - subroutine vpassm (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la) - integer INC1,INC2,INC3,INC4,LOT,N,IFAC,LA - real(kind=KIND(1.0)) A(N),B(N),C(N),D(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA" -! PERFORMS ONE PASS THROUGH DATA -! AS PART OF MULTIPLE COMPLEX FFT ROUTINE -! A IS FIRST REAL INPUT VECTOR -! B IS FIRST IMAGINARY INPUT VECTOR -! C IS FIRST REAL OUTPUT VECTOR -! D IS FIRST IMAGINARY OUTPUT VECTOR -! TRIGS IS PRECALCULATED TABLE OF SINES & COSINES -! INC1 IS ADDRESSING INCREMENT FOR A AND B -! INC2 IS ADDRESSING INCREMENT FOR C AND D -! INC3 IS ADDRESSING INCREMENT BETWEEN As & Bs -! INC4 IS ADDRESSING INCREMENT BETWEEN Cs & Ds -! LOT IS THE NUMBER OF VECTORS -! N IS LENGTH OF VECTORS -! IFAC IS CURRENT FACTOR OF N -! LA IS PRODUCT OF PREVIOUS FACTORS -! - real(kind=KIND(1.0)) SIN36, COS36, SIN72, COS72, SIN60 - DATA SIN36/0.587785252292473/,COS36/0.809016994374947/, - * SIN72/0.951056516295154/,COS72/0.309016994374947/, - * SIN60/0.866025403784437/ - integer M, IINK, JINK, JUMP, IBASE, JBASE, IGO, IA, JA, IB, JB - integer IC, JC, ID, JD, IE, JE - integer I, J, K, L, IJK, LA1, KB, KC, KD, KE - real(kind=KIND(1.0)) C1, S1, C2, S2, C3, S3, C4, S4 -! -!FPP$ NOVECTOR R - M=N/IFAC - IINK=M*INC1 - JINK=LA*INC2 - JUMP=(IFAC-1)*JINK - IBASE=0 - JBASE=0 - IGO=IFAC-1 - IF (IGO.GT.4) RETURN - GO TO (10,50,90,130),IGO -! -! CODING FOR FACTOR 2 -! - 10 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - DO 20 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 15 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=A(IA+I)-A(IB+I) - D(JB+J)=B(IA+I)-B(IB+I) - I=I+INC3 - J=J+INC4 - 15 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 20 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 40 K=LA1,M,LA - KB=K+K-2 - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - DO 30 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 25 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) - D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) - I=I+INC3 - J=J+INC4 - 25 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 30 CONTINUE - JBASE=JBASE+JUMP - 40 CONTINUE - RETURN -! -! CODING FOR FACTOR 3 -! - 50 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - DO 60 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 55 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))) - C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))) - D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))) - D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))) - I=I+INC3 - J=J+INC4 - 55 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 60 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 80 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - DO 70 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 65 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)= - * C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - D(JB+J)= - * S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - C(JC+J)= - * C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - D(JC+J)= - * S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - I=I+INC3 - J=J+INC4 - 65 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 70 CONTINUE - JBASE=JBASE+JUMP - 80 CONTINUE - RETURN -! -! CODING FOR FACTOR 4 -! - 90 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - DO 100 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 95 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) - C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) - C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) - D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) - D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) - I=I+INC3 - J=J+INC4 - 95 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 100 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 120 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - DO 110 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 105 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - C(JC+J)= - * C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - D(JC+J)= - * S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - C(JB+J)= - * C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - D(JB+J)= - * S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - C(JD+J)= - * C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - D(JD+J)= - * S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 105 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 110 CONTINUE - JBASE=JBASE+JUMP - 120 CONTINUE - RETURN -! -! CODING FOR FACTOR 5 -! - 130 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - IE=ID+IINK - JE=JD+JINK - DO 140 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 135 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 135 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 140 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 160 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - KE=KD+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - C4=TRIGS(KE+1) - S4=TRIGS(KE+2) - DO 150 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 145 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)= - * C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JB+J)= - * S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JE+J)= - * C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JE+J)= - * S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JC+J)= - * C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JC+J)= - * S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - C(JD+J)= - * C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JD+J)= - * S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - I=I+INC3 - J=J+INC4 - 145 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 150 CONTINUE - JBASE=JBASE+JUMP - 160 CONTINUE - RETURN - END - - subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef ) - implicit none - integer iin,jin, iout,jout, mlev - real qin(iin,jin,mlev), qout(iout,jout,mlev) - real undef,pi,dlin,dpin,dlout,dpout - real dlam(iin), lons(iout*jout), lon - real dphi(jin), lats(iout*jout), lat - integer i,j,loc - - pi = 4.0*atan(1.0) - dlin = 2*pi/iin - dpin = pi/(jin-1) - dlam(:) = dlin - dphi(:) = dpin - - dlout = 2*pi/iout - dpout = pi/(jout-1) - - loc = 0 - do j=1,jout - do i=1,iout - loc = loc + 1 - lon = -pi + (i-1)*dlout - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jout - lat = -pi/2.0 + (j-1)*dpout - do i=1,iout - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call interp_h ( qin,iin,jin,mlev,dlam,dphi, - . qout,iout*jout,lons,lats,undef, -pi ) - - return - end - - subroutine interp_h ( q_cmp,im,jm,lm,dlam,dphi, - . q_geo,irun,lon_geo,lat_geo, undef, lon_min ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - - real :: lon_min - -c Local Variables -c --------------- - integer i,j,l,m,n - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - - integer ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1 - integer ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2 - integer jm2_for_jm2, jp1_for_jp1 - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real ux, ap1, ap0, am1, am2 - real uy, bp1, bp0, bm1, bm2 - - real lon_cmp(im) - real lat_cmp(jm) - real q_tmp(irun) - - real pi,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp,phi_np,lam_0 - real lam_geo, lam_cmp - real phi_geo, phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = lon_min ! user supplied orign - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - do i=1,irun - lam_cmp = lon_geo(i) - phi_cmp = lat_geo(i) - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm1 = lat_cmp(jm1(i)) - - if( jm2(i).eq.0 ) then - phi_jm2 = phi_jm1 - dphi(1) - else - phi_jm2 = lat_cmp(jm2(i)) - endif - - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - else - phi_jp0 = lat_cmp(jp0(i)) - if( jp1(i).eq.jm+1 ) then - phi_jp1 = phi_jp0 + dphi(jm-1) - else - phi_jp1 = lat_cmp(jp1(i)) - endif - endif - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - -c Interpolate Computational-Grid Quantities to Geophysical Grid -c ------------------------------------------------------------- - do L=1,lm - do i=1,irun - - if( lat_geo(i).le.lat_cmp(2) .or. - . lat_geo(i).ge.lat_cmp(jm-1) ) then - -c 1st Order Interpolation at Poles -c -------------------------------- - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - else - -c Cubic Interpolation away from Poles -c ----------------------------------- - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jp1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp1(i),L ).ne.undef .and. - . q_cmp( im2(i),jp1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm2(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm2(i),L ).ne.undef .and. - . q_cmp( im1(i),jm2(i),L ).ne.undef .and. - . q_cmp( im2(i),jm2(i),L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) - . + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) - . + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) - . + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) - . + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) - . + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) - . + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - return - - end - - subroutine sigtopl ( qprs,q,logpl,logp,im,jm,lm,undef ) -C*********************************************************************** -C -C PURPOSE -C To interpolate an arbitrary quantity from Model Vertical Grid to Pressure -C -C INPUT -C Q ..... Q (im,jm,lm) Arbitrary Quantity on Model Grid -C PKZ ... PKZ (im,jm,lm) Pressure to the Kappa at Model Levels (From Phillips) -C PKSRF . PKSRF(im,jm) Surface Pressure to the Kappa -C PTOP .. Pressure at Model Top -C P ..... Output Pressure Level (mb) -C IM .... Longitude Dimension of Input -C JM .... Latitude Dimension of Input -C LM .... Vertical Dimension of Input -C -C OUTPUT -C QPRS .. QPRS (im,jm) Arbitrary Quantity at Pressure p -C -C NOTE -C Quantity is interpolated Linear in P**Kappa. -C Between PTOP**Kappa and PKZ(1), quantity is extrapolated. -C Between PKSRF**Kappa and PKZ(LM), quantity is extrapolated. -C Undefined Model-Level quantities are not used. -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** -C - implicit none - integer i,j,l,im,jm,lm - - real qprs(im,jm) - real q (im,jm,lm) - real logpl(im,jm,lm) - - real p,undef - real logp,logpmin,logpmax,temp - -c Initialize to UNDEFINED -c ----------------------- - do i=1,im*jm - qprs(i,1) = undef - enddo - -c Interpolate to Pressure Between Model Levels -c -------------------------------------------- - do L=1,lm-1 - if( all( logpl(:,:,L )>logp ) ) exit - if( all( logpl(:,:,L+1) 2 and km-1 => km -! ----------------------------------------------------------------- - else if( LM1.eq.1 .or. LP0.eq.km .or. 1.eq.1 ) then - q2(i,j,k) = q1(i,j,LP0) + ( q1(i,j,LM1)-q1(i,j,LP0) )*( logpl2(i,j,k )-logpl1(i,j,LP0) ) - . /( logpl1(i,j,LM1)-logpl1(i,j,LP0) ) - -! Interpolate Cubicly in LogP between other model levels -! ------------------------------------------------------ - else - LP1 = LP0+1 - LM2 = LM1-1 - P = logpl2(i,j,k) - PLP1 = logpl1(i,j,LP1) - PLP0 = logpl1(i,j,LP0) - PLM1 = logpl1(i,j,LM1) - PLM2 = logpl1(i,j,LM2) - DLP0 = dlogp1(i,j,LP0) - DLM1 = dlogp1(i,j,LM1) - DLM2 = dlogp1(i,j,LM2) - - ap1 = (P-PLP0)*(P-PLM1)*(P-PLM2)/( DLP0*(DLP0+DLM1)*(DLP0+DLM1+DLM2) ) - ap0 = (PLP1-P)*(P-PLM1)*(P-PLM2)/( DLP0* DLM1 *( DLM1+DLM2) ) - am1 = (PLP1-P)*(PLP0-P)*(P-PLM2)/( DLM1* DLM2 *(DLP0+DLM1 ) ) - am2 = (PLP1-P)*(PLP0-P)*(PLM1-P)/( DLM2*(DLM1+DLM2)*(DLP0+DLM1+DLM2) ) - - q2(i,j,k) = ap1*q1(i,j,LP1) + ap0*q1(i,j,LP0) + am1*q1(i,j,LM1) + am2*q1(i,j,LM2) - - endif - - enddo - enddo - enddo - - return - end - - SUBROUTINE GETVORDIV ( U,V,VOR,DIV,IM,JM ) -C ******************************************************************** -C **** **** -C **** THIS PROGRAM CALCULATES DIVERGENCE **** -C **** AT EACH LEVEL FOR A NON-STAGGERED A-GRID **** -C **** **** -C **** INPUT: **** -C **** U ....... ZONAL WIND **** -C **** V ....... MERIDIONAL WIND **** -C **** IM ...... NUMBER OF LONGITUDE POINTS **** -C **** JM ...... NUMBER OF LATITUDE POINTS **** -C **** **** -C **** OUTPUT: **** -C **** VOR (IM,JM) .... VORTICITY **** -C **** DIV (IM,JM) .... DIVERGENCE **** -C **** **** -C ******************************************************************** - - real U(IM,JM) - real V(IM,JM) - real VOR(IM,JM) - real DIV(IM,JM) - - real P1X (IM,JM) - real P1Y (IM,JM) - real TMP1(IM,JM) - real TMP2(IM,JM) - real cosij(IM,JM) - - DIMENSION MSGN(2) - - DATA MSGN /-1,1/ - -C ********************************************************* -C **** INITIALIZATION FOR DIVERGENCE **** -C ********************************************************* - - A = 6.372e6 - pi = 4.*atan(1.) - dlon = 2*pi/ im - dlat = pi/(jm-1) - - C11 = 1.0 / (2.0*A*IM*(1.0-COS(0.5*dlat))) - - CX1 = 1.0 / (2.0*A*dlon) - CY1 = 1.0 / (2.0*A*dlat) - - do j=2,jm-1 - phi = -pi/2.+(j-1)*dlat - cosphi = cos(phi) - do i=1,im - cosij(i,j) = cosphi - enddo - enddo - cosij(:,1) = 0.0 - cosij(:,jm) = 0.0 - -C ******************************************************** -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - DO j=2,jm-1 - i =im - DO ip1=1,im - P1X(i,j) = ( U(ip1,j)+U(i,j) ) - i =ip1 - ENDDO - ENDDO - - DO j=1,jm-1 - DO I=1,im - P1Y(I,j) = ( V(I,J+1)*COSIJ(I,J+1)+V(I,j)*COSIJ(I,j) ) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE **** -C ********************************************************* - - DO j=2,jm-1 - im1=im - DO i=1,im - TMP1(i,j) = ( P1X(i,j)-P1X(im1,j) )*CX1 - im1=i - ENDDO - - DO I=1,im - TMP2(I,j) = ( P1Y(I,j) -P1Y(I,j-1) )*CY1 - DIV (I,j) = ( TMP1(I,j)+TMP2(I,j) )/(cosij(i,j)) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE AT POLES **** -C ********************************************************* - - DO M=1,2 - JPOLE = 1 + (M-1)*(jm-1) - JPH = 1 + (M-1)*(jm-2) - - SUM11 = 0.0 - DO I=1,im - SUM11 = SUM11 + P1Y(I,JPH) - ENDDO - - DO I=1,im - DIV(I,JPOLE) = - MSGN(M) * C11*SUM11 - ENDDO - ENDDO - -C ******************************************************** -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - DO j=2,jm-1 - i =im - DO ip1=1,im - P1X(i,j) = ( V(ip1,j)+V(i,j) ) - i =ip1 - ENDDO - ENDDO - - DO j=1,jm-1 - DO I=1,im - P1Y(I,j) = ( U(I,J+1)*COSIJ(I,J+1)+U(I,j)*COSIJ(I,j) ) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL VORTICITY **** -C ********************************************************* - - DO j=2,jm-1 - im1=im - DO i=1,im - TMP1(i,j) = ( P1X(i,j)-P1X(im1,j) )*CX1 - im1=i - ENDDO - - DO I=1,im - TMP2(I,j) = ( P1Y(I,j) -P1Y(I,j-1) )*CY1 - VOR (I,j) = ( TMP1(I,j)-TMP2(I,j) )/(cosij(i,j)) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE AT POLES **** -C ********************************************************* - - DO M=1,2 - JPOLE = 1 + (M-1)*(jm-1) - JPH = 1 + (M-1)*(jm-2) - - SUM11 = 0.0 - DO I=1,im - SUM11 = SUM11 + P1Y(I,JPH) - ENDDO - - DO I=1,im - VOR(I,JPOLE) = - MSGN(M) * C11*SUM11 - ENDDO - ENDDO - - RETURN - END - SUBROUTINE GRADQ (Q,DQDX,DQDY,IM,JM) -C ********************************************************* -C **** **** -C **** THIS PROGRAM CALCULATES THE HORIZONTAL **** -C **** GRADIENT OF THE INPUT FIELD Q **** -C **** **** -C **** ARGUMENTS: **** -C **** Q ....... FIELD TO BE DIFFERENTIATED **** -C **** DQDX .... LONGITUDINAL Q-DERIVATIVE **** -C **** DQDY .... MERIDIONAL Q-DERIVATIVE **** -C **** IM ...... NUMBER OF LONGITUDINAL POINTS **** -C **** JM ...... NUMBER OF LATITUDINAL POINTS **** -C **** **** -C ********************************************************* - - use MAPL_ConstantsMod - implicit none - integer im,jm - - real Q(IM,JM) - real DQDX(IM,JM) - real DQDY(IM,JM) - real Q1X(IM,JM) - real Q2X(IM,JM) - real Q1Y(IM,JM) - real Q2Y(IM,JM) - real acos(JM) - real sinl(IM) - real cosl(IM) - - real cx1,cx2,cy1,cy2,uc,vc,us,vs - real dl,dp,a,pi,fjeq,phi - integer i,j,m,ip1,ip2,jpole,msgn - -C ********************************************************* -C **** INITIALIZATION **** -C ********************************************************* - - a = MAPL_RADIUS - pi = 4.0*atan(1.0) - dl = 2.0*pi/im - dp = pi/(jm-1) - - CX1 = 2.0 / ( 3.0*A*DL) - CX2 = 1.0 / (12.0*A*DL) - CY1 = 2.0 / ( 3.0*A*DP) - CY2 = 1.0 / (12.0*A*DP) - - Q1X(:,:) = 0.0 - Q2X(:,:) = 0.0 - Q1Y(:,:) = 0.0 - Q2Y(:,:) = 0.0 - - fjeq = ( jm+1 )*0.5 - do j=2,jm-1 - phi = dp * (j-fjeq) - acos(j) = 1.0/( cos(phi) ) - enddo - do i=1,im/2 - cosl(i) = -cos((i-1)*dl) - cosl(i+im/2) = -cosl(i) - sinl(i) = -sin((i-1)*dl) - sinl(i+im/2) = -sinl(i) - enddo - -C ********************************************************* -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - do j = 2,jm-1 - i = im-1 - ip1 = im - do ip2 = 1,im - Q1X(i ,j) = Q(ip1,j) + Q(i,j) - Q2X(ip1,j) = Q(ip2,j) + Q(i,j) - i = ip1 - ip1 = ip2 - enddo - enddo - - do j=1,jm-1 - do i=1,im - Q1Y(i,j) = Q(i,j+1) + Q(i,j) - enddo - enddo - - do j=2,jm-1 - do i=1,im - Q2Y(i,j) = Q(i,j+1) + Q(i,j-1) - enddo - enddo - - do i=1,im/2 - Q2Y(i, 1) = Q(i,2) - Q2Y(i,jm) = Q(i,jm-1) - enddo - - do i=1,im/2 - Q2Y(i , 1) = Q(i+im/2,2) + Q2Y(i,1) - Q2Y(i+im/2, 1) = Q2Y(i,1) - Q2Y(i ,jm) = Q(i+im/2,jm-1) + Q2Y(i,jm) - Q2Y(i+im/2,jm) = Q2Y(i,jm) - enddo - -C ********************************************************* -C **** CALCULATE Q-GRADIENTS **** -C ********************************************************* - - do j = 2,jm-1 - i = im-1 - ip1 = im - do ip2 = 1,im - DQDX(ip1,j) = ACOS(j) * ( ( Q1X(ip1,j)-Q1X(i,j) )*CX1 - . - ( Q2X(ip2,j)-Q2X(i,j) )*CX2 ) - i = ip1 - ip1 = ip2 - enddo - enddo - - do j=2,jm-1 - do i=1,im - DQDY(i,j) = ( Q1Y(i,j) -Q1Y(i,j-1) )*CY1 - . - ( Q2Y(i,j+1)-Q2Y(i,j-1) )*CY2 - enddo - enddo - -C ********************************************************* -C **** CALCULATE Q-GRADIENTS (POLES) **** -C ********************************************************* - - do i=1,im/2 - Q1Y(i, 2) = Q(i, 1) + Q(i+im/2,2) - Q1Y(i+im/2, 2) = Q(i+im/2, 1) + Q(i, 2) - Q2Y(i, 1) = Q(i, 1) + Q(i+im/2,3) - Q2Y(i+im/2, 1) = Q(i+im/2, 1) + Q(i, 3) - - Q1Y(i, jm) = Q(i, jm) + Q(i+im/2,jm-1) - Q1Y(i+im/2,jm) = Q(i+im/2,jm) + Q(i, jm-1) - Q2Y(i, jm) = Q(i, jm) + Q(i+im/2,jm-2) - Q2Y(i+im/2,jm) = Q(i+im/2,jm) + Q(i, jm-2) - enddo - - do i=1,im - DQDY(i,jm) = ( Q1Y(i,jm)-Q1Y(i,jm-1) )*CY1 - . - ( Q2Y(i,jm)-Q2Y(i,jm-1) )*CY2 - - DQDY(i, 1) = ( Q1Y(i,1)-Q1Y(i,2) )*CY1 - . - ( Q2Y(i,2)-Q2Y(i,1) )*CY2 - enddo - -C APPLY BOUNDARY CONDITIONS AT THE POLES -C ========================================== - - DO 170 M=1,2 - MSGN = (-1)**M - JPOLE = 1 + (M-1)*(jm - 1) - - VC = 0.0 - VS = 0.0 - DO 180 I=1,IM - VC = VC + DQDY(I,JPOLE)*COSL(I) - VS = VS + DQDY(I,JPOLE)*SINL(I) - 180 CONTINUE - VC = 2.0 * VC / IM - VS = 2.0 * VS / IM - - UC = - MSGN*VS - US = MSGN*VC - - DO 190 I=1,IM - DQDX(I,JPOLE) = US*SINL(I) + UC*COSL(I) - DQDY(I,JPOLE) = VS*SINL(I) + VC*COSL(I) - 190 CONTINUE - - 170 CONTINUE - - RETURN - END - SUBROUTINE LAPLACIAN (DIV,VELP,im,jnp) - - integer IM,JNP - real DIV(IM,JNP) - real VELP(IM,JNP) - - real*8, allocatable :: VP(:,:) - real*8, allocatable :: w(:) - real*8, allocatable :: bdtf(:) - real*8, allocatable :: bdts(:) - real*8, allocatable :: bdps(:) - real*8, allocatable :: bdpf(:) - real*8 ts,tf,ps,pf,elmbda,pertrb,pi - - imp = im+1 - iwk = 11*jnp+6*imp - - allocate ( vp(jnp,imp) ) - allocate ( w(iwk) ) - allocate ( bdtf(imp) ) - allocate ( bdts(imp) ) - allocate ( bdps(jnp) ) - allocate ( bdpf(jnp) ) - - vp(:,:)=0.0 - w(:)=0.0 - bdtf(:)=0.0 - bdts(:)=0.0 - bdps(:)=0.0 - bdpf(:)=0.0 - -c Transpose the input array -c ------------------------- - do j=1,jnp - do i=1,im - vp(j,i) = div(i,j) - enddo - vp(j,imp) = vp(j,1) - enddo - -C === SET THE INPUT VARIABLES - RAD = 6371000.0 - PI = 3.14159265358979D0 - INTL=0 - TS=0.0 - TF=PI - M=JNP-1 - MBDCND=9 - PS=0.0 - PF=2*PI - N=IM - NBDCND=0 - ELMBDA=0 - PERTRB=0 - IDIMF=M+1 - - CALL PWSSSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS, - * BDPF,ELMBDA,VP,IDIMF,PERTRB,IERROR,W) - - if( ierror.ne.0 ) then - print *, 'PWSSSP IERROR = ',ierror - stop - endif - -c Scale by earth radius -c --------------------- - do j=1,jnp - do i=1,im - VELP(I,J) = VP(J,I) * RAD * RAD - enddo - enddo - -c Remove global mean -c ------------------ - CALL ZEROG (VELP,IM,JNP) - - deallocate ( vp ) - deallocate ( w ) - deallocate ( bdtf ) - deallocate ( bdts ) - deallocate ( bdps ) - deallocate ( bdpf ) - RETURN - END - - SUBROUTINE ZEROG (VEL,IM,JNP) - integer IM,JNP - real VEL(IM,JNP) - - pi = 4.0*atan(1.0) - dl = 2*pi/im - dp = pi/(jnp-1) - cap = 1-cos(0.5*dp) - -c Ensure unique pole values -c ------------------------- - sum1 = 0.0 - sum2 = 0.0 - do i=1,im - sum1 = sum1 + vel(i,1) - sum2 = sum2 + vel(i,jnp) - enddo - sum1 = sum1/im - sum2 = sum2/im - do i=1,im - vel(i,1) = sum1 - vel(i,jnp) = sum2 - enddo - -c Compute global average -c ---------------------- - sum1 = 0.0 - sum2 = 0.0 - do i=1,im - sum1 = sum1 + cap*vel(i,1) - sum2 = sum2 + cap - enddo - - do j=2,jnp-1 - cosj = cos( -pi/2 + (j-1)*dp ) - do i=1,im - sum1 = sum1 + cosj*dp*vel(i,j) - sum2 = sum2 + cosj*dp - enddo - enddo - - do i=1,im - sum1 = sum1 + cap*vel(i,jnp) - sum2 = sum2 + cap - enddo - - qave = sum1/sum2 - - do j=1,jnp - do i=1,im - vel(i,j) = vel(i,j)-qave - enddo - enddo - -c print *, 'Remove Global Average: ', qave - - RETURN - END diff --git a/GEOS_Util/post/rs2hdf.F b/GEOS_Util/post/rs2hdf.F deleted file mode 100644 index 9a741836..00000000 --- a/GEOS_Util/post/rs2hdf.F +++ /dev/null @@ -1,1391 +0,0 @@ - program main - implicit none - -! ********************************************************************** -! ********************************************************************** -! **** **** -! **** Program to create an eta_hdf file from GEOS5 restarts **** -! **** **** -! ********************************************************************** -! ********************************************************************** - - - character*256 dynrst, moistrst, topofile, bkgeta,tag - - integer headr1(6) - integer headr2(5) - integer nymd,nhms - integer im,jm,lm - integer imo,jmo - real*8 undef,rgas,rvap,eps,grav - - -! restart variables and topography -! -------------------------------- - real*8, allocatable :: dp(:,:,:) - real*8, allocatable :: u(:,:,:) - real*8, allocatable :: v(:,:,:) - real*8, allocatable :: th(:,:,:) - real*8, allocatable :: thv(:,:,:) - real*8, allocatable :: pk(:,:,:) - real*8, allocatable :: ple(:,:,:) - real*8, allocatable :: q(:,:,:) - real*8, allocatable :: ps(:,:) - real*8, allocatable :: ak(:) - real*8, allocatable :: bk(:) - - real*8, allocatable :: phis (:,:) - real*8, allocatable :: topo_std (:,:) - real*8, allocatable :: oro (:,:) - real*8, allocatable :: frland (:,:) - real*8, allocatable :: frlandice(:,:) - real*8, allocatable :: frlake (:,:) - real*8, allocatable :: frocean (:,:) - real*8, allocatable :: u10m (:,:) - real*8, allocatable :: v10m (:,:) - real*8, allocatable :: ts (:,:) - real*8, allocatable :: qs (:,:) - real*8, allocatable :: snowmass (:,:) - real*8, allocatable :: wet1 (:,:) - real*8, allocatable :: tsoil1 (:,:) - real*8, allocatable :: oz (:,:,:) - - real*4, allocatable :: dum(:,:) - - character*256, allocatable :: arg(:) - character*5 extn - character*8 date - character*2 hour - integer n,nargs,i,j,L,nymd0,nhms0 - integer precision - logical file_exists - logical dtoa - -! ********************************************************************** -! **** Initialize Filenames **** -! ********************************************************************** - - dtoa = .false. - undef = 1.0e15 - tag = 'geos5' - dynrst = 'xxx' - moistrst = 'xxx' - topofile = 'xxx' - nymd0 = -999 - nhms0 = -999 - imo = -999 - jmo = -999 - precision = 0 ! 32-bit: 0, 64-bit: 1 - extn = 'nc4' - - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage() - else - - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-h' ) call usage() - if( trim(arg(n)).eq.'-help' ) call usage() - if( trim(arg(n)).eq.'-H' ) call usage() - if( trim(arg(n)).eq.'-Help' ) call usage() - if( trim(arg(n)).eq.'-tag' ) then - tag = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-dynrst' ) then - dynrst = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-topo' ) then - topofile = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-moistrst' ) then - moistrst = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-dtoa' ) dtoa = .true. - if( trim(arg(n)).eq.'-im' ) read(arg(n+1),*) imo - if( trim(arg(n)).eq.'-jm' ) read(arg(n+1),*) jmo - if( trim(arg(n)).eq.'-nymd' ) read(arg(n+1),*) nymd0 - if( trim(arg(n)).eq.'-nhms' ) read(arg(n+1),*) nhms0 - if( trim(arg(n)).eq.'-precision' ) read(arg(n+1),*) precision - if( trim(arg(n)).eq.'-ext' ) read(arg(n+1),*) extn - enddo - endif - - if( trim(dynrst) .eq.'xxx' .or. - . trim(moistrst).eq.'xxx' ) then - print * - call usage() - endif - - print * - print *, ' tag: ',trim(tag) - print *, ' dyn restart filename: ',trim(dynrst) - print *, 'moist restart filename: ',trim(moistrst) - if( trim(topofile).ne.'xxx' ) then - print *, ' topo filename: ',trim(topofile) - endif - -! ********************************************************************** -! **** Read dycore internal Restart **** -! ********************************************************************** - - inquire ( file=trim(dynrst), exist=file_exists ) - if( file_exists ) then - open (10,file=trim(dynrst),form='unformatted',access='sequential') - read (10) headr1 - read (10) headr2 - - if( nymd0.ne.-999 ) then - nymd = nymd0 - else - nymd = headr1(1)*10000 + headr1(2)*100 + headr1(3) - endif - if( nhms0.ne.-999 ) then - nhms = nhms0 - else - nhms = headr1(4)*10000 + headr1(5)*100 + headr1(6) - endif - - im = headr2(1) - jm = headr2(2) - lm = headr2(3) - if( imo .eq. -999 ) imo = im - if( jmo .eq. -999 ) jmo = jm - - print *, ' input resolution: ',im,jm,lm - print *, ' output resolution: ',imo,jmo,lm - print *, ' date: ',nymd,nhms - if( precision.eq.0 ) then - print *, ' precision: 0 (32-bit)' - endif - if( precision.eq.1 ) then - print *, ' precision: 1 (64-bit)' - endif - print * - - allocate ( u(im,jm,lm) ) - allocate ( v(im,jm,lm) ) - allocate ( th(im,jm,lm) ) - allocate ( thv(im,jm,lm) ) - allocate ( dp(im,jm,lm) ) - allocate ( pk(im,jm,lm) ) - allocate ( ple(im,jm,lm+1) ) - allocate ( ps(im,jm) ) - allocate ( ak(lm+1) ) - allocate ( bk(lm+1) ) - - read (10) ak - read (10) bk - - do L=1,lm - read(10) (( u(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm - read(10) (( v(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm - read(10) (( th(i,j,L),i=1,im),j=1,jm) ! Note: GEOS-5 variable is DRY potential temperature - enddo - do L=1,lm+1 - read(10) ((ple(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm - read(10) (( pk(i,j,L),i=1,im),j=1,jm) - enddo - - close (10) - - ps(:,:) = ple(:,:,lm+1) - do L=lm,1,-1 - dp(:,:,L) = ple(:,:,L+1) - ple(:,:,L) - enddo - else - print *, trim(dynrst),' does not exist' - stop - endif - - print * - write(6,500) - 500 format(2x,' k ',' A(k) ',2x,' B(k) ',2x,' Pref ',2x,' DelP',/, - . 1x,'----',3x,'----------',2x,'--------',2x,'----------',2x,'---------' ) - L=1 - write(6,501) L,ak(L)*0.01, bk(L), ak(L)*0.01 + 1000.0*bk(L) - do L=2,lm+1 - write(6,502) L,ak(L)*0.01, bk(L), ak(L)*0.01 + 1000.0*bk(L), - . (ak(L)-ak(L-1))*0.01 + 1000.0*(bk(L)-bk(L-1)) - enddo - - print * - 501 format(2x,i3,2x,f10.6,2x,f8.4,2x,f10.4) - 502 format(2x,i3,2x,f10.6,2x,f8.4,2x,f10.4,3x,f8.4) - -! ********************************************************************** -! **** Read moist internal Restart **** -! ********************************************************************** - - allocate ( q(im,jm,lm) ) - allocate ( dum(im,jm) ) - - inquire ( file=trim(moistrst), exist=file_exists ) - if( file_exists ) then - open (10,file=trim(moistrst),form='unformatted',access='sequential') - do L=1,lm - read(10) dum - q(:,:,L) = dum(:,:) ! First moist variable is SPHU - enddo - close (10) - endif - -! ********************************************************************** -! **** Read topo file **** -! ********************************************************************** - - allocate ( phis (im,jm) ) - allocate ( topo_std (im,jm) ) - allocate ( oro (im,jm) ) - allocate ( frland (im,jm) ) - allocate ( frlandice(im,jm) ) - allocate ( frlake (im,jm) ) - allocate ( frocean (im,jm) ) - allocate ( u10m (im,jm) ) - allocate ( v10m (im,jm) ) - allocate ( ts (im,jm) ) - allocate ( qs (im,jm) ) - allocate ( snowmass (im,jm) ) - allocate ( wet1 (im,jm) ) - allocate ( tsoil1 (im,jm) ) - allocate ( oz (im,jm,lm) ) - - phis = 0.0 - inquire ( file=trim(topofile), exist=file_exists ) - if( file_exists ) then - open (10,file=trim(topofile),form='unformatted',access='sequential') - print *, 'Reading topography from: ',trim(topofile) - read(10) dum ; phis = dum - close (10) - endif - -! ********************************************************************** -! **** Adjust Fields **** -! ********************************************************************** - - grav = 9.8 - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - thv = th*(1+eps*q) ! Construct virtual potential temperature - - phis = phis*grav - topo_std = 0.0 ! Analysis needs to read it, but doesn't use it - snowmass = snowmass/1000 ! Convert millimeter to meter - oz = oz/1.655e-6 - - oro = 1.0 ! Land - where ( frocean >= 0.6 .or. frlake >= 0.6 ) oro = 0.0 ! Water - where ( oro == 0.0 .and. ts <= 272.81 ) oro = 2.0 ! Ice - - do j=1,jm - do i=1,im - wet1(i,j) = ( frland(i,j)*wet1(i,j) + 1.0-frland(i,j) ) - if( oro(i,j) == 1.0 ) then - tsoil1(i,j) = tsoil1(i,j) + 273.16 - else - tsoil1(i,j) = undef - endif - enddo - enddo - - where ( frlandice == 1.0 ) snowmass = 4.0 - -! ********************************************************************** -! **** Write Analysis BKG Files **** -! ********************************************************************** - - write(date,101) nymd - write(hour,102) nhms/10000 - 101 format(i8.8) - 102 format(i2.2) - - bkgeta = trim(tag) // '.bkg.eta.' // date // '_' // hour // 'z.'//trim(extn) - - print *, 'Creating ',trim(tag),' bkg.eta HDF file: ',trim(bkgeta) - print * - - call hflip ( phis,im,jm, 1 ) - call hflip ( ps ,im,jm, 1 ) - call hflip ( dp ,im,jm,lm ) - call hflip ( u ,im,jm,lm ) - call hflip ( v ,im,jm,lm ) - call hflip ( thv ,im,jm,lm ) - call hflip ( q ,im,jm,lm ) - call hflip ( oz ,im,jm,lm ) - - call hflip ( u10m ,im,jm, 1 ) - call hflip ( v10m ,im,jm, 1 ) - call hflip ( ts ,im,jm, 1 ) - call hflip ( qs ,im,jm, 1 ) - call hflip ( snowmass ,im,jm, 1 ) - call hflip ( wet1 ,im,jm, 1 ) - call hflip ( tsoil1 ,im,jm, 1 ) - call hflip ( oro ,im,jm, 1 ) - call hflip ( frland ,im,jm, 1 ) - call hflip ( frlandice,im,jm, 1 ) - call hflip ( frlake ,im,jm, 1 ) - call hflip ( frocean ,im,jm, 1 ) - - call dynhdf ( bkgeta,nymd,nhms,im,jm,lm,ak,bk, - . phis,topo_std,ts,oro, - . ps,dp,u,v,thv,q,oz,precision,imo,jmo,dtoa ) - - stop - end - - subroutine minmax (q,im,jm,L) - real*8 q(im,jm) - qmin = q(1,1) - qmax = q(1,1) - do j=1,jm - do i=1,im - qmin = min( qmin,q(i,j) ) - qmax = max( qmax,q(i,j) ) - enddo - enddo - print *, 'L: ',L,' qmin: ',qmin,' qmax: ',qmax - return - end - - subroutine dynhdf ( filename,nymd,nhms,im,jm,lm,ak,bk, - . phis,topo_std,ts,oro,ps,dp,u,v,thv,q,oz,precision,imo,jmo,dtoa ) - implicit none - integer im,jm,lm,nymd,nhms - integer imo,jmo - real*8 sump(im,jm) - real*8 phis(im,jm) - real*8 slp(im,jm) - real*8 ps(im,jm) - real*8 ts(im,jm) - real*8 oro(im,jm) - real*8 topo_std(im,jm) - real*8 dp(im,jm,lm) - real*8 u(im,jm,lm) - real*8 v(im,jm,lm) - real*8 t(im,jm,lm) - real*8 thv(im,jm,lm) - real*8 q(im,jm,lm) - real*8 oz(im,jm,lm) - real*8 pk(im,jm,lm) - real*8 pke(im,jm,lm+1) - real*8 ple(im,jm,lm+1) - real*8 phi(im,jm,lm+1) - real*8 ak(lm+1) - real*8 bk(lm+1) - - real lats(jmo) - real lons(imo) - real levs(lm) - real*8 latsd(jmo) - real*8 lonsd(imo) - - logical dtoa - real ptop,dlon,dlat,undef,pint - integer i,j,L,timeinc,rc,ks - character*80 filename - integer nvars,fid,precision - - character*256 levunits - character*256 title - character*256 source - character*256 contact - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - integer, allocatable :: lmvar(:) - real, allocatable :: v_range(:,:) - real, allocatable :: p_range(:,:) - - real, allocatable :: dum1(:) - real, allocatable :: dum2(:,:) - real, allocatable :: dum3(:,:,:) - real, allocatable :: dumu(:,:,:) - real, allocatable :: dumv(:,:,:) - real rgas,rvap,eps,kappa,grav,cp - - real dpref - dpref(L) = ( ak(L+1)-ak(L) ) + ( bk(L+1)-bk(L) ) * 98400.0 - - undef = 1.0e15 - timeinc = 060000 - - cp = 1004.16 - rgas = 8314.3/28.97 - rvap = 8314.3/18.01 - eps = rvap/rgas-1.0 - kappa = 2.0/7.0 - grav = 9.81 - -! String and vars settings -! ------------------------ - title = 'GEOS5 Dynamics State Vector (Hybrid Coordinates)' - source = 'Goddard Modeling and Assimilation Office, NASA/GSFC' - contact = 'data@gmao.gsfc.nasa.gov' - levunits = 'hPa' - - nvars = 14 - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - allocate ( v_range(2,nvars) ) - allocate ( p_range(2,nvars) ) - - vname(01) = 'phis' - vtitle(01) = 'Topography geopotential' - vunits(01) = 'meter2/sec2' - lmvar(01) = 0 - - vname(02) = 'hs_stdv' - vtitle(02) = 'Topography Height Standard Deviation' - vunits(02) = 'm' - lmvar(02) = 0 - - vname(03) = 'ts' - vtitle(03) = 'Surface temperature' - vunits(03) = 'K' - lmvar(03) = 0 - - vname(04) = 'lwi' - vtitle(04) = 'Land-water-ice mask' - vunits(04) = 'na' - lmvar(04) = 0 - - vname(05) = 'ps' - vtitle(05) = 'Surface Pressure' - vunits(05) = 'Pa' - lmvar(05) = 0 - - vname(06) = 'delp' - vtitle(06) = 'Pressure Thickness' - vunits(06) = 'Pa' - lmvar(06) = lm - - vname(07) = 'uwnd' - vtitle(07) = 'Zonal Wind' - vunits(07) = 'm/s' - lmvar(07) = lm - - vname(08) = 'vwnd' - vtitle(08) = 'Meridional Wind' - vunits(08) = 'm/s' - lmvar(08) = lm - - vname(09) = 'theta' - vtitle(09) = 'Scaled Virtual Potential Temperature' - vunits(09) = 'K/Pa^kappa' - lmvar(09) = lm - - vname(10) = 'sphu' - vtitle(10) = 'Specific Humidity' - vunits(10) = 'kg/kg' - lmvar(10) = lm - - vname(11) = 'ozone' - vtitle(11) = 'Ozone Mixing Ratio' - vunits(11) = 'kg/kg' - lmvar(11) = lm - - vname(12) = 'slp' - vtitle(12) = 'Sea Level Pressure' - vunits(12) = 'Pa' - lmvar(12) = 0 - - vname(13) = 'tmpu' - vtitle(13) = 'Temperature' - vunits(13) = 'K' - lmvar(13) = lm - - vname(14) = 'zle' - vtitle(14) = 'Edge Heights' - vunits(14) = 'm' - lmvar(14) = lm - - v_range(:,:) = undef - p_range(:,:) = undef - -! Compute grid -! ------------ - dlon = 360.0/ imo - dlat = 180.0/(jmo-1) - - do j=1,jmo - latsd(j) = -90.0 + (j-1)*dlat - enddo - do i=1,imo - lonsd(i) = 0.0 + (i-1)*dlon - enddo - do L=1,lm - levs(L) = L - enddo - lats = latsd - lons = lonsd - - sump(:,:) = 0.0 - do L=1,lm - sump(:,:) = sump(:,:) + dp(:,:,L) - enddo - sump(:,:) = ps(:,:)-sump(:,:) -! print *, 'ptop values (mb): ',sump/100 - ptop = sump(1,1) - - ptop = ak(1) - levs(1) = ptop + 0.5 * dpref(1) - do L = 2, lm - levs(L) = levs(L-1) + 0.5 * ( dpref(L-1) + dpref(L) ) - enddo - levs(1:lm) = levs(1:lm) / 100.0 - -! Create Dry Temperature and SLP -! ------------------------------ - do L=1,lm+1 - ple(:,:,L) = ak(L) + ps(:,:)*bk(L) - enddo - pke(:,:,:) = ple(:,:,:)**kappa - phi(:,:,lm+1) = phis(:,:) - do L=lm,1,-1 - phi(:,:,L) = phi(:,:,L+1) + cp*thv(:,:,L)*( pke(:,:,L+1)-pke(:,:,L) ) - pk(:,:,L) = ( pke(:,:,L+1)-pke(:,:,L) ) - . / ( kappa*log(ple(:,:,L+1)/ple(:,:,L)) ) - enddo - t = thv*pk - call get_slp ( ps,phis,slp,ple,pk,t,rgas,grav,im,jm,lm ) - t = t/(1+eps*q) - phi = phi/grav - -! Create GFIO file -! ---------------- - call GFIO_Create ( filename, title, source, contact, undef, - . imo, jmo, lm, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vname, vtitle, vunits, lmvar, - . v_range, p_range, precision, - . fid, rc ) -! Write GFIO data -! --------------- - allocate( dum1(lm+1) ) - allocate( dum2(im,jm) ) - allocate( dum3(im,jm,lm) ) - allocate( dumu(im,jm,lm) ) - allocate( dumv(im,jm,lm) ) - - dumu = u - dumv = v - if( dtoa) call dtoa_winds ( dumu,dumv,dumu,dumv,im,jm,lm ) - - dum2 = phis ; call putVar ( fid,vname(01),nymd,nhms,im,jm,imo,jmo,0, 1,dum2,rc ) - dum2 = topo_std ; call putVar ( fid,vname(02),nymd,nhms,im,jm,imo,jmo,0, 1,dum2,rc ) - dum2 = ts ; call putVar ( fid,vname(03),nymd,nhms,im,jm,imo,jmo,0, 1,dum2,rc ) - dum2 = oro ; call putVar ( fid,vname(04),nymd,nhms,im,jm,imo,jmo,0, 1,dum2,rc ) - dum2 = ps ; call putVar ( fid,vname(05),nymd,nhms,im,jm,imo,jmo,0, 1,dum2,rc ) - dum3 = dp ; call putVar ( fid,vname(06),nymd,nhms,im,jm,imo,jmo,1,lm,dum3,rc ) - dum3 = dumu ; call putVar ( fid,vname(07),nymd,nhms,im,jm,imo,jmo,1,lm,dum3,rc ) - dum3 = dumv ; call putVar ( fid,vname(08),nymd,nhms,im,jm,imo,jmo,1,lm,dum3,rc ) - dum3 = thv ; call putVar ( fid,vname(09),nymd,nhms,im,jm,imo,jmo,1,lm,dum3,rc ) - dum3 = q ; call putVar ( fid,vname(10),nymd,nhms,im,jm,imo,jmo,1,lm,dum3,rc ) - dum3 = oz ; call putVar ( fid,vname(11),nymd,nhms,im,jm,imo,jmo,1,lm,dum3,rc ) - dum2 = slp ; call putVar ( fid,vname(12),nymd,nhms,im,jm,imo,jmo,0, 1,dum2,rc ) - dum3 = t ; call putVar ( fid,vname(13),nymd,nhms,im,jm,imo,jmo,1,lm,dum3,rc ) - - dum3 = phi(:,:,1:lm) ; call putVar ( fid,vname(14),nymd,nhms,im,jm,imo,jmo,1,lm,dum3,rc ) - -! Write GFIO global attributes -! ---------------------------- - ks = 0 - pint = ak(ks+1) - call GFIO_PutIntAtt ( fid,'nstep', 1,ks ,0 ,rc ) - call GFIO_PutRealAtt ( fid,'ptop', 1,ptop ,precision,rc ) - call GFIO_PutRealAtt ( fid,'pint', 1,pint ,precision,rc ) - call GFIO_PutIntAtt ( fid,'ks', 1,ks ,0 ,rc ) - dum1 = ak ; call GFIO_PutRealAtt ( fid,'ak', lm+1,dum1 ,precision,rc ) - dum1 = bk ; call GFIO_PutRealAtt ( fid,'bk', lm+1,dum1 ,precision,rc ) - - - call gfio_close ( fid,rc ) - return - end - - subroutine putvar (id,name,nymd,nhms,im,jm,imo,jmo,lbeg,lm,q,rc) - implicit none - integer id,nymd,nhms,im,jm,lbeg,lm,rc - integer imo,jmo - real undef - real q (im ,jm ,lm) - real qo(imo,jmo,lm) - character(*) name - undef = 1e15 - if( im.ne.imo .or. jm.ne.jmo ) then - call hinterp ( q,im,jm,qo,imo,jmo,lm,undef ) - else - qo = q - endif - call Gfio_putVar ( id,name,nymd,nhms,imo,jmo,lbeg,lm,qo,rc ) - return - end - - subroutine sfchdf ( filename,nymd,nhms,im,jm,lm, - . phis,u10m,v10m,ts,qs, - . snomas,wet1,tsoil1, - . frland,frlandice,frlake,frocean,oro,precision ) - implicit none - integer im,jm,lm,nymd,nhms - real*8 phis(im,jm) - real*8 u10m(im,jm) - real*8 v10m(im,jm) - real*8 ts(im,jm) - real*8 qs(im,jm) - real*8 snomas(im,jm) - real*8 wet1(im,jm) - real*8 tsoil1(im,jm) - real*8 frland(im,jm) - real*8 frlandice(im,jm) - real*8 frlake(im,jm) - real*8 frocean(im,jm) - real*8 oro(im,jm) - - real lats(jm) - real lons(im) - real levs(lm) - real*8 latsd(jm) - real*8 lonsd(im) - - real*8 dlon,dlat,undef - integer i,j,L,timeinc,rc - character*80 filename - integer nvars,fid,precision - - character*256 levunits - character*256 title - character*256 source - character*256 contact - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - integer, allocatable :: lmvar(:) - real, allocatable :: v_range(:,:) - real, allocatable :: p_range(:,:) - - undef = 1.0e15 - timeinc = 060000 - -! String and vars settings -! ------------------------ - title = 'GEOS5 Dynamics State Vector (Hybrid Coordinates)' - source = 'Goddard Modeling and Assimilation Office, NASA/GSFC' - contact = 'data@gmao.gsfc.nasa.gov' - levunits = 'hPa' - - nvars = 13 - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( lmvar(nvars) ) - allocate ( v_range(2,nvars) ) - allocate ( p_range(2,nvars) ) - - vname(01) = 'PHIS' - vtitle(01) = 'Topography geopotential' - vunits(01) = 'meter2/sec2' - lmvar(01) = 0 - - vname(02) = 'TSKIN' - vtitle(02) = 'Surface skin temperature' - vunits(02) = 'K' - lmvar(02) = 0 - - vname(03) = 'QS' - vtitle(03) = 'Surface Specific Humidity' - vunits(03) = 'kg/kg' - lmvar(03) = 0 - - vname(04) = 'U10M' - vtitle(04) = '10 meter U Wind' - vunits(04) = 'm/s' - lmvar(04) = 0 - - vname(05) = 'V10M' - vtitle(05) = '10 meter V Wind' - vunits(05) = 'm/s' - lmvar(05) = 0 - - vname(06) = 'SNOWDP' - vtitle(06) = 'Snow Depth Water Equivalent' - vunits(06) = 'm' - lmvar(06) = 0 - - vname(07) = 'GWETTOP' - vtitle(07) = 'Top soil layer wetness' - vunits(07) = '0-1' - lmvar(07) = 0 - - vname(08) = 'TSOIL1' - vtitle(08) = 'Top soil layer wetness' - vtitle(08) = 'Surface skin temperature' - vunits(08) = 'K' - lmvar(08) = 0 - - vname(09) = 'FRLAND' - vtitle(09) = 'Fraction of Land' - vunits(09) = '0-1' - lmvar(09) = 0 - - vname(10) = 'FRLANDICE' - vtitle(10) = 'Fraction of Land Ice' - vunits(10) = '0-1' - lmvar(10) = 0 - - vname(11) = 'FRLAKE' - vtitle(11) = 'Fraction of Lake' - vunits(11) = '0-1' - lmvar(11) = 0 - - vname(12) = 'FROCEAN' - vtitle(12) = 'Fraction of Ocean' - vunits(12) = '0-1' - lmvar(12) = 0 - - vname(13) = 'ORO' - vtitle(13) = 'Water(0) Land(1) Ice(2) Flag' - vunits(13) = '0-1-2' - lmvar(13) = 0 - - v_range(:,:) = undef - p_range(:,:) = undef - -! Compute grid -! ------------ - dlon = 360.0/ im - dlat = 180.0/(jm-1) - - do j=1,jm - latsd(j) = -90.0 + (j-1)*dlat - enddo - do i=1,im - lonsd(i) = 0.0 + (i-1)*dlon - enddo - do L=1,lm - levs(L) = L - enddo - lats = latsd - lons = lonsd - -! Create GFIO file -! ---------------- - call GFIO_Create ( filename, title, source, contact, undef, - . im, jm, lm, lons, lats, levs, levunits, - . nymd, nhms, timeinc, - . nvars, vname, vtitle, vunits, lmvar, - . v_range, p_range, precision, - . fid, rc ) -! Write GFIO data -! --------------- - call Gfio_putVar ( fid,vname(01),nymd,nhms,im,jm,0, 1,phis ,rc ) - call Gfio_putVar ( fid,vname(02),nymd,nhms,im,jm,0, 1,ts ,rc ) - call Gfio_putVar ( fid,vname(03),nymd,nhms,im,jm,0, 1,qs ,rc ) - call Gfio_putVar ( fid,vname(04),nymd,nhms,im,jm,0, 1,u10m ,rc ) - call Gfio_putVar ( fid,vname(05),nymd,nhms,im,jm,0, 1,v10m ,rc ) - call Gfio_putVar ( fid,vname(06),nymd,nhms,im,jm,0, 1,snomas ,rc ) - call Gfio_putVar ( fid,vname(07),nymd,nhms,im,jm,0, 1,wet1 ,rc ) - call Gfio_putVar ( fid,vname(08),nymd,nhms,im,jm,0, 1,tsoil1 ,rc ) - call Gfio_putVar ( fid,vname(09),nymd,nhms,im,jm,0, 1,frland ,rc ) - call Gfio_putVar ( fid,vname(10),nymd,nhms,im,jm,0, 1,frlandice,rc ) - call Gfio_putVar ( fid,vname(11),nymd,nhms,im,jm,0, 1,frlake ,rc ) - call Gfio_putVar ( fid,vname(12),nymd,nhms,im,jm,0, 1,frocean ,rc ) - call Gfio_putVar ( fid,vname(13),nymd,nhms,im,jm,0, 1,oro ,rc ) - -! Write GFIO global attributes -! ---------------------------- -! call GFIO_PutRealAtt ( fid,'ptop', 1,ptop ,precision,rc ) - - call gfio_close ( fid,rc ) - return - end - - subroutine hflip ( q,im,jm,lm ) - implicit none - integer im,jm,lm,i,j,L - real*8 q(im,jm,lm),dum(im) - do L=1,lm - do j=1,jm - do i=1,im/2 - dum(i) = q(i+im/2,j,L) - dum(i+im/2) = q(i,j,L) - enddo - q(:,j,L) = dum(:) - enddo - enddo - return - end - - subroutine get_slp ( ps,phis,slp,pe,pk,tv,rgas,grav,im,jm,km ) - implicit none - integer im,jm,km - real grav - real rgas - real*8 pk(im,jm,km) ! layer-mean P**kappa - real*8 tv(im,jm,km) ! layer-mean virtual Temperature - real*8 pe(im,jm,km+1) ! press at layer edges (Pa) - real*8 ps(im,jm) ! surface pressure (Pa) - real*8 phis(im,jm) ! surface geopotential - real*8 slp(im,jm) ! sea-level pressure (hPa) - - real p_offset - real p_bot - real tstar ! extrapolated temperature (K) - real tref ! Reference virtual temperature (K) - real pref ! Reference pressure level (Pa) - real pkref ! Reference pressure level (Pa) ** kappa - real dp1, dp2 - real factor, yfactor - real gg - real gamma - integer k_bot, k, k1, k2, i,j - - gamma = 6.5e-3 - gg = gamma / grav - factor = grav / ( Rgas * gamma ) - yfactor = Rgas * gg - p_offset = 15000. ! 150 hPa above surface - - do j=1,jm - do i=1,im - p_bot = ps(i,j) - p_offset - k_bot = -1 - do k = km, 2, -1 - if ( pe(i,j,k+1) .lt. p_bot ) then - k_bot = k - go to 123 - endif - enddo -123 continue - k1 = k_bot - 1 - k2 = k_bot - dp1 = pe(i,j,k_bot) - pe(i,j,k_bot-1) - dp2 = pe(i,j,k_bot+1) - pe(i,j,k_bot) - pkref = ( pk(i,j,k1)*dp1 + pk(i,j,k2)*dp2 ) / (dp1+dp2) - tref = ( tv(i,j,k1)*dp1 + tv(i,j,k2)*dp2 ) / (dp1+dp2) - pref = 0.5 * ( pe(i,j,k_bot+1) + pe(i,j,k_bot-1) ) - tstar = tref*( ps(i,j)/pref )**yfactor - slp(i,j) = ps(i,j)*( 1.0+gg*phis(i,j)/tstar )**factor - enddo - enddo - - return - end - - subroutine usage() - print *, "Usage: " - print * - print *, " rs2hdf.x [-dynrst dynrst_fname] Default: fvcore_internal_restart" - print *, " [-moistrst moistrst_fname] Default: moist_internal_restart" - print *, " [-topo topo_fname] Optional Topography File" - print *, " [-tag tag] Optional Tag" - print *, " [-nymd yyyymmdd] Optional Overriding DateStamp for Output" - print *, " [-nhms hhmmss] Optional Overriding TimeStamp for Output" - print *, " [-ext filename extension] Optional Overriding Output filename extension" - print * - print *, "where:" - print *, "-----" - print *, " -dynrst dynrst_fname: Filename of dynamics internal restart" - print *, " -moistrst moistrst_fname: Filename of moist internal restart" - print * - print *, "creates:" - print *, "-------" - print *, " tag.bkg.eta.yyyymmdd_hhz.nc4" - print * - error stop 7 - end - - subroutine dtoa_winds ( ud,vd,ua,va,im,jm,lm ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded winds **** -C **** to 'A' gridded winds **** -C **** using simple averaging. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C ****************************************************************** - - real ua(im,jm,lm), ud(im,jm,lm) - real va(im,jm,lm), vd(im,jm,lm) - - real uz(im,jm) - real vz(im,jm) - real sinx(im/2) - real cosx(im/2) - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - - do i=1,imh - sinx(i) = sin( -pi + (i-1)*dx ) - cosx(i) = cos( -pi + (i-1)*dx ) - enddo - - do L=1,lm - - uz(:,:) = ud(:,:,L) - vz(:,:) = vd(:,:,L) - -C ********************************************************* -C **** Average D-Grid Winds **** -C ********************************************************* - - do j=2,jm-1 - i=im - do ip1=1,im - ua(i,j,L) = ( uz(i,j)+uz(i,j+1) )*0.5 - va(i,j,L) = ( vz(i,j)+vz(ip1,j) )*0.5 - i=ip1 - enddo - enddo - -C ********************************************************* -C **** Fix A-Grid Pole Winds **** -C ********************************************************* - - do m=1,2 - n = (-1)**m - jpole = 1 + (m-1)*(jm-1) - jstar = 2 + (m-1)*(jm-3) - - upole = 0.0 - vpole = 0.0 - do i=1,imh - upole = upole + ( ua(i+imh,jstar,L)-ua(i,jstar,L) )*sinx(i) - . + n*( va(i+imh,jstar,L)-va(i,jstar,L) )*cosx(i) - vpole = vpole - n*( ua(i+imh,jstar,L)-ua(i,jstar,L) )*cosx(i) - . + ( va(i+imh,jstar,L)-va(i,jstar,L) )*sinx(i) - enddo - upole = upole / im - vpole = vpole / im - do i=1,imh - ua(i ,jpole,L) = - upole*sinx(i) + n*vpole*cosx(i) - va(i ,jpole,L) = - n*upole*cosx(i) - vpole*sinx(i) - ua(i+imh,jpole,L) = - ua(i,jpole,L) - va(i+imh,jpole,L) = - va(i,jpole,L) - enddo - enddo - -C ********************************************************* -C **** End Level Loop **** -C ********************************************************* - - enddo - - return - end - subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef ) - implicit none - integer iin,jin, iout,jout, mlev - real qin(iin,jin,mlev), qout(iout,jout,mlev) - real undef,pi,dlin,dpin,dlout,dpout - real dlam(iin), lons(iout*jout), lon - real dphi(jin), lats(iout*jout), lat - integer i,j,loc - - pi = 4.0*atan(1.0) - dlin = 2*pi/iin - dpin = pi/(jin-1) - dlam(:) = dlin - dphi(:) = dpin - - dlout = 2*pi/iout - dpout = pi/(jout-1) - - loc = 0 - do j=1,jout - do i=1,iout - loc = loc + 1 - lon = -pi + (i-1)*dlout - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jout - lat = -pi/2.0 + (j-1)*dpout - do i=1,iout - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call interp_h ( qin,iin,jin,mlev,dlam,dphi, - . qout,iout*jout,lons,lats,undef ) - - return - end subroutine hinterp - - subroutine interp_h ( q_cmp,im,jm,lm,dlam,dphi, - . q_geo,irun,lon_geo,lat_geo,undef ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - -c Local Variables -c --------------- - integer i,j,l - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real ap1, ap0, am1, am2 - real bp1, bp0, bm1, bm2 - - real lon_cmp(im) - real lat_cmp(jm) - real q_tmp(irun) - - real pi,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp - real lam_cmp - real phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - do i=1,irun - lam_cmp = lon_geo(i) - phi_cmp = lat_geo(i) - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm2 = lat_cmp(jm2(i)) - phi_jm1 = lat_cmp(jm1(i)) - phi_jp0 = lat_cmp(jp0(i)) - phi_jp1 = lat_cmp(jp1(i)) - - if( jm2(i).eq.0 ) phi_jm2 = phi_jm1 - dphi(1) - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - endif - if( jp1(i).eq.jm+1 ) phi_jp1 = phi_jp0 + dphi(jm-1) - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - -c Interpolate Computational-Grid Quantities to Geophysical Grid -c ------------------------------------------------------------- - do L=1,lm - do i=1,irun - - if( lat_geo(i).le.lat_cmp(2) .or. - . lat_geo(i).ge.lat_cmp(jm-1) ) then - -c 1st Order Interpolation at Poles -c -------------------------------- - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - else - -c Cubic Interpolation away from Poles -c ----------------------------------- - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jp1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp1(i),L ).ne.undef .and. - . q_cmp( im2(i),jp1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm2(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm2(i),L ).ne.undef .and. - . q_cmp( im1(i),jm2(i),L ).ne.undef .and. - . q_cmp( im2(i),jm2(i),L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) - . + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) - . + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) - . + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) - . + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) - . + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) - . + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - return - end subroutine interp_h diff --git a/GEOS_Util/post/rs_hinterp.F b/GEOS_Util/post/rs_hinterp.F deleted file mode 100755 index b2264234..00000000 --- a/GEOS_Util/post/rs_hinterp.F +++ /dev/null @@ -1,2663 +0,0 @@ - program main - use MAPL - - implicit none - -! ********************************************************************** -! ********************************************************************** -! **** **** -! **** Program to merge eta_hdf data into GEOS5 restarts **** -! **** **** -! ********************************************************************** -! ********************************************************************** - - integer im_out - integer jm_out - - character*256 dynrst, moistrst, anaeta - character*256 topo_old - character*256 topo_new - character*256, allocatable :: other_rst(:) - - integer headr1(6) - integer headr2(5) - integer nymd,nhms,nymd_ana,nhms_ana - integer im,jm,lm - -! restart variables and topography -! -------------------------------- - real, allocatable :: u(:,:,:) - real, allocatable :: v(:,:,:) - real, allocatable :: th(:,:,:) - real, allocatable :: pk(:,:,:) - real, allocatable :: ple(:,:,:) - real, allocatable :: q(:,:,:) - real, allocatable :: ps(:,:) - real, allocatable :: ts(:,:) - real, allocatable :: tb(:,:) - real, allocatable :: qnew(:,:,:) - real, allocatable :: thnew(:,:,:) - real, allocatable :: unew(:,:,:) - real, allocatable :: vnew(:,:,:) - real, allocatable :: plenew(:,:,:) - real, allocatable :: pkenew(:,:,:) - real, allocatable :: pknew(:,:,:) - real, allocatable :: phisold(:,:) - real, allocatable :: phisint(:,:) - real, allocatable :: phisnew(:,:) - real, allocatable :: psnew(:,:) - real, allocatable :: tbnew(:,:) - - real*8, allocatable :: ak(:) - real*8, allocatable :: bk(:) - real*8, allocatable :: dum(:,:) - - real*4, allocatable :: dumold(:,:) - real*4, allocatable :: dumnew(:,:) - - real kappa, grav, beta, delp - real undef - - character*256, allocatable :: arg(:) - character*1 char - character*8 date - character*2 hour - character*4 xdim ,ydim - integer m,n,nmax,nargs,i,j,L,rc - integer nlots,nrem,num,num_other_rst - integer :: filetype,dimSizes(3),counter,nVars - - character(len=:), pointer :: var_name - type(FileMetadata), allocatable :: cfg_in(:), cfg_out(:) - type(Netcdf4_Fileformatter) :: fmt_in,fmt_out - type(StringVariableMap), pointer :: vars - type(StringVariableMapIterator) :: iter - - -! ********************************************************************** -! **** Initialize Filenames **** -! ********************************************************************** - - kappa = MAPL_KAPPA - grav = MAPL_GRAV - beta = 0.0065 - - xdim = ' ' - ydim = ' ' - dynrst = 'fvcore_internal_restart' - moistrst = 'moist_internal_restart' - anaeta = 'x' - nymd_ana = -999 - nhms_ana = -999 - im_out = -999 - jm_out = -999 - - num_other_rst = 0 - - nargs = command_argument_count() - if( nargs.eq.0 ) call usage() - - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-dyn' ) then - dynrst = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-moist' ) then - moistrst = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-topo_old' ) then - topo_old = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-topo_new' ) then - topo_new = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-im' ) read(arg(n+1),*) im_out - if( trim(arg(n)).eq.'-jm' ) read(arg(n+1),*) jm_out - - if( trim(arg(n)).eq.'-other' ) then - num = 1 - if( n+num.le.nargs ) then - read(arg(n+num),fmt='(a1)') char - do while (char.ne.'-' .and. n+num.ne.nargs ) - num = num+1 - read(arg(n+num),fmt='(a1)') char - enddo - if( char.eq.'-' ) num = num-1 - allocate ( other_rst(num) ) - do m=1,num - other_rst(m) = arg(n+m) - enddo - num_other_rst = num - endif - endif - - enddo - - if( im_out.eq.-999 .or. jm_out.eq.-999 ) then - print *, 'You must supply the desired output resolution IM and JM!' - stop - endif - call checkfile ( trim(dynrst) ) - call checkfile ( trim(moistrst) ) - call checkfile ( trim(topo_old) ) - call checkfile ( trim(topo_new) ) - do n=1,num_other_rst - call checkfile ( trim(other_rst(n)) ) - enddo - -! ********************************************************************** -! **** Read dycore internal Restart for RSLV, Date and Time **** -! ********************************************************************** - - call MAPL_NCIOGetFileType(dynrst,filetype,rc=rc) - - if (filetype ==0) then - - allocate(cfg_in(1),cfg_out(1)) - call fmt_in%open(dynrst,pFIO_READ,rc=rc) - cfg_in(1) = fmt_in%read(rc=rc) - im = cfg_in(1)%get_dimension('lon',rc=rc) - jm = cfg_in(1)%get_dimension('lat',rc=rc) - lm = cfg_in(1)%get_dimension('lev',rc=rc) - call MAPL_IOGetTime(cfg_in(1),nymd,nhms) - - else - - open (10,file=trim(dynrst),form='unformatted',access='sequential') - read (10) headr1 - read (10) headr2 - close(10) - - nymd = headr1(1)*10000 - . + headr1(2)*100 - . + headr1(3) - nhms = headr1(4)*10000 - . + headr1(5)*100 - . + headr1(6) - - im = headr2(1) - jm = headr2(2) - lm = headr2(3) - end if - - if( nymd_ana.eq.-999 ) nymd_ana = nymd - if( nhms_ana.eq.-999 ) nhms_ana = nhms - - write(xdim,103) im_out - write(ydim,103) jm_out - write(date,101) nymd_ana - write(hour,102) nhms_ana/10000 - 101 format(i8.8) - 102 format(i2.2) - 103 format(i4.4) - - print * - print *, ' dyn restart filename: ',trim(dynrst) - print *, ' moist restart filename: ',trim(moistrst) - do n=1,num_other_rst - print *, ' other restart filename: ',trim(other_rst(n)) - enddo - print *, ' resolution: ',im,jm,lm - print *, ' date: ',nymd_ana,nhms_ana - print * - - allocate ( ts(im,jm) ) - allocate ( tb(im,jm) ) - allocate ( ps(im,jm) ) - allocate ( pk(im,jm,lm) ) - allocate ( ple(im,jm,lm+1) ) - allocate ( u(im,jm,lm) ) - allocate ( v(im,jm,lm) ) - allocate ( th(im,jm,lm) ) - allocate ( q(im,jm,lm) ) - - allocate ( dumold(im ,jm ) ) - allocate ( dumnew(im_out,jm_out) ) - - allocate ( ak(lm+1) ) - allocate ( bk(lm+1) ) - -! ********************************************************************** -! **** Read Topography Datasets **** -! ********************************************************************** - - allocate ( phisold(im,jm) ) - allocate ( phisint(im_out,jm_out) ) - allocate ( phisnew(im_out,jm_out) ) - - print *, 'Reading Old Topography Dataset: ',trim(topo_old) - open (10,file=trim(topo_old),form='unformatted',access='sequential') - read (10) dumold - phisold(:,:) = dumold - close(10) - - print *, 'Reading New Topography Dataset: ',trim(topo_new) - open (10,file=trim(topo_new),form='unformatted',access='sequential') - read (10) dumnew - phisnew(:,:) = dumnew - close(10) - - phisold = phisold*grav - phisnew = phisnew*grav - -! ********************************************************************** -! **** Read dycore internal Restart **** -! ********************************************************************** - - allocate ( dum(im,jm) ) - - if (filetype == 0) then - call MAPL_VarRead(fmt_in,"AK",ak) - call MAPL_VarRead(fmt_in,"BK",bk) - do L=1,lm - call MAPL_VarRead(fmt_in,"U",dum,lev=l) - u(:,:,L) = dum(:,:) - enddo - do L=1,lm - call MAPL_VarRead(fmt_in,"V",dum,lev=l) - v(:,:,L) = dum(:,:) - enddo - do L=1,lm - call MAPL_VarRead(fmt_in,"PT",dum,lev=l) - th(:,:,L) = dum(:,:) - enddo - do L=1,lm+1 - call MAPL_VarRead(fmt_in,"PE",dum,lev=l) - ple(:,:,L) = dum(:,:) - enddo - do L=1,lm - call MAPL_VarRead(fmt_in,"PKZ",dum,lev=l) - pk(:,:,L) = dum(:,:) - enddo - else - - open (10,file=trim(dynrst),form='unformatted',access='sequential') - read (10) headr1 - read (10) headr2 - read (10) ak - read (10) bk - do L=1,lm - read(10) dum - u(:,:,L) = dum(:,:) - enddo - do L=1,lm - read(10) dum - v(:,:,L) = dum(:,:) - enddo - do L=1,lm - read(10) dum - th(:,:,L) = dum(:,:) - enddo - do L=1,lm+1 - read(10) dum - ple(:,:,L) = dum(:,:) - enddo - do L=1,lm - read(10) dum - pk(:,:,L) = dum(:,:) - enddo - close (10) - - end if - - deallocate ( dum ) - -c compute ts based on mean theta in pbl (100-mb) -c ---------------------------------------------- - ps(:,:) = ple(:,:,lm+1) - ts(:,:) = 0.0 - do j=1,jm - do i=1,im - L=lm - delp = 0.0 - do while ( delp.le.10000.0 ) - delp = delp + ple(i,j,L+1)-ple(i,j,L) - ts(i,j) = ts(i,j) + th(i,j,L)*(ple(i,j,L+1)-ple(i,j,L)) - L = L-1 - enddo - ts(i,j) = ts(i,j)/delp - enddo - enddo - ts(:,:) = ts(:,:)*ple(:,:,lm+1)**kappa - tb(:,:) = ts(:,:) + beta*phisold(:,:)/(2.0*grav) - -! ********************************************************************** -! **** Interpolate to New Resolution **** -! ********************************************************************** - - allocate ( tbnew(im_out,jm_out) ) - allocate ( psnew(im_out,jm_out) ) - allocate ( plenew(im_out,jm_out,lm+1) ) - allocate ( pkenew(im_out,jm_out,lm+1) ) - allocate ( pknew(im_out,jm_out,lm) ) - allocate ( unew(im_out,jm_out,lm) ) - allocate ( vnew(im_out,jm_out,lm) ) - allocate ( thnew(im_out,jm_out,lm) ) - allocate ( qnew(im_out,jm_out,lm) ) - -c interpolate topography, surface pressure, and tbar -c -------------------------------------------------- - call hinterp ( phisold,im,jm,phisint,im_out,jm_out,1,undef,1,3,.false. ) - call hinterp ( ps,im,jm, psnew,im_out,jm_out,1,undef,1,3,.false. ) - call hinterp ( tb,im,jm, tbnew,im_out,jm_out,1,undef,1,3,.false. ) - - call ps_mod ( psnew,phisint,tbnew,phisnew,im_out,jm_out ) - -c reconstruct upper-level pressures based on new ps -c ------------------------------------------------- - do L=1,lm+1 - do j=1,jm_out - do i=1,im_out - plenew(i,j,L) = ak(L)+bk(L)*psnew(i,j) - pkenew(i,j,L) = plenew(i,j,L)**kappa - enddo - enddo - enddo - do L=1,lm - pknew(:,:,L) = (pkenew(:,:,L+1)-pkenew(:,:,L)) - . / ( kappa*log(plenew(:,:,L+1)/plenew(:,:,L)) ) - enddo - -c interpolate winds -c ----------------- - call dtoa ( u,u,im,jm,lm,2 ) - call dtoa ( v,v,im,jm,lm,1 ) - - call hinterp ( u,im,jm,unew,im_out,jm_out,lm,undef,-1,3,.false.) - call hinterp ( v,im,jm,vnew,im_out,jm_out,lm,undef,-1,3,.false.) - - call atod ( unew,unew,im_out,jm_out,lm,2 ) - call atod ( vnew,vnew,im_out,jm_out,lm,1 ) - -c interpolate potential temperature -c --------------------------------- - call hinterp ( th,im,jm,thnew,im_out,jm_out,lm,undef, 1,3,.false.) - - -! ********************************************************************** -! **** Write dycore internal Restart **** -! ********************************************************************** - - undef = -999 - headr2(1) = im_out - headr2(2) = jm_out - - anaeta = trim(dynrst) // '.' // xdim // 'x' // ydim - print * - print *, 'Creating GEOS-5 fvcore_internal_restart: ',trim(anaeta) - - allocate ( dum(im_out,jm_out) ) - - if (filetype ==0) then - - call MAPL_IOChangeRes(cfg_in(1),cfg_out(1),(/'lon','lat'/),(/im_out,jm_out/),rc=rc) - call fmt_out%create(anaeta,rc=rc) - call fmt_out%write(cfg_out(1),rc=rc) - - call MAPL_VarWrite(fmt_out,"AK",ak) - call MAPL_VarWrite(fmt_out,"BK",bk) - do L=1,lm - dum(:,:) = unew(:,:,L) - call MAPL_VarWrite(fmt_out,"U",dum,lev=L) - enddo - do L=1,lm - dum(:,:) = vnew(:,:,L) - call MAPL_VarWrite(fmt_out,"V",dum,lev=L) - enddo - do L=1,lm - dum(:,:) = thnew(:,:,L) - call MAPL_VarWrite(fmt_out,"PT",dum,lev=L) - enddo - do L=1,lm+1 - dum(:,:) = plenew(:,:,L) - call MAPL_VarWrite(fmt_out,"PE",dum,lev=L) - enddo - do L=1,lm - dum(:,:) = pknew(:,:,L) - call MAPL_VarWrite(fmt_out,"PKZ",dum,lev=L) - enddo - call fmt_out%close() - call fmt_in%close() - deallocate(cfg_in,cfg_out) - - else - - open (20,file=trim(anaeta),form='unformatted',access='sequential') - write(20) headr1 - write(20) headr2 - write(20) ak - write(20) bk - do L=1,lm - dum(:,:) = unew(:,:,L) - write(20) dum - enddo - do L=1,lm - dum(:,:) = vnew(:,:,L) - write(20) dum - enddo - do L=1,lm - dum(:,:) = thnew(:,:,L) - write(20) dum - enddo - do L=1,lm+1 - dum(:,:) = plenew(:,:,L) - write(20) dum - enddo - do L=1,lm - dum(:,:) = pknew(:,:,L) - write(20) dum - enddo - close (20) - - endif - deallocate ( dum ) - -! ********************************************************************** -! **** Read, Interpolate, and Write MOIST Internal Restart **** -! ********************************************************************** - - anaeta = trim(moistrst) // '.' // xdim // 'x' // ydim - - call MAPL_NCIOGetFileType(moistrst,filetype,rc=rc) - - if (filetype ==0) then - - allocate(cfg_in(1),cfg_out(1)) - call fmt_in%open(moistrst,pFIO_READ,rc=rc) - cfg_in(1) = fmt_in%read(rc=rc) - call MAPL_IOChangeRes(cfg_in(1),cfg_out(1),(/'lon','lat'/),(/im_out,jm_out/),rc=rc) - call fmt_out%create(anaeta,rc=rc) - call fmt_out%write(cfg_out(1),rc=rc) - - nmax = 0 - do n=1,nVars - nmax = nmax+lm - enddo - - deallocate ( q,qnew ) - allocate ( q (im, jm, nmax) ) - allocate ( qnew(im_out,jm_out,nmax) ) - - vars => cfg_in(1)%get_variables() - iter = vars%begin() - - counter = 0 - do while(iter /= vars%end()) - var_name => iter%key() - if (.not.cfg_in(1)%is_coordinate_variable(var_name)) then - do l=1,dimSizes(3) - call MAPL_VarRead(fmt_in,var_name,dumold,lev=l) - counter = counter + 1 - q(:,:,counter) = dumold - enddo - end if - call iter%next() - enddo - - call hinterp ( q,im,jm,qnew,im_out,jm_out,nmax,undef, 1,-3,.false.) - - counter = 0 - do while(iter /= vars%end()) - var_name => iter%key() - if (.not.cfg_in(1)%is_coordinate_variable(var_name)) then - do l=1,dimSizes(3) - counter = counter + 1 - dumnew = qnew(:,:,counter) - call MAPL_VarWrite(fmt_out,var_name,dumnew,lev=l) - enddo - end if - call iter%next() - enddo - - call fmt_out%close() - call fmt_in%close() - deallocate(cfg_in,cfg_out) - - else - - open (10,file=trim(moistrst),form='unformatted',access='sequential') - open (20,file=trim(anaeta) ,form='unformatted',access='sequential') - - nmax = 0 - rc = 0 - dowhile (rc.eq.0) - read (10,iostat=rc) - if( rc.eq.0 ) nmax = nmax + 1 - enddo - rewind 10 - - print * - write(6,1001) 'Creating GEOS-5 moist_internal_restart: ' // trim(moistrst),nmax - print * - 1001 format(1x,a,/,1x,'(',i5,' 2-D Arrays)' ) - nlots = nmax/100 - nrem = nmax - nlots*100 - - do n=1,nlots+1 - if( n.eq.1 ) then - nmax = nrem - else - nmax = 100 - endif - deallocate ( q,qnew ) - allocate ( q (im, jm, nmax) ) - allocate ( qnew(im_out,jm_out,nmax) ) - - print *, 'Interpolating MOIST Restart for ',nmax,' 2-D Arrays ...' - do L=1,nmax - read (10) dumold - q(:,:,L) = dumold - enddo - - call hinterp ( q,im,jm,qnew,im_out,jm_out,nmax,undef, 1,-3,.false.) - - do L=1,nmax - dumnew = qnew(:,:,L) - write(20) dumnew - enddo - - enddo - print * - - close (10) - close (20) - - endif - -! ********************************************************************** -! **** Read, Interpolate, and Write Other Internal Restart **** -! ********************************************************************** - - do m=1,num_other_rst - anaeta = trim(other_rst(m)) // '.' // xdim // 'x' // ydim - - call MAPL_NCIOGetFileType(other_rst(m),filetype,rc=rc) - - if (filetype ==0) then - - allocate(cfg_in(1),cfg_out(1)) - call fmt_in%open(other_rst(m),pFIO_READ,rc=rc) - cfg_in(1) = fmt_in%read(rc=rc) - call MAPL_IOChangeRes(cfg_in(1),cfg_out(1),(/'lon','lat'/),(/im_out,jm_out/),rc=rc) - call fmt_out%create(anaeta,rc=rc) - call fmt_out%write(cfg_out(1),rc=rc) - - nmax = 0 - do n=1,nVars - nmax = nmax+lm - enddo - - deallocate ( q,qnew ) - allocate ( q (im, jm, nmax) ) - allocate ( qnew(im_out,jm_out,nmax) ) - - vars => cfg_in(1)%get_variables() - iter = vars%begin() - - counter = 0 - do while(iter /= vars%end()) - var_name => iter%key() - if (.not.cfg_in(1)%is_coordinate_variable(var_name)) then - do l=1,dimSizes(3) - call MAPL_VarRead(fmt_in,var_name,dumold,lev=l) - counter = counter + 1 - q(:,:,counter) = dumold - enddo - end if - call iter%next() - enddo - - call hinterp ( q,im,jm,qnew,im_out,jm_out,nmax,undef, 1,-3,.false.) - - counter = 0 - do while(iter /= vars%end()) - var_name => iter%key() - if (.not.cfg_in(1)%is_coordinate_variable(var_name)) then - do l=1,dimSizes(3) - counter = counter + 1 - dumnew = qnew(:,:,counter) - call MAPL_VarWrite(fmt_out,var_name,dumnew,lev=l) - enddo - end if - call iter%next() - enddo - - call fmt_out%close() - call fmt_in%close() - deallocate(cfg_in,cfg_out) - - else - - open (10,file=trim(other_rst(m)),form='unformatted',access='sequential') - open (20,file=trim(anaeta) ,form='unformatted',access='sequential') - - nmax = 0 - rc = 0 - dowhile (rc.eq.0) - read (10,iostat=rc) - if( rc.eq.0 ) nmax = nmax + 1 - enddo - rewind 10 - - write(6,1001) 'Creating GEOS-5 other_internal_restart: ' // trim(anaeta),nmax - print * - nlots = nmax/100 - nrem = nmax - nlots*100 - - do n=1,nlots+1 - if( n.eq.1 ) then - nmax = nrem - else - nmax = 100 - endif - deallocate ( q,qnew ) - allocate ( q (im, jm, nmax) ) - allocate ( qnew(im_out,jm_out,nmax) ) - - print *, 'Interpolating Other Restart for ',nmax,' 2-D Arrays ...' - do L=1,nmax - read (10) dumold - q(:,:,L) = dumold - enddo - -! call hinterp ( q,im,jm,qnew,im_out,jm_out,nmax,undef, 1,-3,.false.) ! For Positive-Definate Fields - call hinterp ( q,im,jm,qnew,im_out,jm_out,nmax,undef, 1, 3,.false.) ! For General Fields - - do L=1,nmax - dumnew = qnew(:,:,L) - write(20) dumnew - enddo - - enddo - print * - - close (10) - close (20) - - end if - - enddo - - stop - end - - subroutine writit (q,im,jm,lm) - real q(im,jm,lm) - real*4 a(im,jm) - do L=1,lm - a(:,:) = q(:,:,L) - write(50) a - enddo - return - end - - subroutine hinterp ( qin,iin,jin,qout,iout,jout,mlev,undef,msgn,norder,check ) - implicit none - integer iin,jin, iout,jout, mlev,msgn,norder - real qin(iin,jin,mlev), qout(iout,jout,mlev) - real undef,pi,dlin,dpin,dlout,dpout - real dlam(iin), lons(iout*jout), lon - real dphi(jin), lats(iout*jout), lat - integer i,j,loc - logical check - - pi = 4.0*atan(1.0) - dlin = 2*pi/iin - dpin = pi/(jin-1) - dlam(:) = dlin - dphi(:) = dpin - - dlout = 2*pi/iout - dpout = pi/(jout-1) - - loc = 0 - do j=1,jout - do i=1,iout - loc = loc + 1 - lon = -pi + (i-1)*dlout - lons(loc) = lon - enddo - enddo - - loc = 0 - do j=1,jout - lat = -pi/2.0 + (j-1)*dpout - do i=1,iout - loc = loc + 1 - lats(loc) = lat - enddo - enddo - - call interp_h ( qin,iin,jin,mlev, - . dlam,dphi,0.0,90.0,0.0, - . qout,iout*jout,lons,lats, - . msgn,norder,check,undef ) - - return - end - - subroutine interp_h ( q_cmp,im,jm,lm, - . dlam,dphi,rotation,tilt,precession, - . q_geo,irun,lon_geo,lat_geo, - . msgn,norder,check,undef ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C rotation ... Rotation parameter lam_np (Degrees) -C tilt ....... Rotation parameter phi_np (Degrees) -C precession . Rotation parameter lam_0 (Degrees) -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C msgn ....... Flag for scalar field ( msgn = 1 ) -C or vector component ( msgn = -1 ) -C norder ..... Order of Interpolation: Bi-Linear => abs(norder) = 1 -C Bi-Cubic => abs(norder) = 3 -C Note: If norder < 0, then check for positive definite -C check ...... Logical Flag to check for Undefined values -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - integer im,jm,lm,irun,norder,msgn - logical check - - real q_geo(irun,lm) - real lon_geo(irun) - real lat_geo(irun) - - real q_cmp(im,jm,lm) - real dlam(im) - real dphi(jm) - -c Local Variables -c --------------- - integer i,j,l,m,n - integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) - integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) - - integer ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1 - integer ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2 - integer jm2_for_jm2, jp1_for_jp1 - - -c Bi-Linear Weights -c ----------------- - real, allocatable :: wl_ip0jp0 (:) - real, allocatable :: wl_im1jp0 (:) - real, allocatable :: wl_ip0jm1 (:) - real, allocatable :: wl_im1jm1 (:) - -c Bi-Cubic Weights -c ---------------- - real, allocatable :: wc_ip1jp1 (:) - real, allocatable :: wc_ip0jp1 (:) - real, allocatable :: wc_im1jp1 (:) - real, allocatable :: wc_im2jp1 (:) - real, allocatable :: wc_ip1jp0 (:) - real, allocatable :: wc_ip0jp0 (:) - real, allocatable :: wc_im1jp0 (:) - real, allocatable :: wc_im2jp0 (:) - real, allocatable :: wc_ip1jm1 (:) - real, allocatable :: wc_ip0jm1 (:) - real, allocatable :: wc_im1jm1 (:) - real, allocatable :: wc_im2jm1 (:) - real, allocatable :: wc_ip1jm2 (:) - real, allocatable :: wc_ip0jm2 (:) - real, allocatable :: wc_im1jm2 (:) - real, allocatable :: wc_im2jm2 (:) - - real, allocatable :: old_lon (:) - real, allocatable :: old_lat (:) - real, allocatable :: old_dlam(:) - real, allocatable :: old_dphi(:) - - real ap1, ap0, am1, am2 - real bp1, bp0, bm1, bm2 - - real lon_cmp(im) - real lat_cmp(jm) - real q_tmp(irun) - - real pi,cosnp,sinnp,p1,p2,p3,eps,d - real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp,lam_np,phi_np,lam_0,eps_np - real rotation , tilt , precession - real lam_geo, lam_cmp - real phi_geo, phi_cmp - real undef - integer im1_cmp,icmp - integer jm1_cmp,jcmp - - logical compute_weights - real old_rotation - real old_tilt - real old_precession - data old_rotation /-999.9/ - data old_tilt /-999.9/ - data old_precession /-999.9/ - - parameter ( eps = 1.e-10 ) - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - if(.not.allocated(old_lon)) then - - allocate ( old_dlam(im) , old_dphi(jm) ) - allocate ( old_lon(irun) , old_lat(irun) ) - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - do i=1,irun - old_lon(i) = -999.9 - old_lat(i) = -999.9 - enddo - do i=1,im - old_dlam(i) = 0.0 - enddo - do j=1,jm - old_dphi(j) = 0.0 - enddo - - else - i = size (old_dlam) - j = size (old_dphi) - m = size (old_lon) - if(i.ne.im .or. j.ne.jm .or. m.ne.irun) then - deallocate ( old_dlam , old_dphi ) - deallocate ( old_lon , old_lat ) - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - allocate ( old_dlam(im) , old_dphi(jm) ) - allocate ( old_lon(irun) , old_lat(irun) ) - allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) - allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , jm1(irun) , jm2(irun) ) - do i=1,irun - old_lon(i) = -999.9 - old_lat(i) = -999.9 - enddo - do i=1,im - old_dlam(i) = 0.0 - enddo - do j=1,jm - old_dphi(j) = 0.0 - enddo - endif - endif - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - -c Check for Co-incident Grid-Point Latitude and Pole Locations -c ------------------------------------------------------------ - eps_np = 0.0 - do j=1,jm - phi_cmp = lat_cmp(j)*180./pi - if( abs( phi_cmp-tilt ).lt.1.e-3 ) eps_np = 1.e-3 - if( tilt+eps_np .gt. 90. ) eps_np = -1.e-3 - enddo - - lam_np = pi/180.*rotation - phi_np = pi/180.*(tilt+eps_np) - lam_0 = pi/180.*precession - - if( tilt.eq.90. ) then - cosnp = 0.0 - sinnp = 1.0 - else if(tilt.eq.-90.0) then - cosnp = 0.0 - sinnp =-1.0 - else - cosnp = cos(phi_np) - sinnp = sin(phi_np) - endif - -c Determine if Weights Need to be Updated -c --------------------------------------- - compute_weights = rotation.ne.old_rotation .or. - . tilt.ne.old_tilt .or. - . precession.ne.old_precession - - m = 1 - do while ( .not.compute_weights .and. m.le.irun ) - compute_weights = (lon_geo(m).ne.old_lon(m)) .or. - . (lat_geo(m).ne.old_lat(m)) - m = m+1 - enddo - i = 1 - do while ( .not.compute_weights .and. i.le.im ) - compute_weights = dlam(i).ne.old_dlam(i) - i = i+1 - enddo - j = 1 - do while ( .not.compute_weights .and. j.le.jm-1 ) - compute_weights = dphi(j).ne.old_dphi(j) - j = j+1 - enddo - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - if( compute_weights ) then - - old_rotation = rotation - old_tilt = tilt - old_precession = precession - -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (i,lam_geo,phi_geo,lam_cmp,phi_cmp,lam,phi) -!$omp& private (p1,p2,p3,d,icmp,jcmp,im1_cmp,jm1_cmp) -!$omp& private (lam_im2, lam_im1, lam_ip0, lam_ip1) -!$omp& private (phi_jm2, phi_jm1, phi_jp0, phi_jp1) -!$omp& private (ap1, ap0, am1, am2) -!$omp& private (bp1, bp0, bm1, bm2) -#endif - do i=1,irun - old_lon(i) = lon_geo(i) - old_lat(i) = lat_geo(i) - lam_geo = lon_geo(i) - phi_geo = lat_geo(i) - - p1 = cosnp*cos(phi_geo)*cos(lam_geo+lam_0-pi) - . + sin(phi_geo)*sinnp - p1 = min(p1, 1.0) - p1 = max(p1,-1.0) - phi_cmp = asin( p1 ) - - if( tilt.eq.90.0 .or. tilt.eq.-90.0 ) then - p2 = sinnp*cos(lam_geo+lam_0-pi) - else - p2 = sinnp*cos(phi_geo)*cos(lam_geo+lam_0-pi) - . - sin(phi_geo)*cosnp - p2 = p2 / max( cos(phi_cmp),eps ) - p2 = min(p2, 1.0) - p2 = max(p2,-1.0) - endif - p2 = acos( p2 ) - - p3 = cos(phi_geo)*sin(lam_geo+lam_0-pi) - if( p3.lt.0.0 ) p2 = -p2 - p2 = p2 + lam_np - pi - lam_cmp = mod( p2+3.0*pi,2.0*pi ) - pi - -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- - im1_cmp = 1 - do icmp = 2,im - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,jm - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i) = im1_cmp - ip0(i) = im1(i) + 1 - ip1(i) = ip0(i) + 1 - im2(i) = im1(i) - 1 - - jm1(i) = jm1_cmp - jp0(i) = jm1(i) + 1 - jp1(i) = jp0(i) + 1 - jm2(i) = jm1(i) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i).eq.im) then - ip0(i) = 1 - ip1(i) = 2 - endif - if(im1(i).eq.1) then - im2(i) = im - endif - if(ip0(i).eq.im) then - ip1(i) = 1 - endif - - -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i)) - lam_im1 = lon_cmp(im1(i)) - lam_ip0 = lon_cmp(ip0(i)) - lam_ip1 = lon_cmp(ip1(i)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - - -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ - phi_jm1 = lat_cmp(jm1(i)) - phi_jp0 = lat_cmp(jp0(i)) - - if( jm2(i).eq.0 ) then - phi_jm2 = phi_jm1 - dphi(1) - else - phi_jm2 = lat_cmp(jm2(i)) - endif - - if( jm1(i).eq.jm ) then - phi_jp0 = phi_jm1 + dphi(jm-1) - phi_jp1 = phi_jp0 + dphi(jm-2) - endif - - if( jp1(i).eq.jm+1 ) then - phi_jp1 = phi_jp0 + dphi(jm-1) - else - phi_jp1 = lat_cmp(jp1(i)) - endif - - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i) = bp1*ap1 - wc_ip0jp1(i) = bp1*ap0 - wc_im1jp1(i) = bp1*am1 - wc_im2jp1(i) = bp1*am2 - - wc_ip1jp0(i) = bp0*ap1 - wc_ip0jp0(i) = bp0*ap0 - wc_im1jp0(i) = bp0*am1 - wc_im2jp0(i) = bp0*am2 - - wc_ip1jm1(i) = bm1*ap1 - wc_ip0jm1(i) = bm1*ap0 - wc_im1jm1(i) = bm1*am1 - wc_im2jm1(i) = bm1*am2 - - wc_ip1jm2(i) = bm2*ap1 - wc_ip0jm2(i) = bm2*ap0 - wc_im1jm2(i) = bm2*am1 - wc_im2jm2(i) = bm2*am2 - - enddo - endif - -c Interpolate Computational-Grid Quantities to Geophysical Grid Using Bi-Linear -c ----------------------------------------------------------------------------- - if( abs(norder).eq.1 ) then - - if( check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,q_tmp) -#endif - do L=1,lm - do i=1,irun - - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - if( .not.check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,q_tmp) -#endif - do L=1,lm - do i=1,irun - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - enddo - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - endif ! End Check for Bi-Linear Interpolation - - -c Interpolate Computational-Grid Quantities to Geophysical Grid Using Bi-Cubic -c ---------------------------------------------------------------------------- - if( abs(norder).eq.3 ) then - - if( check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,m,n,q_tmp) -!$omp& private (ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1) -!$omp& private (ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2) -!$omp& private (jp1_for_jp1, jm2_for_jm2) -#endif - do L=1,lm - do i=1,irun - - ip1_for_jp1 = ip1(i) - ip0_for_jp1 = ip0(i) - im1_for_jp1 = im1(i) - im2_for_jp1 = im2(i) - jp1_for_jp1 = jp1(i) - m = 1 - - if( jp0(i).eq.jm ) then - ip1_for_jp1 = 1 + mod( ip1_for_jp1 + im/2 -1, im ) - ip0_for_jp1 = 1 + mod( ip0_for_jp1 + im/2 -1, im ) - im1_for_jp1 = 1 + mod( im1_for_jp1 + im/2 -1, im ) - im2_for_jp1 = 1 + mod( im2_for_jp1 + im/2 -1, im ) - jp1_for_jp1 = jm-1 - if(msgn.eq.-1) m=-1 - endif - - ip1_for_jm2 = ip1(i) - ip0_for_jm2 = ip0(i) - im1_for_jm2 = im1(i) - im2_for_jm2 = im2(i) - jm2_for_jm2 = jm2(i) - n = 1 - - if( jm1(i).eq.1 ) then - ip1_for_jm2 = 1 + mod( ip1_for_jm2 + im/2 -1, im ) - ip0_for_jm2 = 1 + mod( ip0_for_jm2 + im/2 -1, im ) - im1_for_jm2 = 1 + mod( im1_for_jm2 + im/2 -1, im ) - im2_for_jm2 = 1 + mod( im2_for_jm2 + im/2 -1, im ) - jm2_for_jm2 = 2 - if(msgn.eq.-1) n=-1 - endif - - - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1_for_jm2,jm2_for_jm2,L ).ne.undef .and. - . q_cmp( ip0_for_jm2,jm2_for_jm2,L ).ne.undef .and. - . q_cmp( im1_for_jm2,jm2_for_jm2,L ).ne.undef .and. - . q_cmp( im2_for_jm2,jm2_for_jm2,L ).ne.undef .and. - - . q_cmp( ip1_for_jp1,jp1_for_jp1,L ).ne.undef .and. - . q_cmp( ip0_for_jp1,jp1_for_jp1,L ).ne.undef .and. - . q_cmp( im1_for_jp1,jp1_for_jp1,L ).ne.undef .and. - . q_cmp( im2_for_jp1,jp1_for_jp1,L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1_for_jp1,jp1_for_jp1,L )*m - . + wc_ip0jp1(i) * q_cmp( ip0_for_jp1,jp1_for_jp1,L )*m - . + wc_im1jp1(i) * q_cmp( im1_for_jp1,jp1_for_jp1,L )*m - . + wc_im2jp1(i) * q_cmp( im2_for_jp1,jp1_for_jp1,L )*m - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1_for_jm2,jm2_for_jm2,L )*n - . + wc_ip0jm2(i) * q_cmp( ip0_for_jm2,jm2_for_jm2,L )*n - . + wc_im1jm2(i) * q_cmp( im1_for_jm2,jm2_for_jm2,L )*n - . + wc_im2jm2(i) * q_cmp( im2_for_jm2,jm2_for_jm2,L )*n - - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - - else - q_tmp(i) = undef - endif - enddo - -c Check for Positive Definite -c --------------------------- - if( norder.lt.0 ) then - do i=1,irun - if( q_tmp(i).ne.undef .and. - . q_tmp(i).lt.0.0 ) then - q_tmp(i) = 0.0 - endif - enddo - endif - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - if( .not.check ) then -#if (openmp) -!$omp parallel do -!$omp& default (shared) -!$omp& private (L,i,m,n,q_tmp) -!$omp& private (ip1_for_jp1, ip0_for_jp1, im1_for_jp1, im2_for_jp1) -!$omp& private (ip1_for_jm2, ip0_for_jm2, im1_for_jm2, im2_for_jm2) -!$omp& private (jp1_for_jp1, jm2_for_jm2) -#endif - do L=1,lm - do i=1,irun - - ip1_for_jp1 = ip1(i) - ip0_for_jp1 = ip0(i) - im1_for_jp1 = im1(i) - im2_for_jp1 = im2(i) - jp1_for_jp1 = jp1(i) - m = 1 - - if( jp0(i).eq.jm ) then - ip1_for_jp1 = 1 + mod( ip1_for_jp1 + im/2 -1, im ) - ip0_for_jp1 = 1 + mod( ip0_for_jp1 + im/2 -1, im ) - im1_for_jp1 = 1 + mod( im1_for_jp1 + im/2 -1, im ) - im2_for_jp1 = 1 + mod( im2_for_jp1 + im/2 -1, im ) - jp1_for_jp1 = jm-1 - if(msgn.eq.-1) m=-1 - endif - - ip1_for_jm2 = ip1(i) - ip0_for_jm2 = ip0(i) - im1_for_jm2 = im1(i) - im2_for_jm2 = im2(i) - jm2_for_jm2 = jm2(i) - n = 1 - - if( jm1(i).eq.1 ) then - ip1_for_jm2 = 1 + mod( ip1_for_jm2 + im/2 -1, im ) - ip0_for_jm2 = 1 + mod( ip0_for_jm2 + im/2 -1, im ) - im1_for_jm2 = 1 + mod( im1_for_jm2 + im/2 -1, im ) - im2_for_jm2 = 1 + mod( im2_for_jm2 + im/2 -1, im ) - jm2_for_jm2 = 2 - if(msgn.eq.-1) n=-1 - endif - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1_for_jp1,jp1_for_jp1,L )*m - . + wc_ip0jp1(i) * q_cmp( ip0_for_jp1,jp1_for_jp1,L )*m - . + wc_im1jp1(i) * q_cmp( im1_for_jp1,jp1_for_jp1,L )*m - . + wc_im2jp1(i) * q_cmp( im2_for_jp1,jp1_for_jp1,L )*m - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1_for_jm2,jm2_for_jm2,L )*n - . + wc_ip0jm2(i) * q_cmp( ip0_for_jm2,jm2_for_jm2,L )*n - . + wc_im1jm2(i) * q_cmp( im1_for_jm2,jm2_for_jm2,L )*n - . + wc_im2jm2(i) * q_cmp( im2_for_jm2,jm2_for_jm2,L )*n - - enddo - -c Check for Positive Definite -c --------------------------- - if( norder.lt.0 ) then - do i=1,irun - if( q_tmp(i).ne.undef .and. - . q_tmp(i).lt.0.0 ) then - q_tmp(i) = 0.0 - endif - enddo - endif - -c Load Temp array into Output array -c --------------------------------- - do i=1,irun - q_geo(i,L) = q_tmp(i) - enddo - enddo - endif - - endif ! End Check for Bi-Cubic Interpolation - - deallocate ( old_dlam , old_dphi ) - deallocate ( old_lon , old_lat ) - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - - return - end - - subroutine ps_mod ( ps,gz1,tbr,gz2,im,jm ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Modify surface pressure using new topography -C -C Input: -C ===== -C ps ...... Surface Pressure consistent with Topography gz1 -C gz1 ..... Old Topography -C tbr ..... Mean Temperature Used for SLP -C gz2 ..... New Topography -C im ...... Zonal Dimension -C jm ...... Meridional Dimension -C -C Output: -C ======= -C ps ...... Updated Surface Pressure-Ptop consistent with Topography gz2 -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use MAPL_ConstantsMod - implicit none - integer im,jm - real ps(im,jm) - real gz1(im,jm) - real gz2(im,jm) - real tbr(im,jm) - real k,r,g,beta - real psl,slp,phis1,phis2,tbar,ts1,f,fp - real phis,ps1,ps2,ps20,psurf - integer i,j,n - - psl(psurf,phis,tbar) = psurf*exp(phis/(r*tbar)) - f(ps2) = ps2-slp*exp(-phis2/(r*(ts1*(ps2/ps1)**k - . + beta*phis2/(2*g)))) - - fp(ps2) = 1-slp*exp(-phis2/(r*(ts1*(ps2/ps1)**k - . + beta*phis2/(2*g)))) - . *( phis2*ts1*k*(ps2/ps1)**k ) - . /( r*ps2*(ts1*(ps2/ps1)**k+beta*phis2/(2*g))**2 ) - - r = MAPL_RGAS - g = MAPL_GRAV - k = MAPL_KAPPA - - beta = 0.0065 - - do j=1,jm - do i=1,im - ps1 = ps(i,j) - phis1 = gz1(i,j) - phis2 = gz2(i,j) - tbar = tbr(i,j) - - slp = psl(ps1,phis1,tbar) - ts1 = tbar - beta*phis1/(2*g) - - ps2 = ps1 - ps20 = 0 - n = 0 - do while ( abs( ps2-ps20 ).gt.1.e-5 .and. n.le.50 ) - ps20 = ps2 - ps2 = ps2 - f(ps2)/fp(ps2) - n = n + 1 - enddo - - ps(i,j) = ps2 - enddo - enddo - return - end - - subroutine atod ( qa,qd,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded data **** -C **** to 'D' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted left (westward), **** -C **** u is shifted down (southward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real qax ( im+2 ,lm) - real cx (2*(im+2),lm) - real qay ( 2*jm ,lm) - real cy (2*(2*jm),lm) - - real cosx (im/2), sinx(im/2) - real cosy (jm) , siny(jm) - real trigx(3*(im+1)) - real trigy(3*(2*jm)) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - -C ********************************************************* -C **** shift left (-dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qa(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) + qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) - qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qd(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift down (-dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qa(i,j+1,L) - qay(j+jmm1,L) = -qa(i+imh,jm-j,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) + qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) - qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qd(i,j+1,L) = qay(j,L) - qd(i+imh,jm-j+1,L) = -qay(j+jmm1,L) - enddo - enddo - enddo - - endif - - return - end - - subroutine dtoa ( qd,qa,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real qax ( im+2 ,lm) - real cx (2*(im+2),lm) - real qay ( 2*jm ,lm) - real cy (2*(2*jm),lm) - - real cosx (im/2), sinx(im/2) - real cosy (jm) , siny(jm) - real trigx(3*(im+1)) - real trigy(3*(2*jm)) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - -C ********************************************************* -C **** shift right (dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qd(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) - qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) + qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qa(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift up (dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qd(i,j+1,L) - qay(j+jmm1,L) = -qd(i+imh,jm-j+1,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) - qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) + qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qa(i,j+1,L) = qay(j,L) - qa(i+imh,jm-j,L) = -qay(j+jmm1,L) - enddo - enddo - - enddo - - do L=1,lm - do i=1,imh - qa(i+imh,jm,L) = -qa(i,jm,L) - qa(i,1,L) = -qa(i+imh,1,L) - enddo - enddo - endif - - return - end - - subroutine rfftmlt (a,work,trigs,ifax,inc,jump,n,lot,isign) - integer INC, JUMP, N, LOT, ISIGN - real(kind=KIND(1.0)) A(N),WORK(N),TRIGS(N) - integer IFAX(*) -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR -! CALL Q8QST4 ( 4HXLIB, 6HFFT99F, 6HFFT991, 10HVERSION 01) -!FPP$ NOVECTOR R - integer NFAX, NH, NX, INK - integer I, J, IBASE, JBASE, L, IGO, IA, LA, K, M, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, - * INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, - * 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 -!DIR$ IVDEP - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END - - subroutine fftfax (n,ifax,trigs) - integer IFAX(13) - integer N - REAL(kind=KIND(1.0)) TRIGS(*) -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - integer I, MODE - DATA MODE /3/ -!FPP$ NOVECTOR R - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) WRITE(6,FMT="(//5X, ' FFTFAX -- INVALID N =', I5,/)") N - IF (IFAX(1) .LE. 0 ) STOP 999 - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END - - subroutine fft99a (a,work,trigs,inc,jump,n,lot) - integer inc, jump, N, lot - real(kind=KIND(1.0)) A(N),WORK(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 -! (SPECTRAL TO GRIDPOINT TRANSFORM) -! -!FPP$ NOVECTOR R - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) C, S - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - IA=1 - IB=N*INC+1 - JA=1 - JB=2 -!DIR$ IVDEP - DO 10 L=1,LOT - WORK(JA)=A(IA)+A(IB) - WORK(JB)=A(IA)-A(IB) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 10 CONTINUE -! -! REMAINING WAVENUMBERS - IABASE=2*INC+1 - IBBASE=(N-2)*INC+1 - JABASE=3 - JBBASE=N-1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - WORK(JA)=(A(IA)+A(IB))- - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JB)=(A(IA)+A(IB))+ - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+ - * (A(IA+INC)-A(IB+INC)) - WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))- - * (A(IA+INC)-A(IB+INC)) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 20 CONTINUE - IABASE=IABASE+INK - IBBASE=IBBASE-INK - JABASE=JABASE+2 - JBBASE=JBBASE-2 - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE -!DIR$ IVDEP - DO 40 L=1,LOT - WORK(JA)=2.0*A(IA) - WORK(JA+1)=-2.0*A(IA+INC) - IA=IA+JUMP - JA=JA+NX - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fft99b (work,a,trigs,inc,jump,n,lot) - integer INC, JUMP, N, LOT - real(kind=KIND(1.0)) WORK(N),A(N) - REAL(kind=KIND(1.0)) TRIGS(N) - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) SCALE - real(kind=KIND(1.0)) C, S -! -! SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 -! (GRIDPOINT TO SPECTRAL TRANSFORM) -! -!FPP$ NOVECTOR R - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - SCALE=1.0/FLOAT(N) - IA=1 - IB=2 - JA=1 - JB=N*INC+1 -!DIR$ IVDEP - DO 10 L=1,LOT - A(JA)=SCALE*(WORK(IA)+WORK(IB)) - A(JB)=SCALE*(WORK(IA)-WORK(IB)) - A(JA+INC)=0.0 - A(JB+INC)=0.0 - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 10 CONTINUE -! -! REMAINING WAVENUMBERS - SCALE=0.5*SCALE - IABASE=3 - IBBASE=N-1 - JABASE=2*INC+1 - JBBASE=(N-2)*INC+1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - A(JA)=SCALE*((WORK(IA)+WORK(IB)) - * +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JB)=SCALE*((WORK(IA)+WORK(IB)) - * -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * +(WORK(IB+1)-WORK(IA+1))) - A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * -(WORK(IB+1)-WORK(IA+1))) - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 20 CONTINUE - IABASE=IABASE+2 - IBBASE=IBBASE-2 - JABASE=JABASE+INK - JBBASE=JBBASE-INK - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - SCALE=2.0*SCALE -!DIR$ IVDEP - DO 40 L=1,LOT - A(JA)=SCALE*WORK(IA) - A(JA+INC)=-SCALE*WORK(IA+1) - IA=IA+NX - JA=JA+JUMP - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fax (ifax,n,mode) - integer IFAX(10) - integer N, MODE -!FPP$ NOVECTOR R - integer NN, K, L, INC, II, ISTOP, ITEM, NFAX, I - NN=N - IF (IABS(MODE).EQ.1) GO TO 10 - IF (IABS(MODE).EQ.8) GO TO 10 - NN=N/2 - IF ((NN+NN).EQ.N) GO TO 10 - IFAX(1)=-99 - RETURN - 10 K=1 -! TEST FOR FACTORS OF 4 - 20 IF (MOD(NN,4).NE.0) GO TO 30 - K=K+1 - IFAX(K)=4 - NN=NN/4 - IF (NN.EQ.1) GO TO 80 - GO TO 20 -! TEST FOR EXTRA FACTOR OF 2 - 30 IF (MOD(NN,2).NE.0) GO TO 40 - K=K+1 - IFAX(K)=2 - NN=NN/2 - IF (NN.EQ.1) GO TO 80 -! TEST FOR FACTORS OF 3 - 40 IF (MOD(NN,3).NE.0) GO TO 50 - K=K+1 - IFAX(K)=3 - NN=NN/3 - IF (NN.EQ.1) GO TO 80 - GO TO 40 -! NOW FIND REMAINING FACTORS - 50 L=5 - INC=2 -! INC ALTERNATELY TAKES ON VALUES 2 AND 4 - 60 IF (MOD(NN,L).NE.0) GO TO 70 - K=K+1 - IFAX(K)=L - NN=NN/L - IF (NN.EQ.1) GO TO 80 - GO TO 60 - 70 L=L+INC - INC=6-INC - GO TO 60 - 80 IFAX(1)=K-1 -! IFAX(1) CONTAINS NUMBER OF FACTORS - NFAX=IFAX(1) -! SORT FACTORS INTO ASCENDING ORDER - IF (NFAX.EQ.1) GO TO 110 - DO 100 II=2,NFAX - ISTOP=NFAX+2-II - DO 90 I=2,ISTOP - IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 - ITEM=IFAX(I) - IFAX(I)=IFAX(I+1) - IFAX(I+1)=ITEM - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN - END - - subroutine fftrig (trigs,n,mode) - REAL(kind=KIND(1.0)) TRIGS(*) - integer N, MODE -!FPP$ NOVECTOR R - real(kind=KIND(1.0)) PI - integer IMODE, NN, L, I, NH, LA - real(kind=KIND(1.0)) DEL, ANGLE - PI=2.0*ASIN(1.0) - IMODE=IABS(MODE) - NN=N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 - DEL=(PI+PI)/FLOAT(NN) - L=NN+NN - DO 10 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(I)=COS(ANGLE) - TRIGS(I+1)=SIN(ANGLE) - 10 CONTINUE - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - DEL=0.5*DEL - NH=(NN+1)/2 - L=NH+NH - LA=NN+NN - DO 20 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(LA+I)=COS(ANGLE) - TRIGS(LA+I+1)=SIN(ANGLE) - 20 CONTINUE - IF (IMODE.LE.3) RETURN - DEL=0.5*DEL - LA=LA+NN - IF (MODE.EQ.5) GO TO 40 - DO 30 I=2,NN - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=2.0*SIN(ANGLE) - 30 CONTINUE - RETURN - 40 CONTINUE - DEL=0.5*DEL - DO 50 I=2,N - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=SIN(ANGLE) - 50 CONTINUE - RETURN - END - - subroutine vpassm (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la) - integer INC1,INC2,INC3,INC4,LOT,N,IFAC,LA - real(kind=KIND(1.0)) A(N),B(N),C(N),D(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA" -! PERFORMS ONE PASS THROUGH DATA -! AS PART OF MULTIPLE COMPLEX FFT ROUTINE -! A IS FIRST REAL INPUT VECTOR -! B IS FIRST IMAGINARY INPUT VECTOR -! C IS FIRST REAL OUTPUT VECTOR -! D IS FIRST IMAGINARY OUTPUT VECTOR -! TRIGS IS PRECALCULATED TABLE OF SINES & COSINES -! INC1 IS ADDRESSING INCREMENT FOR A AND B -! INC2 IS ADDRESSING INCREMENT FOR C AND D -! INC3 IS ADDRESSING INCREMENT BETWEEN As & Bs -! INC4 IS ADDRESSING INCREMENT BETWEEN Cs & Ds -! LOT IS THE NUMBER OF VECTORS -! N IS LENGTH OF VECTORS -! IFAC IS CURRENT FACTOR OF N -! LA IS PRODUCT OF PREVIOUS FACTORS -! - real(kind=KIND(1.0)) SIN36, COS36, SIN72, COS72, SIN60 - DATA SIN36/0.587785252292473/,COS36/0.809016994374947/, - * SIN72/0.951056516295154/,COS72/0.309016994374947/, - * SIN60/0.866025403784437/ - integer M, IINK, JINK, JUMP, IBASE, JBASE, IGO, IA, JA, IB, JB - integer IC, JC, ID, JD, IE, JE - integer I, J, K, L, IJK, LA1, KB, KC, KD, KE - real(kind=KIND(1.0)) C1, S1, C2, S2, C3, S3, C4, S4 -! -!FPP$ NOVECTOR R - M=N/IFAC - IINK=M*INC1 - JINK=LA*INC2 - JUMP=(IFAC-1)*JINK - IBASE=0 - JBASE=0 - IGO=IFAC-1 - IF (IGO.GT.4) RETURN - GO TO (10,50,90,130),IGO -! -! CODING FOR FACTOR 2 -! - 10 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - DO 20 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 15 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=A(IA+I)-A(IB+I) - D(JB+J)=B(IA+I)-B(IB+I) - I=I+INC3 - J=J+INC4 - 15 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 20 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 40 K=LA1,M,LA - KB=K+K-2 - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - DO 30 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 25 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) - D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) - I=I+INC3 - J=J+INC4 - 25 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 30 CONTINUE - JBASE=JBASE+JUMP - 40 CONTINUE - RETURN -! -! CODING FOR FACTOR 3 -! - 50 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - DO 60 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 55 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))) - C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))) - D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))) - D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))) - I=I+INC3 - J=J+INC4 - 55 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 60 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 80 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - DO 70 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 65 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)= - * C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - D(JB+J)= - * S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - C(JC+J)= - * C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - D(JC+J)= - * S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - I=I+INC3 - J=J+INC4 - 65 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 70 CONTINUE - JBASE=JBASE+JUMP - 80 CONTINUE - RETURN -! -! CODING FOR FACTOR 4 -! - 90 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - DO 100 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 95 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) - C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) - C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) - D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) - D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) - I=I+INC3 - J=J+INC4 - 95 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 100 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 120 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - DO 110 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 105 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - C(JC+J)= - * C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - D(JC+J)= - * S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - C(JB+J)= - * C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - D(JB+J)= - * S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - C(JD+J)= - * C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - D(JD+J)= - * S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 105 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 110 CONTINUE - JBASE=JBASE+JUMP - 120 CONTINUE - RETURN -! -! CODING FOR FACTOR 5 -! - 130 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - IE=ID+IINK - JE=JD+JINK - DO 140 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 135 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 135 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 140 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 160 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - KE=KD+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - C4=TRIGS(KE+1) - S4=TRIGS(KE+2) - DO 150 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 145 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)= - * C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JB+J)= - * S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JE+J)= - * C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JE+J)= - * S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JC+J)= - * C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JC+J)= - * S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - C(JD+J)= - * C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JD+J)= - * S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - I=I+INC3 - J=J+INC4 - 145 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 150 CONTINUE - JBASE=JBASE+JUMP - 160 CONTINUE - RETURN - END - - subroutine minmax (q,im,jm,qmin,qmax) - real*4 q(im,jm) - qmin = q(1,1) - qmax = q(1,1) - do j=1,jm - do i=1,im - qmin = min( qmin,q(i,j) ) - qmax = max( qmax,q(i,j) ) - enddo - enddo - return - end - - subroutine checkfile ( filename ) - character(*) filename - logical file_exists - inquire( file=trim(filename), exist=file_exists ) - if( file_exists ) return - print * - print *, 'File: ',trim(filename),' does not exist!' - print * - stop - end - - subroutine usage() - write(6,100) - 100 format( "Usage: " ,/ - . ,/ - . " rs_hinterp_$ARCH.x -dyn DYNRST" ,/ - . " -moist MOISTRST" ,/ - . " -other OtherRST1 OtherRST2 OtherRST3 ..." ,/ - . " -topo_old TOPO_OLD" ,/ - . " -topo_new TOPO_NEW" ,/ - . " -im IM_OUT" ,/ - . " -jm JM_OUT" ,/ - . ,/ - . "where:" ,/ - . ,/ - . " -dyn DYNRST: Filename for DYNAMICS_INTERNAL_RESTART" ,/ - . " -moist MOISTRST: Filename for MOIST_INTERNAL_RESTART" ,/ - . " -other OtherRST: Filename for Other Flat Binary_RESTART" ,/ - . " -topo_old TOPO_OLD: Filename for OLD Topography (associated with INPUT resolution)" ,/ - . " -topo_new TOPO_NEW: Filename for NEW Topography (associated with OUTPUT resolution)" ,/ - . " -im IM_OUT: IM Dimension for Output" ,/ - . " -jm JM_OUT: JM Dimension for Output" ,/ - . ,/ - . ) - error stop 7 - end subroutine usage - diff --git a/GEOS_Util/post/rs_numtiles.F90 b/GEOS_Util/post/rs_numtiles.F90 deleted file mode 100644 index e9e3a2a2..00000000 --- a/GEOS_Util/post/rs_numtiles.F90 +++ /dev/null @@ -1,83 +0,0 @@ -program rs_numtiles - - use iso_fortran_env - use MAPL - - implicit none - - character(256) :: fname1 - -#ifndef __GFORTRAN__ - integer :: ftell - external :: ftell -#endif - - integer :: bpos, epos, ntiles, nargs - - type(Netcdf4_Fileformatter) :: formatter - type(FileMetadata) :: cfg - integer :: rc, filetype - -! Usage -! ----- - - nargs = command_argument_count() - - if (nargs /= 1) then - write (output_unit,*) "rs_numtiles.x requires one input." - write (output_unit,*) " Usage: rs_numtiles.x " - write (output_unit,*) "" - write (output_unit,*) " NOTE: rs_numtiles.x will always return the correct number of tiles" - write (output_unit,*) " for NetCDF4 restarts, but binary restarts perhaps not. This" - write (output_unit,*) " This program looks at the first record of a binary restart. If" - write (output_unit,*) " that record has subtiles, it will be a multiple of the number" - write (output_unit,*) " of tiles." - error stop 2 - end if - - call get_command_argument(1, fname1) - -! Open INPUT Restart File -! ----------------------- - - call MAPL_NCIOGetFileType(trim(fname1), filetype, rc=rc) - - if (filetype == 0) then - call formatter%open(trim(fname1),pFIO_READ,rc=rc) - cfg = formatter%read(rc=rc) - else - open (unit=10, file=trim(fname1), form='unformatted') - end if - -! Determine NTILES -! ---------------- - - if (filetype == 0) then - ntiles = cfg%get_dimension('tile',rc=rc) - else - bpos=0 - read (10) -#ifdef __NAG_COMPILER_RELEASE - write (*,*) 'NAG does not provide ftell. Use only netCDF' - error stop 1 -#else - epos = ftell(10) ! ending position of file pointer -#endif - ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; - rewind 10 - end if - - write (output_unit,100) ntiles - -! Close INPUT Restart File -! ------------------------ - - if (filetype == 0) then - call formatter%close() - else - close (10) - end if - -100 format (1x,'Total Tiles: ',i10) - -end program rs_numtiles diff --git a/GEOS_Util/post/rs_vinterp.F90 b/GEOS_Util/post/rs_vinterp.F90 deleted file mode 100644 index c811420e..00000000 --- a/GEOS_Util/post/rs_vinterp.F90 +++ /dev/null @@ -1,1190 +0,0 @@ - program main - use MAPL_ConstantsMod - implicit none - -! ********************************************************************** -! ********************************************************************** -! **** **** -! **** Program to remap GEOS-5 FV & MOIST restarts in the vertical **** -! **** **** -! ********************************************************************** -! ********************************************************************** - - - character*256 dynrst, moistrst, topo - character*256, allocatable :: other_rst(:) - - integer headr1(6) - integer headr2(5) - integer nymd,nhms - integer im,jm,lm_in,lm_out,nt,rc - real undef, kappa, grav - -! restart variables and topography -! -------------------------------- - real*8, allocatable :: dp_in(:,:,:) - real*8, allocatable :: u_in(:,:,:) - real*8, allocatable :: v_in(:,:,:) - real*8, allocatable :: thv_in(:,:,:) - real*8, allocatable :: pk_in(:,:,:) - real*8, allocatable :: ple_in(:,:,:) - real*8, allocatable :: q_in(:,:,:,:) - real*8, allocatable :: ps_in(:,:) - real*8, allocatable :: ak_in(:) - real*8, allocatable :: bk_in(:) - real*8, allocatable :: phis(:,:) - - real*8, allocatable :: dp_out(:,:,:) - real*8, allocatable :: u_out(:,:,:) - real*8, allocatable :: v_out(:,:,:) - real*8, allocatable :: thv_out(:,:,:) - real*8, allocatable :: pk_out(:,:,:) - real*8, allocatable :: pke_out(:,:,:) - real*8, allocatable :: ple_out(:,:,:) - real*8, allocatable :: q_out(:,:,:,:) - real*8, allocatable :: ps_out(:,:) - real*8, allocatable :: ak_out(:) - real*8, allocatable :: bk_out(:) - -! Two extras if we are on the cubed sphere grid -! --------------------------------------------- - real*8, allocatable :: dz_out(:,:,:) - real*8, allocatable :: w_out(:,:,:) - - real*4, allocatable :: dum(:,:) - - character*256, allocatable :: arg(:) - character*8 date - character*1 char - character*2 hour - character*4 cim,cjm,clm - integer m,n,nargs,i,j,L - integer num,num_other_rst,nbeg,nend - integer, allocatable :: nt_other(:) - logical verbose - -! ********************************************************************** -! **** Initialize Filenames **** -! ********************************************************************** - - verbose = .false. - lm_out = -999 - undef = 1.0e15 - dynrst = 'fvcore_internal_restart' - moistrst = 'moist_internal_restart' - num_other_rst = 0 - - nargs = command_argument_count() - if(nargs == 0 ) call usage() - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-h' ) call usage() - if( trim(arg(n)).eq.'-help' ) call usage() - if( trim(arg(n)).eq.'-H' ) call usage() - if( trim(arg(n)).eq.'-Help' ) call usage() - if( trim(arg(n)).eq.'-v' ) verbose = .true. - if( trim(arg(n)).eq.'-verbose' ) verbose = .true. - - if( trim(arg(n)).eq.'-dynrst' ) then - dynrst = trim(arg(n+1)) - endif - - if( trim(arg(n)).eq.'-moistrst' ) then - moistrst = trim(arg(n+1)) - endif - - if( trim(arg(n)).eq.'-topo' ) then - topo = trim(arg(n+1)) - endif - - if( trim(arg(n)).eq.'-other' ) then - num = 1 - if( n+num.le.nargs ) then - read(arg(n+num),fmt='(a1)') char - do while (char.ne.'-' .and. n+num.ne.nargs ) - num = num+1 - read(arg(n+num),fmt='(a1)') char - enddo - if( char.eq.'-' ) num = num-1 - allocate ( other_rst(num) ) - do m=1,num - other_rst(m) = arg(n+m) - enddo - num_other_rst = num - endif - endif - - if( trim(arg(n)).eq.'-lm' ) read(arg(n+1),*) lm_out - enddo - if( lm_out.eq.-999 ) then - print * - print *, 'You must supply Output Vertical Resolution!' - print * - stop - endif - - print * - print *, ' dyn restart filename: ',trim(dynrst) - print *, 'moist restart filename: ',trim(moistrst) - print *, ' topo filename: ',trim(topo) - do n=1,num_other_rst - print *, ' other restart filename: ',trim(other_rst(n)) - enddo - -! ********************************************************************** -! **** Read dycore internal Restart **** -! ********************************************************************** - - open (10,file=trim(dynrst),form='unformatted',access='sequential') - read (10) headr1 - read (10) headr2 - - nymd = headr1(1)*10000 + headr1(2)*100 + headr1(3) - nhms = headr1(4)*10000 + headr1(5)*100 + headr1(6) - - im = headr2(1) - jm = headr2(2) - lm_in = headr2(3) - - print *, ' input resolution: ',im,jm,lm_in - print *, ' date: ',nymd,nhms - print * - - allocate ( u_in(im,jm,lm_in) ) - allocate ( v_in(im,jm,lm_in) ) - allocate ( thv_in(im,jm,lm_in) ) - allocate ( dp_in(im,jm,lm_in) ) - allocate ( pk_in(im,jm,lm_in) ) - allocate ( ple_in(im,jm,lm_in+1) ) - allocate ( ps_in(im,jm) ) - allocate ( ak_in(lm_in+1) ) - allocate ( bk_in(lm_in+1) ) - - read (10) ak_in - read (10) bk_in - - do L=1,lm_in - read(10) (( u_in(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm_in - read(10) (( v_in(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm_in - read(10) ((thv_in(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm_in+1 - read(10) ((ple_in(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm_in - read(10) (( pk_in(i,j,L),i=1,im),j=1,jm) - enddo - - close (10) - - ps_in(:,:) = ple_in(:,:,lm_in+1) - do L=lm_in,1,-1 - dp_in(:,:,L) = ple_in(:,:,L+1) - ple_in(:,:,L) - enddo - -! ********************************************************************** -! **** Read Moist Internal Restart **** -! ********************************************************************** - - allocate ( dum(im,jm) ) - - open (10,file=trim(moistrst),form='unformatted',access='sequential') - - nt = 0 - rc = 0 - do while (rc.eq.0) - read (10,iostat=rc) dum - if( rc.eq.0 ) then - nt = nt + 1 - allocate( q_out(im,jm,lm_in,nt) ) - q_out(:,:,1,nt) = dum - do L=2,lm_in - read (10,iostat=rc) dum - q_out(:,:,L,nt) = dum - enddo - if( nt.eq.1) then - allocate( q_in (im,jm,lm_in,nt) ) - q_in (:,:,:,nt) = q_out(:,:,:,nt) - else - q_out(:,:,:,1:nt-1) = q_in(:,:,:,1:nt-1) - deallocate( q_in ) - allocate( q_in (im,jm,lm_in,nt) ) - q_in = q_out - endif - print '(a,i4)', 'Reading Moist Restart for Field # ',nt-nbeg - deallocate( q_out ) - endif - enddo - print * - - close (10) - -! ********************************************************************** -! **** Read Other 3D-Restarts **** -! ********************************************************************** - - allocate( nt_other(0:num_other_rst) ) - nt_other(0) = nt - - if( num_other_rst.ne.0 ) then - - ! n = 0 - nbeg = nt - do m=1,num_other_rst - !open (10,file=trim(other_rst(m)),form='unformatted',access='direct',recl=im*jm*4) - open (10,file=trim(other_rst(m)),form='unformatted',access='sequential') - rc = 0 - do while (rc.eq.0) - ! n = n+1 - !read (10,iostat=rc,rec=n) dum - read (10,iostat=rc) dum - if( rc.eq.0 ) then - nt = nt + 1 - allocate( q_out(im,jm,lm_in,nt) ) - q_out(:,:,1,nt) = dum - do L=2,lm_in - !n = n+1 - !read (10,iostat=rc,rec=n) dum - read (10,iostat=rc) dum - if( rc.eq.0 ) then - q_out(:,:,L,nt) = dum - else - print *, trim(other_rst(m)),' not 3D!' - stop - endif - enddo - q_out(:,:,:,1:nt-1) = q_in(:,:,:,1:nt-1) - deallocate( q_in ) - allocate( q_in (im,jm,lm_in,nt) ) - q_in = q_out - print '(a,i2,a,i4)', 'Reading Other_Restart # ',m,' for Field # ',nt-nbeg - deallocate( q_out ) - endif - enddo - nt_other(m) = nt-nbeg - nbeg = nt - print * - close (10) - enddo - - endif - -! ********************************************************************** -! **** Read Topography Datasets **** -! ********************************************************************** - - allocate ( phis(im,jm) ) - - print *, 'Reading Topography Dataset: ',trim(topo) - open (10,file=trim(topo),form='unformatted',access='sequential') - read (10) dum - close(10) - - grav = MAPL_GRAV - phis = dum*grav - -! ********************************************************************** -! **** Remap State **** -! ********************************************************************** - - allocate ( u_out(im,jm,lm_out) ) - allocate ( v_out(im,jm,lm_out) ) - allocate ( thv_out(im,jm,lm_out) ) - allocate ( dp_out(im,jm,lm_out) ) - allocate ( pk_out(im,jm,lm_out) ) - allocate ( pke_out(im,jm,lm_out+1) ) - allocate ( ple_out(im,jm,lm_out+1) ) - allocate ( q_out(im,jm,lm_out,nt) ) - allocate ( ps_out(im,jm) ) - allocate ( ak_out(lm_out+1) ) - allocate ( bk_out(lm_out+1) ) - allocate ( dz_out(im,jm,lm_out) ) - allocate ( w_out(im,jm,lm_out) ) - -! ---------------------------------- - - print *, 'Calling REMAP ...' - call remap ( ps_out,dp_out,u_out,v_out,thv_out,q_out,phis,lm_out, & - ps_in ,dp_in ,u_in ,v_in ,thv_in ,q_in ,phis,lm_in , & - im,jm,nt,ak_out,bk_out,verbose ) - print *, ' REMAP Finished' - -! ---------------------------------- - - kappa = MAPL_KAPPA - - ple_out(:,:,lm_out+1) = ps_out(:,:) - do L=lm_out,1,-1 - ple_out(:,:,L) = ple_out(:,:,L+1)-dp_out(:,:,L) - enddo - dz_out = 0. - w_out = 0. - -! Ensure top edge = ptop -! ---------------------- - dp_out(:,:,1) = ple_out(:,:,2)-ak_out(1) - ple_out(:,:,1) = ple_out(:,:,2)-dp_out(:,:,1) - - pke_out(:,:,:) = ple_out(:,:,:)**kappa - - do L=1,lm_out - pk_out(:,:,L) = ( pke_out(:,:,L+1)-pke_out(:,:,L) ) & - / ( kappa*log(ple_out(:,:,L+1)/ple_out(:,:,L)) ) - enddo - -! ********************************************************************** -! **** Write dycore internal Restart **** -! ********************************************************************** - - write(date,101) nymd - write(hour,102) nhms/10000 - write(cim ,103) im - write(cjm ,103) jm - write(clm ,103) lm_out - 101 format(i8.8) - 102 format(i2.2) - 103 format(i4.4) - - dynrst = trim(dynrst) // '.r' // cim // 'x' // cjm // 'x' // clm // & - '.e' // date // '_' // hour // 'z' - - print * - print *, ' Creating: ',trim(dynrst) - print *, ' output resolution: ',im,jm,lm_out - print *, ' date: ',nymd,nhms - print * - open (10,file=trim(dynrst),form='unformatted',access='sequential') - - headr2(3) = lm_out - write(10) headr1 - write(10) headr2 - - write(10) ak_out - write(10) bk_out - - do L=1,lm_out - write(10) (( u_out(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm_out - write(10) (( v_out(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm_out - write(10) ((thv_out(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm_out+1 - write(10) ((ple_out(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm_out - write(10) (( pk_out(i,j,L),i=1,im),j=1,jm) - enddo -! if we are on the cube (check for jm being equal to im*6) write out dz and w - if(jm.eq.im*6) then - do L=1,lm_out - write(10) (( dz_out(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm_out - write(10) (( w_out(i,j,L),i=1,im),j=1,jm) - enddo - print *,' Cubed Sphere Grid: Writing zero fields of DZ and W ' - print * - endif - - close (10) - -! ********************************************************************** -! **** Write moist internal Restart **** -! ********************************************************************** - - moistrst = trim(moistrst) // '.r' // cim // 'x' // cjm // 'x' // clm // & - '.e' // date // '_' // hour // 'z' - print *, ' Creating: ',trim(moistrst) - - open (10,file=trim(moistrst),form='unformatted',access='sequential') - do n=1,nt_other(0) - print '(a,i4)', ' Writing Moist Restart for Field # ',n - do L=1,lm_out - dum(:,:) = q_out(:,:,L,n) - write(10) dum - enddo - enddo - print * - close (10) - -! ********************************************************************** -! **** Write Other Internal Restarts **** -! ********************************************************************** - - if( num_other_rst.ne.0 ) then - - nbeg = nt_other(0) + 1 - do m=1,num_other_rst - nend = nbeg + nt_other(m)-1 - - other_rst(m) = trim(other_rst(m)) // '.r' // cim // 'x' // cjm // 'x' // clm // & - '.e' // date // '_' // hour // 'z' - print *, ' Creating: ',trim(other_rst(m)) - - open (10,file=trim(other_rst(m)),form='unformatted',access='sequential') - - do n=nbeg,nend - print '(a,i2,a,i4)', ' Writing Other_Restart # ',m,' for Field # ',n-nbeg+1 - do L=1,lm_out - dum(:,:) = q_out(:,:,L,n) - write(10) dum - enddo - enddo - close (10) - nbeg = nend + 1 - print * - enddo - - endif - - stop - end - - subroutine remap ( ps1,dp1,u1,v1,thv1,q1,phis1,lm1, & - ps2,dp2,u2,v2,thv2,q2,phis2,lm2,im,jm,nt,ak1,bk1,verbose ) - -! ******************************************************************************* -! ***** ***** -! ***** Program to remap Target analysis variables (ps2,dp2,u2,v2,t2,q2) ***** -! ***** onto Model grid variables (ps1,dp1,u1,v1,thv1,q1). Program ***** -! ***** allows for differenct topographies between Analysis and Model. ***** -! ***** ***** -! ******************************************************************************* - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - integer im,jm,lm1,lm2,nt - -! Output Model Variables -! ---------------------- - real dp1(im,jm,lm1) - real u1(im,jm,lm1) - real v1(im,jm,lm1) - real thv1(im,jm,lm1) - real q1(im,jm,lm1,nt) - real ps1(im,jm) - real phis1(im,jm) - real ak1(lm1+1) - real bk1(lm1+1) - -! Input Analysis Variables -! ------------------------ - real dp2(im,jm,lm2) - real u2(im,jm,lm2) - real v2(im,jm,lm2) - real thv2(im,jm,lm2) - real q2(im,jm,lm2,nt) - real ps2(im,jm) - real phis2(im,jm) - real ak2(lm2+1) - real bk2(lm2+1) - - logical verbose - -! Local variables -! --------------- - real pe1(im,jm,lm1+1) - real pe2(im,jm,lm2+1) - real pk (im,jm,lm2 ) - real pke1(im,jm,lm1+1) - real pke2(im,jm,lm2+1) - real phi2(im,jm,lm2+1) - - real, allocatable :: plevs(:) - - real kappa,cp,dum,dum1,dum2 - real rgas,eps,rvap,grav - integer i,j,L,kdum - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - -! Create AK & BK for each vertical dimension -! ------------------------------------------ - call set_eta ( lm1,kdum,dum,dum,ak1,bk1 ) - call set_eta ( lm2,kdum,dum,dum,ak2,bk2 ) - - if( verbose ) then - allocate( plevs(lm2) ) - do L=1,lm2 - plevs(L) = 0.5*( ak2(L) + 100000.0*bk2(L) & - + ak2(L+1) + 100000.0*bk2(L+1) ) - enddo - print *, 'Input PLEVS:' - print *, (plevs(L)/100,L=1,lm2) - - deallocate( plevs ) - allocate( plevs(lm1) ) - do L=1,lm1 - plevs(L) = 0.5*( ak1(L) + 100000.0*bk1(L) & - + ak1(L+1) + 100000.0*bk1(L+1) ) - enddo - print *, 'Output PLEVS:' - print *, (plevs(L)/100,L=1,lm1) - deallocate( plevs ) - endif - -! Create Pressure Variables -! ------------------------- - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1 (i,j,L) = ak1(L)+bk1(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - - do L=1,lm2+1 - do j=1,jm - do i=1,im - pe2 (i,j,L) = ak2(L)+bk2(L)*ps2(i,j) - pke2(i,j,L) = pe2(i,j,L)**kappa - enddo - enddo - enddo - do L=1,lm2 - do j=1,jm - do i=1,im - dp2(i,j,L) = pe2(i,j,L+1)-pe2(i,j,L) - enddo - enddo - enddo - -! Construct target virtual potential temperature -! ---------------------------------------------- - do L=1,lm2 - pk(:,:,L) = ( pke2(:,:,L+1)-pke2(:,:,L) )/( kappa*log(pe2(:,:,L+1)/pe2(:,:,L)) ) - enddo - -! Construct target analysis heights -! --------------------------------- - phi2(:,:,lm2+1) = phis2(:,:) - do L=lm2,1,-1 - phi2(:,:,L) = phi2(:,:,L+1) + cp*thv2(:,:,L)*( pke2(:,:,L+1)-pke2(:,:,L) ) - enddo - -! Compute new surface pressure consistent with target surface pressure and topography -! ----------------------------------------------------------------------------------- - do j=1,jm - do i=1,im - L = lm2 - do while ( phi2(i,j,L).lt.phis1(i,j) ) - L = L-1 - enddo - ps1(i,j) = pe2(i,j,L+1)*( 1+(phi2(i,j,L+1)-phis1(i,j))/(cp*thv2(i,j,L)*pke2(i,j,L+1)) )**(1.0/kappa) - enddo - enddo - -! Construct model pressure variables using new surface pressure -! ------------------------------------------------------------- - print * - L = 1 - dum1 = (ak1(L)+bk1(L)*100000.0)/100 - write(6,1000) L,ak1(L),bk1(L),dum1 - 1000 format(1x,'L: ',i3,4x,'ak: ',f10.3,' bk: ',f10.8,4x,'pe: ',f8.3) - do L=2,lm1+1 - dum2 = (ak1(L)+bk1(L)*100000.0)/100 - write(6,1001) L,ak1(L),bk1(L),dum2,dum2-dum1 - 1001 format(1x,'L: ',i3,4x,'ak: ',f10.3,' bk: ',f10.8,4x,'pe: ',f8.3,3x,'dp: ',f7.3) - dum1 = dum2 - enddo - print * - - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1 (i,j,L) = ak1(L)+bk1(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -! Map target analysis onto grid defined by new surface pressure -! ------------------------------------------------------------- - print *, 'Calling GMAP, LM_in : ',lm2 - print *, ' LM_out: ',lm1 - call gmap ( im,jm,nt, & - lm2, pke2, pe2, u2, v2, thv2, q2,& - lm1, pke1, pe1, u1, v1, thv1, q1 ) - - return - end - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine gmap(im, jm, nq, & - km, pk3d_m, pe3d_m, u_m, v_m, pt_m, q_m, & - kn, pk3d_n, pe3d_n, u_n, v_n, pt_n, q_n ) -!****6***0*********0*********0*********0*********0*********0**********72 - - implicit none - - integer im, jm - integer km, kn, nq - -! Input: -! original data km-level - - real u_m(im,jm,km) - real v_m(im,jm,km) - real pt_m(im,jm,km) - real q_m(im,jm,km,nq) - real pk3d_m(im,jm,km+1) - real pe3d_m(im,jm,km+1) - - -! Output: -! New data (kn-level) - real u_n(im,jm,kn) - real v_n(im,jm,kn) - real pt_n(im,jm,kn) - real q_n(im,jm,kn,nq) - real pk3d_n(im,jm,kn+1) - real pe3d_n(im,jm,kn+1) - -! local (private) - integer i, j, k, n - - real pe1(im,km+1),pe2(im,kn+1) - real pk1(im,km+1),pk2(im,kn+1) - real dp1(im,km) ,dp2(im,kn) - real u1(im,km) , u2(im,kn) - real v1(im,km) , v2(im,kn) - real t1(im,km) , t2(im,kn) - real q1(im,km) , q2(im,kn) - - real undef - real big - parameter ( undef = 1.e15 ) - parameter ( big = 1.e10 ) - - - do 2000 j=1,jm - -! Copy original data to local 2D arrays. - - do k=1,km+1 - do i=1,im - pe1(i,k) = pe3d_m(i,j,k) - pk1(i,k) = pk3d_m(i,j,k) - enddo - enddo - - do k=1,kn+1 - do i=1,im - pe2(i,k) = pe3d_n(i,j,k) - pk2(i,k) = pk3d_n(i,j,k) - enddo - enddo - - do k=1,km - do i=1,im - dp1(i,k) = pk1(i,k+1)-pk1(i,k) - u1(i,k) = u_m(i,j,k) - v1(i,k) = v_m(i,j,k) - t1(i,k) = pt_m(i,j,k) - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pk2(i,k+1)-pk2(i,k) - enddo - enddo - -! map pt -! ------ - call mappm ( km, pk1, dp1, t1, kn, pk2, t2, im, 1, 7 ) - - do k=1,km - do i=1,im - dp1(i,k) = pe1(i,k+1)-pe1(i,k) - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pe2(i,k+1)-pe2(i,k) - enddo - enddo - -! map u,v -! ------- - call mappm ( km, pe1, dp1, u1, kn, pe2, u2, im, -1, 7 ) - call mappm ( km, pe1, dp1, v1, kn, pe2, v2, im, -1, 7 ) - -! map q -! ------- - do n=1,nq - do k=1,km - do i=1,im - q1(i,k) = q_m(i,j,k,n) - enddo - enddo - call mappm ( km, pe1, dp1, q1, kn, pe2, q2, im, 0, 7 ) - do k=1,kn - do i=1,im - q_n(i,j,k,n) = q2(i,k) - enddo - enddo - enddo - - do k=1,kn - do i=1,im - u_n(i,j,k) = u2(i,k) - v_n(i,j,k) = v2(i,k) - pt_n(i,j,k) = t2(i,k) - enddo - enddo - -2000 continue - - return - end - - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine mappm(km, pe1, dp1, q1, kn, pe2, q2, im, iv, kord) -!****6***0*********0*********0*********0*********0*********0**********72 -! IV = 0: constituents -! IV = 1: potential temp -! IV =-1: winds -! -! Mass flux preserving mapping: q1(im,km) -> q2(im,kn) -! -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate - - parameter (kmax = 200) - parameter (R3 = 1./3., R23 = 2./3.) - - real dp1(im,km) - real q1(im,km), q2(im,kn) - real pe1(im,km+1), pe2(im,kn+1) - integer kord - -! local work arrays - real a4(4,im,km) - - do k=1,km - do i=1,im - a4(1,i,k) = q1(i,k) - enddo - enddo - - call ppm2m(a4, dp1, im, km, iv, kord) - -! Lowest layer: constant distribution - do i=1, im - a4(2,i,km) = q1(i,km) - a4(3,i,km) = q1(i,km) - a4(4,i,km) = 0. - enddo - - do 5555 i=1,im - k0 = 1 - do 555 k=1,kn - - if(pe2(i,k+1) .le. pe1(i,1)) then -! Entire grid above old ptop - q2(i,k) = a4(2,i,1) - elseif(pe2(i,k) .ge. pe1(i,km+1)) then -! Entire grid below old ps - q2(i,k) = a4(3,i,km) - elseif(pe2(i,k ) .lt. pe1(i,1) .and. & - pe2(i,k+1) .gt. pe1(i,1)) then -! Part of the grid above ptop - q2(i,k) = a4(1,i,1) - else - - do 45 L=k0,km -! locate the top edge at pe2(i,k) - if( pe2(i,k) .ge. pe1(i,L) .and. & - pe2(i,k) .le. pe1(i,L+1) ) then - k0 = L - PL = (pe2(i,k)-pe1(i,L)) / dp1(i,L) - if(pe2(i,k+1) .le. pe1(i,L+1)) then - -! entire new grid is within the original grid - PR = (pe2(i,k+1)-pe1(i,L)) / dp1(i,L) - TT = R3*(PR*(PR+PL)+PL**2) - q2(i,k) = a4(2,i,L) + 0.5*(a4(4,i,L)+a4(3,i,L) & - - a4(2,i,L))*(PR+PL) - a4(4,i,L)*TT - goto 555 - else -! Fractional area... - delp = pe1(i,L+1) - pe2(i,k) - TT = R3*(1.+PL*(1.+PL)) - qsum = delp*(a4(2,i,L)+0.5*(a4(4,i,L)+ & - a4(3,i,L)-a4(2,i,L))*(1.+PL)-a4(4,i,L)*TT) - dpsum = delp - k1 = L + 1 - goto 111 - endif - endif -45 continue - -111 continue - do 55 L=k1,km - if( pe2(i,k+1) .gt. pe1(i,L+1) ) then - -! Whole layer.. - - qsum = qsum + dp1(i,L)*q1(i,L) - dpsum = dpsum + dp1(i,L) - else - delp = pe2(i,k+1)-pe1(i,L) - esl = delp / dp1(i,L) - qsum = qsum + delp * (a4(2,i,L)+0.5*esl* & - (a4(3,i,L)-a4(2,i,L)+a4(4,i,L)*(1.-r23*esl)) ) - dpsum = dpsum + delp - k0 = L - goto 123 - endif -55 continue - delp = pe2(i,k+1) - pe1(i,km+1) - if(delp .gt. 0.) then -! Extended below old ps - qsum = qsum + delp * a4(3,i,km) - dpsum = dpsum + delp - endif -123 q2(i,k) = qsum / dpsum - endif -555 continue -5555 continue - - return - end - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine ppm2m(a4,delp,im,km,iv,kord) -!****6***0*********0*********0*********0*********0*********0**********72 -! iv = 0: positive definite scalars -! iv = 1: others -! iv =-1: winds - - implicit none - - integer im, km, lmt, iv - integer kord - integer i, k, km1 - real a4(4,im,km), delp(im,km) - -! local arrays. - real dc(im,km),delq(im,km) - real h2(im,km) - real a1, a2, c1, c2, c3, d1, d2 - real qmax, qmin, cmax, cmin - real qm, dq, tmp - -! Local scalars: - real qmp - real lac - - km1 = km - 1 - - do 500 k=2,km - do 500 i=1,im - delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) -500 a4(4,i,k ) = delp(i,k-1) + delp(i,k) - - do 1220 k=2,km1 - do 1220 i=1,im - c1 = (delp(i,k-1)+0.5*delp(i,k))/a4(4,i,k+1) - c2 = (delp(i,k+1)+0.5*delp(i,k))/a4(4,i,k) - tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / & - (a4(4,i,k)+delp(i,k+1)) - qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k) - qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp) -1220 continue - -!****6***0*********0*********0*********0*********0*********0**********72 -! 4th order interpolation of the provisional cell edge value -!****6***0*********0*********0*********0*********0*********0**********72 - - do 12 k=3,km1 - do 12 i=1,im - c1 = delq(i,k-1)*delp(i,k-1) / a4(4,i,k) - a1 = a4(4,i,k-1) / (a4(4,i,k) + delp(i,k-1)) - a2 = a4(4,i,k+1) / (a4(4,i,k) + delp(i,k)) - a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(a4(4,i,k-1)+a4(4,i,k+1)) * & - ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - & - delp(i,k-1)*a1*dc(i,k ) ) -12 continue - -! Area preserving cubic with 2nd deriv. = 0 at the boundaries -! Top - do i=1,im - d1 = delp(i,1) - d2 = delp(i,2) - qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) - dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) - c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) - c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1) - a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2) - dc(i,1) = a4(1,i,1) - a4(2,i,1) -! No over- and undershoot condition - cmax = max(a4(1,i,1), a4(1,i,2)) - cmin = min(a4(1,i,1), a4(1,i,2)) - a4(2,i,2) = max(cmin,a4(2,i,2)) - a4(2,i,2) = min(cmax,a4(2,i,2)) - enddo - - if(iv == 0) then - do i=1,im - a4(2,i,1) = max(0.,a4(2,i,1)) - a4(2,i,2) = max(0.,a4(2,i,2)) - enddo - elseif(iv == -1) then - do i=1,im - if( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. - enddo - endif - -!****6***0*********0*********0*********0*********0*********0**********72 - -! Bottom -! Area preserving cubic with 2nd deriv. = 0 at the surface - do 15 i=1,im - d1 = delp(i,km) - d2 = delp(i,km1) - qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) - dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) - c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) - c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1) - a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km) - dc(i,km) = a4(3,i,km) - a4(1,i,km) -!****6***0*********0*********0*********0*********0*********0**********72 -! No over- and undershoot condition - cmax = max(a4(1,i,km), a4(1,i,km1)) - cmin = min(a4(1,i,km), a4(1,i,km1)) - a4(2,i,km) = max(cmin,a4(2,i,km)) - a4(2,i,km) = min(cmax,a4(2,i,km)) -!****6***0*********0*********0*********0*********0*********0**********72 -15 continue - - if(iv .eq. 0) then - do i=1,im - a4(2,i,km) = max(0.,a4(2,i,km)) - a4(3,i,km) = max(0.,a4(3,i,km)) - enddo - endif - - do 20 k=1,km1 - do 20 i=1,im - a4(3,i,k) = a4(2,i,k+1) -20 continue -! -! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) -! - -! Top 2 and bottom 2 layers always use monotonic mapping - - do k=1,2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) - enddo - - if(kord == 7) then -!****6***0*********0*********0*********0*********0*********0**********72 -! Huynh's 2nd constraint -!****6***0*********0*********0*********0*********0*********0**********72 - do k=2, km1 - do i=1,im - h2(i,k) = delq(i,k) - delq(i,k-1) - enddo - enddo - - do 4000 k=3, km-2 - do 3000 i=1, im -! Right edges - qmp = a4(1,i,k) + 2.0*delq(i,k-1) - lac = a4(1,i,k) + 1.5*h2(i,k-1) + 0.5*delq(i,k-1) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax) -! Left edges - qmp = a4(1,i,k) - 2.0*delq(i,k) - lac = a4(1,i,k) + 1.5*h2(i,k+1) - 0.5*delq(i,k) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax) -! Recompute A6 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) -3000 continue -! Additional constraint to prevent negatives - if (iv == 0) then - call kmppm(dc(1,k),a4(1,1,k),im, 2) - endif -4000 continue - - else - - lmt = kord - 3 - lmt = max(0, lmt) - if (iv .eq. 0) lmt = min(2, lmt) - - do k=3, km-2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, lmt) - enddo - endif - - do 5000 k=km1,km - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) -5000 continue - - return - end - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine kmppm(dm, a4, km, lmt) -!****6***0*********0*********0*********0*********0*********0**********72 - implicit none - - real r12 - parameter (r12 = 1./12.) - - integer km, lmt - integer i - real a4(4,km),dm(km) - real da1, da2, a6da - real fmin - real qmp - - if (lmt .eq. 3) return -! Full constraint - - if(lmt .eq. 0) then - do 100 i=1,km - if(dm(i) .eq. 0.) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da .lt. -da2) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da .gt. da2) then - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif -100 continue - elseif (lmt .eq. 2) then -! Positive definite - -! Positive definite constraint - do 250 i=1,km - if(abs(a4(3,i)-a4(2,i)) .ge. -a4(4,i)) go to 250 - fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 - if(fmin.ge.0.) go to 250 - if(a4(1,i).lt.a4(3,i) .and. a4(1,i).lt.a4(2,i)) then - a4(3,i) = a4(1,i) - a4(2,i) = a4(1,i) - a4(4,i) = 0. - elseif(a4(3,i) .gt. a4(2,i)) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - else - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif -250 continue - - elseif (lmt == 1) then - -! Improved full monotonicity constraint (Lin) -! Note: no need to provide first guess of A6 <-- a4(4,i) - - do i=1, km - qmp = 2.*dm(i) - a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) - a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) - a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) ) - enddo - endif - - return - end - subroutine minmax ( q,name,im,jm,lm ) - character*4 name - real q(im,jm,lm) - qmax = q(1,1,1) - qmin = q(1,1,1) - do l=1,lm - do j=1,jm - do i=1,im - qmax = max( qmax,q(i,j,L) ) - qmin = min( qmin,q(i,j,L) ) - enddo - enddo - enddo - print *, name,' max: ',qmax,' min: ',qmin - return - end - subroutine usage() - print *, "Usage: " - print * - print *, " rs_vinterp.x -dynrst dynrst_fname Default: fvcore_internal_restart" - print *, " -moistrst moistrst_fname Default: moist_internal_restart" - print *, " -topo topo_fname" - print *, " -lm LM" - print * - print *, "where:" - print *, "-----" - print *, " -dynrst dynrst_fname: Filename of dynamics internal restart" - print *, " -moistrst moistrst_fname: Filename of moist internal restart" - print *, " -topo topo_fname: Filename of topography" - print *, " -lm LM: Output Veritcal Resolution" - print * - print *, "creates updated restarts at new LM resolution" - print *, "---------------------------------------------" - print * - error stop 7 - end diff --git a/GEOS_Util/post/rs_vinterp_scm.F90 b/GEOS_Util/post/rs_vinterp_scm.F90 deleted file mode 100644 index 7043c0cf..00000000 --- a/GEOS_Util/post/rs_vinterp_scm.F90 +++ /dev/null @@ -1,1302 +0,0 @@ - program main - use MAPL_ConstantsMod - implicit none - -! ********************************************************************** -! ********************************************************************** -! **** **** -! **** Program to remap GEOS-5 FV & MOIST restarts in the vertical **** -! **** **** -! ********************************************************************** -! ********************************************************************** - - - character*256 dynrst, moistrst, topo, datmodynrst - character*256, allocatable :: other_rst(:) - - integer im,jm,lm_in,lm_out,nt,rc - real undef, kappa, grav - -! restart variables and topography -! -------------------------------- - real*8, allocatable :: dp_in(:,:,:) - real*8, allocatable :: u_in(:,:,:) - real*8, allocatable :: v_in(:,:,:) - real*8, allocatable :: thv_in(:,:,:) - real*8, allocatable :: pk_in(:,:,:) - real*8, allocatable :: ple_in(:,:,:) - real*8, allocatable :: q_in(:,:,:,:) - real*8, allocatable :: ps_in(:,:) - real*8, allocatable :: phis(:,:) - real*8, allocatable :: pke_in(:,:,:) - - real*8, allocatable :: dp_out(:,:,:) - real*8, allocatable :: u_out(:,:,:) - real*8, allocatable :: v_out(:,:,:) - real*8, allocatable :: thv_out(:,:,:) - real*8, allocatable :: pk_out(:,:,:) - real*8, allocatable :: pke_out(:,:,:) - real*8, allocatable :: ple_out(:,:,:) - real*8, allocatable :: q_out(:,:,:,:) - real*8, allocatable :: ps_out(:,:) - real*8, allocatable :: ak_out(:) - real*8, allocatable :: bk_out(:) - -! Two extras if we are on the cubed sphere grid -! --------------------------------------------- - real*8, allocatable :: dz_out(:,:,:) - real*8, allocatable :: w_out(:,:,:) - - real*4, allocatable :: dum(:,:) - - real*4, allocatable :: dum1(:) - real*4, allocatable :: dum3e(:,:,:) - real*4, allocatable :: dum3l(:,:,:) - -! MAT New fields -! -------------- - - real*8, allocatable :: t_in(:,:,:) - real*8, allocatable :: om_in(:,:,:) - real*8, allocatable :: oml_in(:,:,:) - real*8, allocatable :: pref_in(:) - - real*8, allocatable :: t_out(:,:,:) - real*8, allocatable :: om_out(:,:,:) - real*8, allocatable :: oml_out(:,:,:) - real*8, allocatable :: pref_out(:) - - character*256, allocatable :: arg(:) - character*1 char - character*4 cim,cjm,clm - integer m,n,nargs,L - integer num,num_other_rst,nbeg,nend - integer, allocatable :: nt_other(:) - logical verbose - real eps - -! ********************************************************************** -! **** Initialize Filenames **** -! ********************************************************************** - - verbose = .false. - lm_in = -999 - lm_out = -999 - undef = 1.0e15 - datmodynrst = 'datmodyn_internal_rst' - moistrst = 'moist_internal_rst' - num_other_rst = 0 - - nargs = command_argument_count() - if(nargs == 0 ) call usage() - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-h' ) call usage() - if( trim(arg(n)).eq.'-help' ) call usage() - if( trim(arg(n)).eq.'-H' ) call usage() - if( trim(arg(n)).eq.'-Help' ) call usage() - if( trim(arg(n)).eq.'-v' ) verbose = .true. - if( trim(arg(n)).eq.'-verbose' ) verbose = .true. - - if( trim(arg(n)).eq.'-dynrst' ) then - dynrst = trim(arg(n+1)) - endif - - if( trim(arg(n)).eq.'-datmodynrst' ) then - datmodynrst = trim(arg(n+1)) - endif - - if( trim(arg(n)).eq.'-moistrst' ) then - moistrst = trim(arg(n+1)) - endif - - if( trim(arg(n)).eq.'-topo' ) then - topo = trim(arg(n+1)) - endif - - if( trim(arg(n)).eq.'-other' ) then - num = 1 - if( n+num.le.nargs ) then - read(arg(n+num),fmt='(a1)') char - do while (char.ne.'-' .and. n+num.ne.nargs ) - num = num+1 - read(arg(n+num),fmt='(a1)') char - enddo - if( char.eq.'-' ) num = num-1 - allocate ( other_rst(num) ) - do m=1,num - other_rst(m) = arg(n+m) - enddo - num_other_rst = num - endif - endif - - if( trim(arg(n)).eq.'-lm_in' ) read(arg(n+1),*) lm_in - if( trim(arg(n)).eq.'-lm_out' ) read(arg(n+1),*) lm_out - enddo - if( lm_in.eq.-999 ) then - print * - print *, 'You must supply Input Vertical Resolution!' - print * - stop - endif - - if( lm_out.eq.-999 ) then - print * - print *, 'You must supply Output Vertical Resolution!' - print * - stop - endif - - print * - print *, ' dyn restart filename: ',trim(dynrst) - print *, ' datmodyn restart filename: ',trim(datmodynrst) - print *, ' moist restart filename: ',trim(moistrst) - print *, ' topo filename: ',trim(topo) - do n=1,num_other_rst - print *, ' other restart filename: ',trim(other_rst(n)) - enddo - -! ********************************************************************** -! **** Read datmodyn internal Restart **** -! ********************************************************************** - - open (10,file=trim(datmodynrst),form='unformatted',access='sequential') - - im = 1 - jm = 1 - - print *, ' input datmo resolution: ',im,jm,lm_in - print * - - allocate ( pref_in( lm_in+1) ) - allocate ( ple_in(im,jm,lm_in+1) ) - allocate ( t_in(im,jm,lm_in ) ) - allocate ( u_in(im,jm,lm_in ) ) - allocate ( v_in(im,jm,lm_in ) ) - allocate ( om_in(im,jm,lm_in+1) ) - allocate ( ps_in(im,jm ) ) - allocate ( dp_in(im,jm,lm_in ) ) - - allocate ( thv_in(im,jm,lm_in ) ) - allocate ( pk_in(im,jm,lm_in ) ) - allocate ( pke_in(im,jm,lm_in+1) ) - allocate ( oml_in(im,jm,lm_in ) ) - - allocate ( dum1( lm_in+1) ) - allocate ( dum3l(im,jm,lm_in ) ) - allocate ( dum3e(im,jm,lm_in+1) ) - - read (10) dum1 - pref_in = dum1 - if (verbose) write (*,*) "pref_in: ", pref_in - - do L=1,lm_in+1 - read(10) dum3e(1,1,L) - ple_in(1,1,L) = dum3e(1,1,L) - enddo - if (verbose) write (*,*) "ple_in: ", ple_in - do L=1,lm_in - read(10) dum3l(1,1,L) - t_in(1,1,L) = dum3l(1,1,L) - enddo - if (verbose) write (*,*) "t_in: ", t_in - do L=1,lm_in - read(10) dum3l(1,1,L) - u_in(1,1,L) = dum3l(1,1,L) - enddo - if (verbose) write (*,*) "u_in: ", u_in - do L=1,lm_in - read(10) dum3l(1,1,L) - v_in(1,1,L) = dum3l(1,1,L) - enddo - if (verbose) write (*,*) "v_in: ", v_in - do L=1,lm_in+1 - read(10) dum3e(1,1,L) - om_in(1,1,L) = dum3e(1,1,L) - enddo - if (verbose) write (*,*) "om_in: ", om_in - - close (10) - - ps_in(:,:) = ple_in(:,:,lm_in+1) - do L=lm_in,1,-1 - dp_in(:,:,L) = ple_in(:,:,L+1) - ple_in(:,:,L) - enddo - - deallocate ( dum1) - deallocate (dum3l) - deallocate (dum3e) - -! ********************************************************************** -! **** Read Moist Internal Restart **** -! ********************************************************************** - - allocate ( dum(im,jm) ) - - open (10,file=trim(moistrst),form='unformatted',access='sequential') - - nt = 0 - rc = 0 - nbeg = 0 - do while (rc.eq.0) - read (10,iostat=rc) dum - if( rc.eq.0 ) then - nt = nt + 1 - allocate( q_out(im,jm,lm_in,nt) ) - q_out(:,:,1,nt) = dum - do L=2,lm_in - read (10,iostat=rc) dum - q_out(:,:,L,nt) = dum - enddo - if( nt.eq.1) then - allocate( q_in (im,jm,lm_in,nt) ) - q_in (:,:,:,nt) = q_out(:,:,:,nt) - else - q_out(:,:,:,1:nt-1) = q_in(:,:,:,1:nt-1) - deallocate( q_in ) - allocate( q_in (im,jm,lm_in,nt) ) - q_in = q_out - endif - print '(a,i4)', 'Reading Moist Restart for Field # ',nt-nbeg - if (verbose) write(*,*) 'Field #', nt-nbeg, ': ', q_in(:,:,:,nt-nbeg) - deallocate( q_out ) - endif - enddo - print * - - close (10) - -! ********************************************************************** -! **** Read Other 3D-Restarts **** -! ********************************************************************** - - allocate( nt_other(0:num_other_rst) ) - nt_other(0) = nt - - if( num_other_rst.ne.0 ) then - - ! n = 0 - nbeg = nt - do m=1,num_other_rst - !open (10,file=trim(other_rst(m)),form='unformatted',access='direct',recl=im*jm*4) - open (10,file=trim(other_rst(m)),form='unformatted',access='sequential') - rc = 0 - do while (rc.eq.0) - ! n = n+1 - !read (10,iostat=rc,rec=n) dum - read (10,iostat=rc) dum - if( rc.eq.0 ) then - nt = nt + 1 - allocate( q_out(im,jm,lm_in,nt) ) - q_out(:,:,1,nt) = dum - do L=2,lm_in - !n = n+1 - !read (10,iostat=rc,rec=n) dum - read (10,iostat=rc) dum - if( rc.eq.0 ) then - q_out(:,:,L,nt) = dum - else - print *, trim(other_rst(m)),' not 3D!' - stop - endif - enddo - q_out(:,:,:,1:nt-1) = q_in(:,:,:,1:nt-1) - deallocate( q_in ) - allocate( q_in (im,jm,lm_in,nt) ) - q_in = q_out - print '(a,i2,a,i4)', 'Reading Other_Restart # ',m,' for Field # ',nt-nbeg - deallocate( q_out ) - endif - enddo - nt_other(m) = nt-nbeg - nbeg = nt - print * - close (10) - enddo - - endif - -! ********************************************************************** -! **** Read Topography Datasets **** -! ********************************************************************** - - allocate ( phis(im,jm) ) - - print *, 'Reading Topography Dataset: ',trim(topo) - open (10,file=trim(topo),form='unformatted',access='sequential') - read (10) dum - close(10) - - grav = MAPL_GRAV - phis = dum*grav - -! ********************************************************************** -! **** Remap State **** -! ********************************************************************** - - allocate ( ak_out(lm_out+1) ) - allocate ( bk_out(lm_out+1) ) - - allocate ( pref_out(lm_out+1) ) - allocate ( ple_out(im,jm,lm_out+1) ) - allocate ( t_out(im,jm,lm_out) ) - allocate ( u_out(im,jm,lm_out) ) - allocate ( v_out(im,jm,lm_out) ) - allocate ( om_out(im,jm,lm_out+1) ) - allocate ( oml_out(im,jm,lm_out) ) - - allocate ( thv_out(im,jm,lm_out) ) - allocate ( dp_out(im,jm,lm_out) ) - allocate ( pk_out(im,jm,lm_out) ) - allocate ( pke_out(im,jm,lm_out+1) ) - allocate ( q_out(im,jm,lm_out,nt) ) - allocate ( ps_out(im,jm) ) - allocate ( dz_out(im,jm,lm_out) ) - allocate ( w_out(im,jm,lm_out) ) - -! ----------------------------------------------------------------- -! MAT Before calling REMAP, we must have THV. Construct this from T -! ----------------------------------------------------------------- - - eps = MAPL_RVAP/MAPL_RGAS-1.0 - pke_in(:,:,:) = ple_in(:,:,:)**MAPL_KAPPA - - do L = 1, lm_in - pk_in (:,:,L) = ( pke_in(:,:,L+1)-pke_in(:,:,L) ) / ( MAPL_KAPPA*log(ple_in(:,:,L+1)/ple_in(:,:,L)) ) - thv_in(:,:,L) = t_in(:,:,L)*(1.0+eps*q_in(:,:,L,1)) / pk_in(:,:,L) - end do - -! ----------------------------------------------------------------- -! MAT REMAP can only really handle level variables. Omega is edge. -! Create a level version -! ----------------------------------------------------------------- - - do L = 1, lm_in - oml_in(:,:,L) = 0.5*(om_in(:,:,L)+om_in(:,:,L+1)) - end do - -! ----------------------- -! MAT Now remap for datmo -! ----------------------- - - print *, 'Calling REMAP for datmo ...' - call remap ( ps_out,dp_out,u_out,v_out,oml_out,thv_out,q_out,phis,lm_out, & - ps_in ,dp_in ,u_in ,v_in ,oml_in, thv_in ,q_in ,phis,lm_in , & - im,jm,nt,ak_out,bk_out,pref_out,verbose ) - print *, ' REMAP Finished' - -! ---------------------------------- - - kappa = MAPL_KAPPA - - ple_out(:,:,lm_out+1) = ps_out(:,:) - do L=lm_out,1,-1 - ple_out(:,:,L) = ple_out(:,:,L+1)-dp_out(:,:,L) - enddo - dz_out = 0. - w_out = 0. - -! Ensure top edge = ptop -! ---------------------- - dp_out(:,:,1) = ple_out(:,:,2)-ak_out(1) - ple_out(:,:,1) = ple_out(:,:,2)-dp_out(:,:,1) - - pke_out(:,:,:) = ple_out(:,:,:)**kappa - - do L=1,lm_out - pk_out(:,:,L) = ( pke_out(:,:,L+1)-pke_out(:,:,L) ) & - / ( kappa*log(ple_out(:,:,L+1)/ple_out(:,:,L)) ) - enddo - -! ----------------------------------------------------------------- -! MAT After calling REMAP, we must have T. Construct this from THV -! ----------------------------------------------------------------- - - do L = 1, lm_out - t_out(:,:,L) = (thv_out(:,:,L)*pk_out(:,:,L))/(1.0+eps*q_out(:,:,L,1)) - end do - -! --------------------------------------- -! MAT Now reconvert oml to get om on edge -! --------------------------------------- - - om_out(:,:,1) = 0.0 - do L = 2, lm_out - om_out(:,:,L) = 0.5*(oml_out(:,:,L-1)+oml_out(:,:,L)) - end do - om_out(:,:,lm_out+1) = 0.0 - -! ********************************************************************** -! **** Write datmodyn internal Restart **** -! ********************************************************************** - - allocate ( dum1( lm_out+1) ) - allocate ( dum3l(im,jm,lm_out ) ) - allocate ( dum3e(im,jm,lm_out+1) ) - - write(cim ,203) im - write(cjm ,203) jm - write(clm ,203) lm_out - 201 format(i8.8) - 202 format(i2.2) - 203 format(i4.4) - - datmodynrst = trim(datmodynrst) // '.r' // cim // 'x' // cjm // 'x' // clm - - print * - print *, ' Creating: ',trim(datmodynrst) - print *, ' output resolution: ',im,jm,lm_out - print * - open (10,file=trim(datmodynrst),form='unformatted',access='sequential') - - dum1 = pref_out - write (10) dum1 - if (verbose) write (*,*) "pref: ", pref_out - - do L=1,lm_out+1 - dum3e(1,1,L) = ple_out(1,1,L) - write(10) dum3e(1,1,L) - enddo - if (verbose) write (*,*) "ple: ", ple_out - do L=1,lm_out - dum3l(1,1,L) = t_out(1,1,L) - write(10) dum3l(1,1,L) - enddo - if (verbose) write (*,*) "t: ", t_out - do L=1,lm_out - dum3l(1,1,L) = u_out(1,1,L) - write(10) dum3l(1,1,L) - enddo - if (verbose) write (*,*) "u: ", u_out - do L=1,lm_out - dum3l(1,1,L) = v_out(1,1,L) - write(10) dum3l(1,1,L) - enddo - if (verbose) write (*,*) "v: ", v_out - do L=1,lm_out+1 - dum3e(1,1,L) = om_out(1,1,L) - write(10) dum3e(1,1,L) - enddo - if (verbose) write (*,*) "om: ", om_out - close (10) - - deallocate ( dum1) - deallocate (dum3l) - deallocate (dum3e) - -! ********************************************************************** -! **** Write moist internal Restart **** -! ********************************************************************** - - moistrst = trim(moistrst) // '.r' // cim // 'x' // cjm // 'x' // clm - print *, ' Creating: ',trim(moistrst) - - open (10,file=trim(moistrst),form='unformatted',access='sequential') - do n=1,nt_other(0) - print '(a,i4)', ' Writing Moist Restart for Field # ',n - if (verbose) write(*,*) 'Field #', n, ': ', q_out(:,:,:,n) - do L=1,lm_out - dum(:,:) = q_out(:,:,L,n) - write(10) dum - enddo - enddo - print * - close (10) - -! ********************************************************************** -! **** Write Other Internal Restarts **** -! ********************************************************************** - - if( num_other_rst.ne.0 ) then - - nbeg = nt_other(0) + 1 - do m=1,num_other_rst - nend = nbeg + nt_other(m)-1 - - other_rst(m) = trim(other_rst(m)) // '.r' // cim // 'x' // cjm // 'x' // clm - print *, ' Creating: ',trim(other_rst(m)) - - open (10,file=trim(other_rst(m)),form='unformatted',access='sequential') - - do n=nbeg,nend - print '(a,i2,a,i4)', ' Writing Other_Restart # ',m,' for Field # ',n-nbeg+1 - do L=1,lm_out - dum(:,:) = q_out(:,:,L,n) - write(10) dum - enddo - enddo - close (10) - nbeg = nend + 1 - print * - enddo - - endif - - stop - end - - subroutine remap ( ps1,dp1,u1,v1,om1,thv1,q1,phis1,lm1, & - ps2,dp2,u2,v2,om2,thv2,q2,phis2,lm2,im,jm,nt,ak1,bk1,pref1,verbose ) - -! ******************************************************************************* -! ***** ***** -! ***** Program to remap Target analysis variables (ps2,dp2,u2,v2,t2,q2) ***** -! ***** onto Model grid variables (ps1,dp1,u1,v1,thv1,q1). Program ***** -! ***** allows for differenct topographies between Analysis and Model. ***** -! ***** ***** -! ******************************************************************************* - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - integer im,jm,lm1,lm2,nt - -! Output Model Variables -! ---------------------- - real dp1(im,jm,lm1) - real u1(im,jm,lm1) - real v1(im,jm,lm1) - real om1(im,jm,lm1) - real thv1(im,jm,lm1) - real q1(im,jm,lm1,nt) - real ps1(im,jm) - real phis1(im,jm) - real ak1(lm1+1) - real bk1(lm1+1) - real pref1(lm1+1) - -! Input Analysis Variables -! ------------------------ - real dp2(im,jm,lm2) - real u2(im,jm,lm2) - real v2(im,jm,lm2) - real om2(im,jm,lm2) - !real t2(im,jm,lm2) - real thv2(im,jm,lm2) - real q2(im,jm,lm2,nt) - real ps2(im,jm) - real phis2(im,jm) - real ak2(lm2+1) - real bk2(lm2+1) - - logical verbose - -! Local variables -! --------------- - real pe1(im,jm,lm1+1) - real pe2(im,jm,lm2+1) - real pk (im,jm,lm2 ) - real pke1(im,jm,lm1+1) - real pke2(im,jm,lm2+1) - real phi2(im,jm,lm2+1) - - real, allocatable :: plevs(:) - - real kappa,cp,dum,dum1,dum2 - real rgas,eps,rvap,grav - integer i,j,L,kdum - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - -! Create AK & BK for each vertical dimension -! ------------------------------------------ - call set_eta ( lm1,kdum,dum,dum,ak1,bk1 ) - call set_eta ( lm2,kdum,dum,dum,ak2,bk2 ) - - if( verbose ) then - allocate( plevs(lm2) ) - do L=1,lm2 - plevs(L) = 0.5*( ak2(L) + 100000.0*bk2(L) & - + ak2(L+1) + 100000.0*bk2(L+1) ) - enddo - print *, 'Input PLEVS:' - print *, (plevs(L)/100,L=1,lm2) - - deallocate( plevs ) - allocate( plevs(lm1) ) - do L=1,lm1 - plevs(L) = 0.5*( ak1(L) + 100000.0*bk1(L) & - + ak1(L+1) + 100000.0*bk1(L+1) ) - enddo - print *, 'Output PLEVS:' - print *, (plevs(L)/100,L=1,lm1) - deallocate( plevs ) - - endif - -! Create Pressure Variables -! ------------------------- - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1 (i,j,L) = ak1(L)+bk1(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - - do L=1,lm2+1 - do j=1,jm - do i=1,im - pe2 (i,j,L) = ak2(L)+bk2(L)*ps2(i,j) - pke2(i,j,L) = pe2(i,j,L)**kappa - enddo - enddo - enddo - do L=1,lm2 - do j=1,jm - do i=1,im - dp2(i,j,L) = pe2(i,j,L+1)-pe2(i,j,L) - enddo - enddo - enddo - -! MAT Fill pref1 -! -------------- - do L=1,lm1+1 - pref1(L) = ak1(L) + 100000.0*bk1(L) - enddo - -! Construct target virtual potential temperature -! ---------------------------------------------- - do L=1,lm2 - pk(:,:,L) = ( pke2(:,:,L+1)-pke2(:,:,L) )/( kappa*log(pe2(:,:,L+1)/pe2(:,:,L)) ) - enddo - -! Construct target analysis heights -! --------------------------------- - phi2(:,:,lm2+1) = phis2(:,:) - do L=lm2,1,-1 - phi2(:,:,L) = phi2(:,:,L+1) + cp*thv2(:,:,L)*( pke2(:,:,L+1)-pke2(:,:,L) ) - enddo - -! Compute new surface pressure consistent with target surface pressure and topography -! ----------------------------------------------------------------------------------- - do j=1,jm - do i=1,im - L = lm2 - do while ( phi2(i,j,L).lt.phis1(i,j) ) - L = L-1 - enddo - ps1(i,j) = pe2(i,j,L+1)*( 1+(phi2(i,j,L+1)-phis1(i,j))/(cp*thv2(i,j,L)*pke2(i,j,L+1)) )**(1.0/kappa) - enddo - enddo - -! Construct model pressure variables using new surface pressure -! ------------------------------------------------------------- - print * - L = 1 - dum1 = (ak1(L)+bk1(L)*100000.0)/100 - write(6,1000) L,ak1(L),bk1(L),dum1 - 1000 format(1x,'L: ',i3,4x,'ak: ',f10.3,' bk: ',f10.8,4x,'pe: ',f8.3) - do L=2,lm1+1 - dum2 = (ak1(L)+bk1(L)*100000.0)/100 - write(6,1001) L,ak1(L),bk1(L),dum2,dum2-dum1 - 1001 format(1x,'L: ',i3,4x,'ak: ',f10.3,' bk: ',f10.8,4x,'pe: ',f8.3,3x,'dp: ',f7.3) - dum1 = dum2 - enddo - print * - - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1 (i,j,L) = ak1(L)+bk1(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -! Map target analysis onto grid defined by new surface pressure -! ------------------------------------------------------------- - print *, 'Calling GMAP, LM_in : ',lm2 - print *, ' LM_out: ',lm1 - call gmap ( im,jm,nt, & - lm2, pke2, pe2, u2, v2, om2, thv2, q2,& - lm1, pke1, pe1, u1, v1, om1, thv1, q1 ) - - return - end - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine gmap(im, jm, nq, & - km, pk3d_m, pe3d_m, u_m, v_m, om_m, pt_m, q_m, & - kn, pk3d_n, pe3d_n, u_n, v_n, om_n, pt_n, q_n ) -!****6***0*********0*********0*********0*********0*********0**********72 - - implicit none - - integer im, jm - integer km, kn, nq - -! Input: -! original data km-level - - real u_m(im,jm,km) - real v_m(im,jm,km) - real om_m(im,jm,km) - real pt_m(im,jm,km) - real q_m(im,jm,km,nq) - real pk3d_m(im,jm,km+1) - real pe3d_m(im,jm,km+1) - - -! Output: -! New data (kn-level) - real u_n(im,jm,kn) - real v_n(im,jm,kn) - real om_n(im,jm,kn) - real pt_n(im,jm,kn) - real q_n(im,jm,kn,nq) - real pk3d_n(im,jm,kn+1) - real pe3d_n(im,jm,kn+1) - -! local (private) - integer i, j, k, n - - real pe1(im,km+1),pe2(im,kn+1) - real pk1(im,km+1),pk2(im,kn+1) - real dp1(im,km) ,dp2(im,kn) - real u1(im,km) , u2(im,kn) - real v1(im,km) , v2(im,kn) - real om1(im,km) ,om2(im,kn) - real t1(im,km) , t2(im,kn) - real q1(im,km) , q2(im,kn) - - real undef - real big - parameter ( undef = 1.e15 ) - parameter ( big = 1.e10 ) - - - do 2000 j=1,jm - -! Copy original data to local 2D arrays. - - do k=1,km+1 - do i=1,im - pe1(i,k) = pe3d_m(i,j,k) - pk1(i,k) = pk3d_m(i,j,k) - enddo - enddo - - do k=1,kn+1 - do i=1,im - pe2(i,k) = pe3d_n(i,j,k) - pk2(i,k) = pk3d_n(i,j,k) - enddo - enddo - - do k=1,km - do i=1,im - dp1(i,k) = pk1(i,k+1)-pk1(i,k) - u1(i,k) = u_m(i,j,k) - v1(i,k) = v_m(i,j,k) - om1(i,k) = om_m(i,j,k) - t1(i,k) = pt_m(i,j,k) - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pk2(i,k+1)-pk2(i,k) - enddo - enddo - -! map pt -! ------ - call mappm ( km, pk1, dp1, t1, kn, pk2, t2, im, 1, 7 ) - - do k=1,km - do i=1,im - dp1(i,k) = pe1(i,k+1)-pe1(i,k) - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pe2(i,k+1)-pe2(i,k) - enddo - enddo - -! map u,v -! ------- - call mappm ( km, pe1, dp1, u1, kn, pe2, u2, im, -1, 7 ) - call mappm ( km, pe1, dp1, v1, kn, pe2, v2, im, -1, 7 ) - -! map om (like u,v) -! ----------------- - call mappm ( km, pe1, dp1,om1, kn, pe2,om2, im, -1, 7 ) - -! map q -! ------- - do n=1,nq - do k=1,km - do i=1,im - q1(i,k) = q_m(i,j,k,n) - enddo - enddo - call mappm ( km, pe1, dp1, q1, kn, pe2, q2, im, 0, 7 ) - do k=1,kn - do i=1,im - q_n(i,j,k,n) = q2(i,k) - enddo - enddo - enddo - - do k=1,kn - do i=1,im - u_n(i,j,k) = u2(i,k) - v_n(i,j,k) = v2(i,k) - om_n(i,j,k) =om2(i,k) - pt_n(i,j,k) = t2(i,k) - enddo - enddo - -2000 continue - - return - end - - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine mappm(km, pe1, dp1, q1, kn, pe2, q2, im, iv, kord) -!****6***0*********0*********0*********0*********0*********0**********72 -! IV = 0: constituents -! IV = 1: potential temp -! IV =-1: winds -! -! Mass flux preserving mapping: q1(im,km) -> q2(im,kn) -! -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate - - parameter (kmax = 200) - parameter (R3 = 1./3., R23 = 2./3.) - - real dp1(im,km) - real q1(im,km), q2(im,kn) - real pe1(im,km+1), pe2(im,kn+1) - integer kord - -! local work arrays - real a4(4,im,km) - - do k=1,km - do i=1,im - a4(1,i,k) = q1(i,k) - enddo - enddo - - call ppm2m(a4, dp1, im, km, iv, kord) - -! Lowest layer: constant distribution - do i=1, im - a4(2,i,km) = q1(i,km) - a4(3,i,km) = q1(i,km) - a4(4,i,km) = 0. - enddo - - do 5555 i=1,im - k0 = 1 - do 555 k=1,kn - - if(pe2(i,k+1) .le. pe1(i,1)) then -! Entire grid above old ptop - q2(i,k) = a4(2,i,1) - elseif(pe2(i,k) .ge. pe1(i,km+1)) then -! Entire grid below old ps - q2(i,k) = a4(3,i,km) - elseif(pe2(i,k ) .lt. pe1(i,1) .and. & - pe2(i,k+1) .gt. pe1(i,1)) then -! Part of the grid above ptop - q2(i,k) = a4(1,i,1) - else - - do 45 L=k0,km -! locate the top edge at pe2(i,k) - if( pe2(i,k) .ge. pe1(i,L) .and. & - pe2(i,k) .le. pe1(i,L+1) ) then - k0 = L - PL = (pe2(i,k)-pe1(i,L)) / dp1(i,L) - if(pe2(i,k+1) .le. pe1(i,L+1)) then - -! entire new grid is within the original grid - PR = (pe2(i,k+1)-pe1(i,L)) / dp1(i,L) - TT = R3*(PR*(PR+PL)+PL**2) - q2(i,k) = a4(2,i,L) + 0.5*(a4(4,i,L)+a4(3,i,L) & - - a4(2,i,L))*(PR+PL) - a4(4,i,L)*TT - goto 555 - else -! Fractional area... - delp = pe1(i,L+1) - pe2(i,k) - TT = R3*(1.+PL*(1.+PL)) - qsum = delp*(a4(2,i,L)+0.5*(a4(4,i,L)+ & - a4(3,i,L)-a4(2,i,L))*(1.+PL)-a4(4,i,L)*TT) - dpsum = delp - k1 = L + 1 - goto 111 - endif - endif -45 continue - -111 continue - do 55 L=k1,km - if( pe2(i,k+1) .gt. pe1(i,L+1) ) then - -! Whole layer.. - - qsum = qsum + dp1(i,L)*q1(i,L) - dpsum = dpsum + dp1(i,L) - else - delp = pe2(i,k+1)-pe1(i,L) - esl = delp / dp1(i,L) - qsum = qsum + delp * (a4(2,i,L)+0.5*esl* & - (a4(3,i,L)-a4(2,i,L)+a4(4,i,L)*(1.-r23*esl)) ) - dpsum = dpsum + delp - k0 = L - goto 123 - endif -55 continue - delp = pe2(i,k+1) - pe1(i,km+1) - if(delp .gt. 0.) then -! Extended below old ps - qsum = qsum + delp * a4(3,i,km) - dpsum = dpsum + delp - endif -123 q2(i,k) = qsum / dpsum - endif -555 continue -5555 continue - - return - end - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine ppm2m(a4,delp,im,km,iv,kord) -!****6***0*********0*********0*********0*********0*********0**********72 -! iv = 0: positive definite scalars -! iv = 1: others -! iv =-1: winds - - implicit none - - integer im, km, lmt, iv - integer kord - integer i, k, km1 - real a4(4,im,km), delp(im,km) - -! local arrays. - real dc(im,km),delq(im,km) - real h2(im,km) - real a1, a2, c1, c2, c3, d1, d2 - real qmax, qmin, cmax, cmin - real qm, dq, tmp - -! Local scalars: - real qmp - real lac - - km1 = km - 1 - - do 500 k=2,km - do 500 i=1,im - delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) -500 a4(4,i,k ) = delp(i,k-1) + delp(i,k) - - do 1220 k=2,km1 - do 1220 i=1,im - c1 = (delp(i,k-1)+0.5*delp(i,k))/a4(4,i,k+1) - c2 = (delp(i,k+1)+0.5*delp(i,k))/a4(4,i,k) - tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / & - (a4(4,i,k)+delp(i,k+1)) - qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k) - qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp) -1220 continue - -!****6***0*********0*********0*********0*********0*********0**********72 -! 4th order interpolation of the provisional cell edge value -!****6***0*********0*********0*********0*********0*********0**********72 - - do 12 k=3,km1 - do 12 i=1,im - c1 = delq(i,k-1)*delp(i,k-1) / a4(4,i,k) - a1 = a4(4,i,k-1) / (a4(4,i,k) + delp(i,k-1)) - a2 = a4(4,i,k+1) / (a4(4,i,k) + delp(i,k)) - a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(a4(4,i,k-1)+a4(4,i,k+1)) * & - ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - & - delp(i,k-1)*a1*dc(i,k ) ) -12 continue - -! Area preserving cubic with 2nd deriv. = 0 at the boundaries -! Top - do i=1,im - d1 = delp(i,1) - d2 = delp(i,2) - qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) - dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) - c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) - c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1) - a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2) - dc(i,1) = a4(1,i,1) - a4(2,i,1) -! No over- and undershoot condition - cmax = max(a4(1,i,1), a4(1,i,2)) - cmin = min(a4(1,i,1), a4(1,i,2)) - a4(2,i,2) = max(cmin,a4(2,i,2)) - a4(2,i,2) = min(cmax,a4(2,i,2)) - enddo - - if(iv == 0) then - do i=1,im - a4(2,i,1) = max(0.,a4(2,i,1)) - a4(2,i,2) = max(0.,a4(2,i,2)) - enddo - elseif(iv == -1) then - do i=1,im - if( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. - enddo - endif - -!****6***0*********0*********0*********0*********0*********0**********72 - -! Bottom -! Area preserving cubic with 2nd deriv. = 0 at the surface - do 15 i=1,im - d1 = delp(i,km) - d2 = delp(i,km1) - qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) - dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) - c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) - c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1) - a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km) - dc(i,km) = a4(3,i,km) - a4(1,i,km) -!****6***0*********0*********0*********0*********0*********0**********72 -! No over- and undershoot condition - cmax = max(a4(1,i,km), a4(1,i,km1)) - cmin = min(a4(1,i,km), a4(1,i,km1)) - a4(2,i,km) = max(cmin,a4(2,i,km)) - a4(2,i,km) = min(cmax,a4(2,i,km)) -!****6***0*********0*********0*********0*********0*********0**********72 -15 continue - - if(iv .eq. 0) then - do i=1,im - a4(2,i,km) = max(0.,a4(2,i,km)) - a4(3,i,km) = max(0.,a4(3,i,km)) - enddo - endif - - do 20 k=1,km1 - do 20 i=1,im - a4(3,i,k) = a4(2,i,k+1) -20 continue -! -! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) -! - -! Top 2 and bottom 2 layers always use monotonic mapping - - do k=1,2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) - enddo - - if(kord == 7) then -!****6***0*********0*********0*********0*********0*********0**********72 -! Huynh's 2nd constraint -!****6***0*********0*********0*********0*********0*********0**********72 - do k=2, km1 - do i=1,im - h2(i,k) = delq(i,k) - delq(i,k-1) - enddo - enddo - - do 4000 k=3, km-2 - do 3000 i=1, im -! Right edges - qmp = a4(1,i,k) + 2.0*delq(i,k-1) - lac = a4(1,i,k) + 1.5*h2(i,k-1) + 0.5*delq(i,k-1) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax) -! Left edges - qmp = a4(1,i,k) - 2.0*delq(i,k) - lac = a4(1,i,k) + 1.5*h2(i,k+1) - 0.5*delq(i,k) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax) -! Recompute A6 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) -3000 continue -! Additional constraint to prevent negatives - if (iv == 0) then - call kmppm(dc(1,k),a4(1,1,k),im, 2) - endif -4000 continue - - else - - lmt = kord - 3 - lmt = max(0, lmt) - if (iv .eq. 0) lmt = min(2, lmt) - - do k=3, km-2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, lmt) - enddo - endif - - do 5000 k=km1,km - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) -5000 continue - - return - end - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine kmppm(dm, a4, km, lmt) -!****6***0*********0*********0*********0*********0*********0**********72 - implicit none - - real r12 - parameter (r12 = 1./12.) - - integer km, lmt - integer i - real a4(4,km),dm(km) - real da1, da2, a6da - real fmin - real qmp - - if (lmt .eq. 3) return -! Full constraint - - if(lmt .eq. 0) then - do 100 i=1,km - if(dm(i) .eq. 0.) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da .lt. -da2) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da .gt. da2) then - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif -100 continue - elseif (lmt .eq. 2) then -! Positive definite - -! Positive definite constraint - do 250 i=1,km - if(abs(a4(3,i)-a4(2,i)) .ge. -a4(4,i)) go to 250 - fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 - if(fmin.ge.0.) go to 250 - if(a4(1,i).lt.a4(3,i) .and. a4(1,i).lt.a4(2,i)) then - a4(3,i) = a4(1,i) - a4(2,i) = a4(1,i) - a4(4,i) = 0. - elseif(a4(3,i) .gt. a4(2,i)) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - else - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif -250 continue - - elseif (lmt == 1) then - -! Improved full monotonicity constraint (Lin) -! Note: no need to provide first guess of A6 <-- a4(4,i) - - do i=1, km - qmp = 2.*dm(i) - a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) - a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) - a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) ) - enddo - endif - - return - end - subroutine minmax ( q,name,im,jm,lm ) - character*4 name - real q(im,jm,lm) - qmax = q(1,1,1) - qmin = q(1,1,1) - do l=1,lm - do j=1,jm - do i=1,im - qmax = max( qmax,q(i,j,L) ) - qmin = min( qmin,q(i,j,L) ) - enddo - enddo - enddo - print *, name,' max: ',qmax,' min: ',qmin - return - end - subroutine usage() - write (*,1001) "Usage: " - write (*,1001) - write (*,1001) " rs_vinterp_scm.x -datmodynrst datmodynrst_fname Default: datmodyn_internal_rst" - write (*,1001) " -moistrst moistrst_fname Default: moist_internal_rst" - write (*,1001) " -topo topo_fname" - write (*,1001) " -lm_in INPUT_LM" - write (*,1001) " -lm_out OUTPUT_LM" - write (*,1001) - write (*,1001) "where:" - write (*,1001) "-----" - write (*,1001) " -datmodynrst datmodynrst_fname: Filename of datmodyn internal restart" - write (*,1001) " -moistrst moistrst_fname: Filename of moist internal restart" - write (*,1001) " -topo topo_fname: Filename of topography" - write (*,1001) " -lm_in INPUT_LM: Input Vertical Resolution" - write (*,1001) " -lm_out OUTPUT_LM: Output Vertical Resolution" - write (*,1001) - write (*,1001) "creates updated restarts at new LM resolution" - write (*,1001) "---------------------------------------------" - write (*,1001) -1001 format (A) - error stop 7 - end diff --git a/GEOS_Util/post/rsg3_vinterp.F b/GEOS_Util/post/rsg3_vinterp.F deleted file mode 100644 index a8545ef1..00000000 --- a/GEOS_Util/post/rsg3_vinterp.F +++ /dev/null @@ -1,3820 +0,0 @@ - program main - use MAPL_ConstantsMod - implicit none - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to remap GEOS-5 FV & MOIST restarts in the vertical **** -c **** to ARIES DYNAMICAL CORE **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - - character*256 dynrst, moistrst, topo, iaurst - - integer headr1(6) - integer headr2(5) - integer nymd,nhms - integer im,jm,lm,nt,rc - real undef, kappa, grav - -c restart variables and topography -c -------------------------------- - real*8, allocatable :: dp_in(:,:,:) - real*8, allocatable :: u_in(:,:,:) - real*8, allocatable :: v_in(:,:,:) - real*8, allocatable :: thv_in(:,:,:) - real*8, allocatable :: pk_in(:,:,:) - real*8, allocatable :: ple_in(:,:,:) - real*8, allocatable :: q_in(:,:,:,:) - real*8, allocatable :: ps_in(:,:) - real*8, allocatable :: ak_in(:) - real*8, allocatable :: bk_in(:) - real*8, allocatable :: phis(:,:) - - real*8, allocatable :: dp_out(:,:,:) - real*8, allocatable :: u_out(:,:,:) - real*8, allocatable :: v_out(:,:,:) - real*8, allocatable :: thv_out(:,:,:) - real*8, allocatable :: pk_out(:,:,:) - real*8, allocatable :: pke_out(:,:,:) - real*8, allocatable :: ple_out(:,:,:) - real*8, allocatable :: q_out(:,:,:,:) - real*8, allocatable :: ps_out(:,:) - real*8, allocatable :: ak_out(:) - real*8, allocatable :: bk_out(:) - - real*8, allocatable :: logps (:,:) - real*8, allocatable :: logpt (:,:) - real*8, allocatable :: logpl (:,:,:) - real*8 logp - - real*4, allocatable :: dum(:,:) - - real*8, allocatable :: dudti(:,:,:) - real*8, allocatable :: dvdti(:,:,:) - real*8, allocatable :: dtdti(:,:,:) - real*8, allocatable :: dpdti(:,:,:) - real*8, allocatable :: dqdti(:,:,:) - real*8, allocatable :: dodti(:,:,:) - - real*8, allocatable :: dudto(:,:,:) - real*8, allocatable :: dvdto(:,:,:) - real*8, allocatable :: dtdto(:,:,:) - real*8, allocatable :: dpdto(:,:,:) - real*8, allocatable :: dqdto(:,:,:) - real*8, allocatable :: dodto(:,:,:) - - character*256, allocatable :: arg(:) - character*8 date - character*2 hour,clm - character*3 cim,cjm - integer n,nargs,i,j,L - -C ********************************************************************** -C **** Initialize Filenames **** -C ********************************************************************** - - undef = 1.0e15 - dynrst = 'fvcore_internal_restart' - moistrst = 'moist_internal_restart' - iaurst = 'xxx' - - nargs = command_argument_count() - if(nargs == 0 ) call usage() - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-h' ) call usage() - if( trim(arg(n)).eq.'-help' ) call usage() - if( trim(arg(n)).eq.'-H' ) call usage() - if( trim(arg(n)).eq.'-Help' ) call usage() - if( trim(arg(n)).eq.'-dynrst' ) then - dynrst = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-moistrst' ) then - moistrst = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-iau' ) then - iaurst = trim(arg(n+1)) - endif - if( trim(arg(n)).eq.'-topo' ) then - topo = trim(arg(n+1)) - endif - enddo - - print * - print *, ' dyn restart filename: ',trim(dynrst) - print *, 'moist restart filename: ',trim(moistrst) - if( trim(iaurst).ne.'xxx' ) then - print *, ' iau restart filename: ',trim(iaurst) - endif - print *, ' topo filename: ',trim(topo) - -C ********************************************************************** -C **** Read dycore internal Restart **** -C ********************************************************************** - - open (10,file=trim(dynrst),form='unformatted',access='sequential') - read (10) headr1 - read (10) headr2 - - nymd = headr1(1)*10000 + headr1(2)*100 + headr1(3) - nhms = headr1(4)*10000 + headr1(5)*100 + headr1(6) - - im = headr2(1) - jm = headr2(2) - lm = headr2(3) - - print *, ' input resolution: ',im,jm,lm - print *, ' date: ',nymd,nhms - print * - - allocate ( u_in(im,jm,lm) ) - allocate ( v_in(im,jm,lm) ) - allocate ( thv_in(im,jm,lm) ) - allocate ( dp_in(im,jm,lm) ) - allocate ( pk_in(im,jm,lm) ) - allocate ( ple_in(im,jm,lm+1) ) - allocate ( ps_in(im,jm) ) - allocate ( ak_in(lm+1) ) - allocate ( bk_in(lm+1) ) - - read (10) ak_in - read (10) bk_in - - do L=1,lm - read(10) (( u_in(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm - read(10) (( v_in(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm - read(10) ((thv_in(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm+1 - read(10) ((ple_in(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm - read(10) (( pk_in(i,j,L),i=1,im),j=1,jm) - enddo - - close (10) - - ps_in(:,:) = ple_in(:,:,lm+1) - do L=lm,1,-1 - dp_in(:,:,L) = ple_in(:,:,L+1) - ple_in(:,:,L) - enddo - -C ********************************************************************** -C **** Read Moist Internal Restart **** -C ********************************************************************** - - allocate ( dum(im,jm) ) - - open (10,file=trim(moistrst),form='unformatted',access='sequential') - - nt = 0 - rc = 0 - dowhile (rc.eq.0) - read (10,iostat=rc) dum - if( rc.eq.0 ) then - nt = nt + 1 - allocate( q_out(im,jm,lm,nt) ) - q_out(:,:,1,nt) = dum - do L=2,lm - read (10,iostat=rc) dum - q_out(:,:,L,nt) = dum - enddo - if( nt.eq.1) then - allocate( q_in (im,jm,lm,nt) ) - q_in (:,:,:,nt) = q_out(:,:,:,nt) - else - q_out(:,:,:,1:nt-1) = q_in(:,:,:,1:nt-1) - deallocate( q_in ) - allocate( q_in (im,jm,lm,nt) ) - q_in = q_out - endif - print *, 'Reading Moist Restart for Field # ',nt - deallocate( q_out ) - endif - enddo - - close (10) - -C ********************************************************************** -C **** Read AGCM Import Restart **** -C ********************************************************************** - - if( trim(iaurst).ne.'xxx' ) then - - open (10,file=trim(iaurst),form='unformatted',access='sequential') - - allocate( dudti(im,jm,lm) ) - allocate( dvdti(im,jm,lm) ) - allocate( dtdti(im,jm,lm) ) - allocate( dpdti(im,jm,lm+1) ) - allocate( dqdti(im,jm,lm) ) - allocate( dodti(im,jm,lm) ) - - do L=1,lm - read (10) dum - dudti(:,:,L) = dum - enddo - do L=1,lm - read (10) dum - dvdti(:,:,L) = dum - enddo - do L=1,lm - read (10) dum - dtdti(:,:,L) = dum - enddo - do L=1,lm+1 - read (10) dum - dpdti(:,:,L) = dum - enddo - do L=1,lm - read (10) dum - dqdti(:,:,L) = dum - enddo - do L=1,lm - read (10) dum - dodti(:,:,L) = dum - enddo - - close (10) - endif - -! ********************************************************************** -! **** Read Topography Datasets **** -! ********************************************************************** - - allocate ( phis(im,jm) ) - - print *, 'Reading Topography Dataset: ',trim(topo) - open (10,file=trim(topo),form='unformatted',access='sequential') - read (10) dum - close(10) - - kappa = MAPL_KAPPA - grav = MAPL_GRAV - phis = dum*grav - -C ********************************************************************** -C **** Remap State **** -C ********************************************************************** - - allocate ( u_out(im,jm,lm) ) - allocate ( v_out(im,jm,lm) ) - allocate ( thv_out(im,jm,lm) ) - allocate ( dp_out(im,jm,lm) ) - allocate ( pk_out(im,jm,lm) ) - allocate ( pke_out(im,jm,lm+1) ) - allocate ( ple_out(im,jm,lm+1) ) - allocate ( q_out(im,jm,lm,nt) ) - allocate ( ps_out(im,jm) ) - allocate ( ak_out(lm+1) ) - allocate ( bk_out(lm+1) ) - -c Remap on Native Grid -c -------------------- - call remap ( ps_out,dp_out,u_out,v_out,thv_out,q_out,lm, - . ps_in ,u_in ,v_in ,thv_in ,q_in ,lm, - . im,jm,nt,ak_out,bk_out ) - - ple_out(:,:,lm+1) = ps_out(:,:) - do L=lm,1,-1 - ple_out(:,:,L) = ple_out(:,:,L+1)-dp_out(:,:,L) - enddo - -c Ensure top edge = ptop -c ---------------------- - dp_out(:,:,1) = ple_out(:,:,2)-ak_out(1) - ple_out(:,:,1) = ple_out(:,:,2)-dp_out(:,:,1) - - pke_out(:,:,:) = ple_out(:,:,:)**kappa - - do L=1,lm - pk_out(:,:,L) = ( pke_out(:,:,L+1)-pke_out(:,:,L) ) - . / ( kappa*log(ple_out(:,:,L+1)/ple_out(:,:,L)) ) - enddo - -c Interpolate Remapped Winds From D-Grid to C-Grid -c ------------------------------------------------ - call dtoa ( u_out,u_out,im,jm,lm,2 ) - call dtoa ( v_out,v_out,im,jm,lm,1 ) - - call atoc ( u_out,u_out,im,jm,lm,1 ) - call atoc ( v_out,v_out,im,jm,lm,2 ) - - call windfix ( u_out,v_out,ple_out, - . u_in, v_in, ple_in, - . im,jm,lm,1 ) - -C ********************************************************************** -C **** Simple Interpolation of IAU **** -C ********************************************************************** - - if( trim(iaurst).ne.'xxx' ) then - - allocate( dudto(im,jm,lm) ) - allocate( dvdto(im,jm,lm) ) - allocate( dtdto(im,jm,lm) ) - allocate( dpdto(im,jm,lm+1) ) - allocate( dqdto(im,jm,lm) ) - allocate( dodto(im,jm,lm) ) - - allocate( logps(im,jm) ) - allocate( logpt(im,jm) ) - -c Mid-Level Fields -c ---------------- - allocate( logpl(im,jm,lm) ) - - do L=1,lm - logpl(:,:,L) = log( 0.5*( ple_in(:,:,L+1)+ple_in(:,:,L) ) ) - enddo - logps(:,:) = log( ple_in(:,:,lm+1) ) - logpt(:,:) = log( ple_in(:,:,1) ) - - do j=1,jm - do i=1,im - do L=1,lm - logp = log( 0.5*( ple_out(i,j,L+1)+ple_out(i,j,L) ) ) - call sigtopl( dudto(i,j,L),dudti(i,j,1:lm),logpl(i,j,1:lm),logps(i,j),logpt(i,j),logp,1,1,lm,undef ) - call sigtopl( dvdto(i,j,L),dvdti(i,j,1:lm),logpl(i,j,1:lm),logps(i,j),logpt(i,j),logp,1,1,lm,undef ) - call sigtopl( dtdto(i,j,L),dtdti(i,j,1:lm),logpl(i,j,1:lm),logps(i,j),logpt(i,j),logp,1,1,lm,undef ) - call sigtopl( dqdto(i,j,L),dqdti(i,j,1:lm),logpl(i,j,1:lm),logps(i,j),logpt(i,j),logp,1,1,lm,undef ) - call sigtopl( dodto(i,j,L),dodti(i,j,1:lm),logpl(i,j,1:lm),logps(i,j),logpt(i,j),logp,1,1,lm,undef ) - enddo - enddo - enddo - -c Edge-Level Fields -c ---=------------- - do L=1,lm+1 - dpdto(:,:,L) = ak_out(L) + dpdti(:,:,lm+1)*bk_out(L) - enddo - - endif - -C ********************************************************************** -C **** Write dycore internal Restart **** -C ********************************************************************** - - write(date,101) nymd - write(hour,102) nhms/10000 - write(cim ,103) im - write(cjm ,103) jm - write(clm ,102) lm - 101 format(i8.8) - 102 format(i2.2) - 103 format(i3.3) - - dynrst = trim(dynrst) // '.r' // cim // 'x' // cjm // 'x' // clm // - . '.e' // date // '_' // hour // 'z' - - moistrst = trim(moistrst) // '.r' // cim // 'x' // cjm // 'x' // clm // - . '.e' // date // '_' // hour // 'z' - - print * - print *, ' Creating: ',trim(dynrst) - print *, ' Creating: ',trim(moistrst) - print *, ' output resolution: ',im,jm,lm - print *, ' date: ',nymd,nhms - print * - open (10,file=trim(dynrst),form='unformatted',access='sequential') - - headr2(3) = lm - write(10) headr1 - write(10) headr2 - - write(10) ak_out - write(10) bk_out - - do L=1,lm - write(10) (( u_out(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm - write(10) (( v_out(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm - write(10) ((thv_out(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm+1 - write(10) ((ple_out(i,j,L),i=1,im),j=1,jm) - enddo - do L=1,lm - write(10) (( pk_out(i,j,L),i=1,im),j=1,jm) - enddo - - close (10) - -C ********************************************************************** -C **** Write moist internal Restart **** -C ********************************************************************** - - open (10,file=trim(moistrst),form='unformatted',access='sequential') - do n=1,nt - do L=1,lm - dum(:,:) = q_out(:,:,L,n) - write(10) dum - enddo - enddo - close (10) - -C ********************************************************************** -C **** Write AGCM Import Restart **** -C ********************************************************************** - - if( trim(iaurst).ne.'xxx' ) then - - iaurst = trim(iaurst) // '.r' // cim // 'x' // cjm // 'x' // clm // - . '.e' // date // '_' // hour // 'z' - - print *, ' Creating: ',trim(iaurst) - print * - open (10,file=trim(iaurst),form='unformatted',access='sequential') - - do L=1,lm - dum = dudto(:,:,L) - write(10) dum - enddo - do L=1,lm - dum = dvdto(:,:,L) - write(10) dum - enddo - do L=1,lm - dum = dtdto(:,:,L) - write(10) dum - enddo - do L=1,lm+1 - dum = dpdto(:,:,L) - write(10) dum - enddo - do L=1,lm - dum = dqdto(:,:,L) - write(10) dum - enddo - do L=1,lm - dum = dodto(:,:,L) - write(10) dum - enddo - - close (10) - endif - - stop - end - - subroutine remap ( ps1,dp1,u1,v1,thv1,q1,lm1, - . ps2,u2,v2,thv2,q2,lm2,im,jm,nt,ak,bk ) - -c ******************************************************************************* -c ***** ***** -c ***** Program to remap Target analysis variables (ps2,dp2,u2,v2,t2,q2) ***** -c ***** onto Model grid variables (ps1,dp1,u1,v1,thv1,q1). Program ***** -c ***** allows for differenct topographies between Analysis and Model. ***** -c ***** ***** -c ******************************************************************************* - - use MAPL_ConstantsMod - use m_set_eta, only: set_eta - implicit none - integer im,jm,lm1,lm2,nt - -c Output Model variables -c ---------------------- - real dp1(im,jm,lm1) - real u1(im,jm,lm1) - real v1(im,jm,lm1) - real thv1(im,jm,lm1) - real q1(im,jm,lm1,nt) - real ps1(im,jm) - - real ak(lm1+1) - real bk(lm1+1) - real sige(lm1+1) - -c Input Analysis variables -c ------------------------ - real u2(im,jm,lm2) - real v2(im,jm,lm2) - real thv2(im,jm,lm2) - real q2(im,jm,lm2,nt) - real ps2(im,jm) - -c Local variables -c --------------- - real pe1(im,jm,lm1+1) - real pe2(im,jm,lm2+1) - real pke1(im,jm,lm1+1) - real pke2(im,jm,lm2+1) - - real kappa,cp,dum - real rgas,pref,ptop,psrf,eps,rvap,grav - integer i,j,L - - if( lm1.ne.lm2 ) then - print *, 'Output Vertical Levels must match INPUT' - stop - endif - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - grav = MAPL_GRAV - cp = MAPL_CP - eps = rvap/rgas-1.0 - -c Construct Analysis Edge-Pressures from Input PS and DP -c ------------------------------------------------------ - call set_eta ( lm2,L,dum,dum,ak,bk ) - - do L=lm2+1,1,-1 - pe2(:,:,L) = ak(L) + bk(L)*ps2(:,:) - enddo - pke2(:,:,:) = pe2(:,:,:)**kappa - -c Construct Virtual Potential Temperature -c --------------------------------------- - thv2 = thv2*(1+eps*q2(:,:,:,1)) - - -c Convert Eta Surface to Standard Sigma Surface -c --------------------------------------------- - psrf = 100000.0 - ptop = ak(1) - do L=1,lm1+1 - pref = ak(L)+bk(L)*psrf - sige(L) = ( pref-ptop )/( psrf-ptop ) - enddo - sige(1) = 0.0 - sige(lm1+1) = 1.0 - do L=1,lm1+1 - bk(L) = sige(L) - ak(L) = ptop*(1-sige(L)) - enddo - -c Compute Output pressure variables -c --------------------------------- - ps1 = ps2 - - do L=1,lm1+1 - do j=1,jm - do i=1,im - pe1 (i,j,L) = ak(L)+bk(L)*ps1(i,j) - pke1(i,j,L) = pe1(i,j,L)**kappa - enddo - enddo - enddo - - do L=1,lm1 - do j=1,jm - do i=1,im - dp1(i,j,L) = pe1(i,j,L+1)-pe1(i,j,L) - enddo - enddo - enddo - -c Map target analysis onto grid defined by new surface pressure -c ------------------------------------------------------------- - print *, 'Calling GMAP, LM_in : ',lm2 - print *, ' LM_out: ',lm1 - call gmap ( im,jm,nt, - . lm2, pke2, pe2, u2, v2, thv2, q2, - . lm1, pke1, pe1, u1, v1, thv1, q1 ) - -c Construct Output Dry Potential Temperature -c ------------------------------------------ - thv1 = thv1/(1+eps*q1(:,:,:,1)) - - return - end - -c****6***0*********0*********0*********0*********0*********0**********72 - subroutine gmap(im, jm, nq, - & km, pk3d_m, pe3d_m, u_m, v_m, pt_m, q_m, - & kn, pk3d_n, pe3d_n, u_n, v_n, pt_n, q_n ) -c****6***0*********0*********0*********0*********0*********0**********72 - - implicit none - - integer im, jm - integer km, kn, nq - -C Input: -C original data km-level - - real u_m(im,jm,km) - real v_m(im,jm,km) - real pt_m(im,jm,km) - real q_m(im,jm,km,nq) - real pk3d_m(im,jm,km+1) - real pe3d_m(im,jm,km+1) - - -C Output: -C New data (kn-level) - real u_n(im,jm,kn) - real v_n(im,jm,kn) - real pt_n(im,jm,kn) - real q_n(im,jm,kn,nq) - real pk3d_n(im,jm,kn+1) - real pe3d_n(im,jm,kn+1) - -c local (private) - integer i, j, k, n - - real pe1(im,km+1),pe2(im,kn+1) - real pk1(im,km+1),pk2(im,kn+1) - real dp1(im,km) ,dp2(im,kn) - real u1(im,km) , u2(im,kn) - real v1(im,km) , v2(im,kn) - real t1(im,km) , t2(im,kn) - real q1(im,km) , q2(im,kn) - - real undef - real big - parameter ( undef = 1.e15 ) - parameter ( big = 1.e10 ) - - - do 2000 j=1,jm - -c Copy original data to local 2D arrays. - - do k=1,km+1 - do i=1,im - pe1(i,k) = pe3d_m(i,j,k) - pk1(i,k) = pk3d_m(i,j,k) - enddo - enddo - - do k=1,kn+1 - do i=1,im - pe2(i,k) = pe3d_n(i,j,k) - pk2(i,k) = pk3d_n(i,j,k) - enddo - enddo - - do k=1,km - do i=1,im - dp1(i,k) = pk1(i,k+1)-pk1(i,k) - u1(i,k) = u_m(i,j,k) - v1(i,k) = v_m(i,j,k) - t1(i,k) = pt_m(i,j,k) - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pk2(i,k+1)-pk2(i,k) - enddo - enddo - -c map pt -c ------ - call mappm ( km, pk1, dp1, t1, kn, pk2, t2, im, 1, 7 ) - - do k=1,km - do i=1,im - dp1(i,k) = pe1(i,k+1)-pe1(i,k) - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pe2(i,k+1)-pe2(i,k) - enddo - enddo - -c map u,v -c ------- - call mappm ( km, pe1, dp1, u1, kn, pe2, u2, im, -1, 7 ) - call mappm ( km, pe1, dp1, v1, kn, pe2, v2, im, -1, 7 ) - -c map q -c ------- - do n=1,nq - do k=1,km - do i=1,im - q1(i,k) = q_m(i,j,k,n) - enddo - enddo - call mappm ( km, pe1, dp1, q1, kn, pe2, q2, im, 0, 7 ) - do k=1,kn - do i=1,im - q_n(i,j,k,n) = q2(i,k) - enddo - enddo - enddo - - do k=1,kn - do i=1,im - u_n(i,j,k) = u2(i,k) - v_n(i,j,k) = v2(i,k) - pt_n(i,j,k) = t2(i,k) - enddo - enddo - -2000 continue - - return - end - - -C****6***0*********0*********0*********0*********0*********0**********72 - subroutine mappm(km, pe1, dp1, q1, kn, pe2, q2, im, iv, kord) -C****6***0*********0*********0*********0*********0*********0**********72 -C IV = 0: constituents -C IV = 1: potential temp -C IV =-1: winds -C -C Mass flux preserving mapping: q1(im,km) -> q2(im,kn) -C -C pe1: pressure at layer edges (from model top to bottom surface) -C in the original vertical coordinate -C pe2: pressure at layer edges (from model top to bottom surface) -C in the new vertical coordinate - - parameter (kmax = 200) - parameter (R3 = 1./3., R23 = 2./3.) - - real dp1(im,km), - & q1(im,km), q2(im,kn), - & pe1(im,km+1), pe2(im,kn+1) - integer kord - -C local work arrays - real a4(4,im,km) - - do k=1,km - do i=1,im - a4(1,i,k) = q1(i,k) - enddo - enddo - - call ppm2m(a4, dp1, im, km, iv, kord) - -C Lowest layer: constant distribution - do i=1, im - a4(2,i,km) = q1(i,km) - a4(3,i,km) = q1(i,km) - a4(4,i,km) = 0. - enddo - - do 5555 i=1,im - k0 = 1 - do 555 k=1,kn - - if(pe2(i,k+1) .le. pe1(i,1)) then -! Entire grid above old ptop - q2(i,k) = a4(2,i,1) - elseif(pe2(i,k) .ge. pe1(i,km+1)) then -! Entire grid below old ps - q2(i,k) = a4(3,i,km) - elseif(pe2(i,k ) .lt. pe1(i,1) .and. - & pe2(i,k+1) .gt. pe1(i,1)) then -! Part of the grid above ptop - q2(i,k) = a4(1,i,1) - else - - do 45 L=k0,km -! locate the top edge at pe2(i,k) - if( pe2(i,k) .ge. pe1(i,L) .and. - & pe2(i,k) .le. pe1(i,L+1) ) then - k0 = L - PL = (pe2(i,k)-pe1(i,L)) / dp1(i,L) - if(pe2(i,k+1) .le. pe1(i,L+1)) then - -! entire new grid is within the original grid - PR = (pe2(i,k+1)-pe1(i,L)) / dp1(i,L) - TT = R3*(PR*(PR+PL)+PL**2) - q2(i,k) = a4(2,i,L) + 0.5*(a4(4,i,L)+a4(3,i,L) - & - a4(2,i,L))*(PR+PL) - a4(4,i,L)*TT - goto 555 - else -! Fractional area... - delp = pe1(i,L+1) - pe2(i,k) - TT = R3*(1.+PL*(1.+PL)) - qsum = delp*(a4(2,i,L)+0.5*(a4(4,i,L)+ - & a4(3,i,L)-a4(2,i,L))*(1.+PL)-a4(4,i,L)*TT) - dpsum = delp - k1 = L + 1 - goto 111 - endif - endif -45 continue - -111 continue - do 55 L=k1,km - if( pe2(i,k+1) .gt. pe1(i,L+1) ) then - -! Whole layer.. - - qsum = qsum + dp1(i,L)*q1(i,L) - dpsum = dpsum + dp1(i,L) - else - delp = pe2(i,k+1)-pe1(i,L) - esl = delp / dp1(i,L) - qsum = qsum + delp * (a4(2,i,L)+0.5*esl* - & (a4(3,i,L)-a4(2,i,L)+a4(4,i,L)*(1.-r23*esl)) ) - dpsum = dpsum + delp - k0 = L - goto 123 - endif -55 continue - delp = pe2(i,k+1) - pe1(i,km+1) - if(delp .gt. 0.) then -! Extended below old ps - qsum = qsum + delp * a4(3,i,km) - dpsum = dpsum + delp - endif -123 q2(i,k) = qsum / dpsum - endif -555 continue -5555 continue - - return - end - -c****6***0*********0*********0*********0*********0*********0**********72 - subroutine ppm2m(a4,delp,im,km,iv,kord) -c****6***0*********0*********0*********0*********0*********0**********72 -c iv = 0: positive definite scalars -c iv = 1: others -c iv =-1: winds - - implicit none - - integer im, km, lmt, iv - integer kord - integer i, k, km1 - real a4(4,im,km), delp(im,km) - -c local arrays. - real dc(im,km),delq(im,km) - real h2(im,km) - real a1, a2, c1, c2, c3, d1, d2 - real qmax, qmin, cmax, cmin - real qm, dq, tmp - -C Local scalars: - real qmp - real lac - - km1 = km - 1 - - do 500 k=2,km - do 500 i=1,im - delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) -500 a4(4,i,k ) = delp(i,k-1) + delp(i,k) - - do 1220 k=2,km1 - do 1220 i=1,im - c1 = (delp(i,k-1)+0.5*delp(i,k))/a4(4,i,k+1) - c2 = (delp(i,k+1)+0.5*delp(i,k))/a4(4,i,k) - tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / - & (a4(4,i,k)+delp(i,k+1)) - qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k) - qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp) -1220 continue - -c****6***0*********0*********0*********0*********0*********0**********72 -c 4th order interpolation of the provisional cell edge value -c****6***0*********0*********0*********0*********0*********0**********72 - - do 12 k=3,km1 - do 12 i=1,im - c1 = delq(i,k-1)*delp(i,k-1) / a4(4,i,k) - a1 = a4(4,i,k-1) / (a4(4,i,k) + delp(i,k-1)) - a2 = a4(4,i,k+1) / (a4(4,i,k) + delp(i,k)) - a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(a4(4,i,k-1)+a4(4,i,k+1)) * - & ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - - & delp(i,k-1)*a1*dc(i,k ) ) -12 continue - -C Area preserving cubic with 2nd deriv. = 0 at the boundaries -C Top - do i=1,im - d1 = delp(i,1) - d2 = delp(i,2) - qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) - dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) - c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) - c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1) - a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2) - dc(i,1) = a4(1,i,1) - a4(2,i,1) -C No over- and undershoot condition - cmax = max(a4(1,i,1), a4(1,i,2)) - cmin = min(a4(1,i,1), a4(1,i,2)) - a4(2,i,2) = max(cmin,a4(2,i,2)) - a4(2,i,2) = min(cmax,a4(2,i,2)) - enddo - - if(iv == 0) then - do i=1,im - a4(2,i,1) = max(0.,a4(2,i,1)) - a4(2,i,2) = max(0.,a4(2,i,2)) - enddo - elseif(iv == -1) then - do i=1,im - if( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. - enddo - endif - -c****6***0*********0*********0*********0*********0*********0**********72 - -c Bottom -c Area preserving cubic with 2nd deriv. = 0 at the surface - do 15 i=1,im - d1 = delp(i,km) - d2 = delp(i,km1) - qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) - dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) - c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) - c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1) - a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km) - dc(i,km) = a4(3,i,km) - a4(1,i,km) -c****6***0*********0*********0*********0*********0*********0**********72 -c No over- and undershoot condition - cmax = max(a4(1,i,km), a4(1,i,km1)) - cmin = min(a4(1,i,km), a4(1,i,km1)) - a4(2,i,km) = max(cmin,a4(2,i,km)) - a4(2,i,km) = min(cmax,a4(2,i,km)) -c****6***0*********0*********0*********0*********0*********0**********72 -15 continue - - if(iv .eq. 0) then - do i=1,im - a4(2,i,km) = max(0.,a4(2,i,km)) - a4(3,i,km) = max(0.,a4(3,i,km)) - enddo - endif - - do 20 k=1,km1 - do 20 i=1,im - a4(3,i,k) = a4(2,i,k+1) -20 continue -c -c f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) -c - -c Top 2 and bottom 2 layers always use monotonic mapping - - do k=1,2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) - enddo - - if(kord == 7) then -c****6***0*********0*********0*********0*********0*********0**********72 -C Huynh's 2nd constraint -c****6***0*********0*********0*********0*********0*********0**********72 - do k=2, km1 - do i=1,im - h2(i,k) = delq(i,k) - delq(i,k-1) - enddo - enddo - - do 4000 k=3, km-2 - do 3000 i=1, im -C Right edges - qmp = a4(1,i,k) + 2.0*delq(i,k-1) - lac = a4(1,i,k) + 1.5*h2(i,k-1) + 0.5*delq(i,k-1) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax) -C Left edges - qmp = a4(1,i,k) - 2.0*delq(i,k) - lac = a4(1,i,k) + 1.5*h2(i,k+1) - 0.5*delq(i,k) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax) -C Recompute A6 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) -3000 continue -! Additional constraint to prevent negatives - if (iv == 0) then - call kmppm(dc(1,k),a4(1,1,k),im, 2) - endif -4000 continue - - else - - lmt = kord - 3 - lmt = max(0, lmt) - if (iv .eq. 0) lmt = min(2, lmt) - - do k=3, km-2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, lmt) - enddo - endif - - do 5000 k=km1,km - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) -5000 continue - - return - end - -c****6***0*********0*********0*********0*********0*********0**********72 - subroutine kmppm(dm, a4, km, lmt) -c****6***0*********0*********0*********0*********0*********0**********72 - implicit none - - real r12 - parameter (r12 = 1./12.) - - integer km, lmt - integer i - real a4(4,km),dm(km) - real da1, da2, a6da - real fmin - real qmp - - if (lmt .eq. 3) return -! Full constraint - - if(lmt .eq. 0) then - do 100 i=1,km - if(dm(i) .eq. 0.) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da .lt. -da2) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da .gt. da2) then - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif -100 continue - elseif (lmt .eq. 2) then -c Positive definite - -c Positive definite constraint - do 250 i=1,km - if(abs(a4(3,i)-a4(2,i)) .ge. -a4(4,i)) go to 250 - fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 - if(fmin.ge.0.) go to 250 - if(a4(1,i).lt.a4(3,i) .and. a4(1,i).lt.a4(2,i)) then - a4(3,i) = a4(1,i) - a4(2,i) = a4(1,i) - a4(4,i) = 0. - elseif(a4(3,i) .gt. a4(2,i)) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - else - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif -250 continue - - elseif (lmt == 1) then - -! Improved full monotonicity constraint (Lin) -! Note: no need to provide first guess of A6 <-- a4(4,i) - - do i=1, km - qmp = 2.*dm(i) - a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) - a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) - a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) ) - enddo - endif - - return - end - - subroutine usage() - print *, "Usage: " - print * - print *, " rsg3_vinterp.x [-dynrst dynrst_fname] Default: fvcore_internal_restart" - print *, " [-moistrst moistrst_fname] Default: moist_internal_restart" - print *, " [-topo topo_fname] " - print * - print *, "where:" - print *, "-----" - print *, " -dynrst dynrst_fname: Filename of dynamics internal restart" - print *, " -moistrst moistrst_fname: Filename of moist internal restart" - print *, " -topo topo_fname: Filename of topography dataset" - print * - print *, "creates:" - print *, "-------" - print *, " New dynrst & moistrst restart files for ARIES" - print * - error stop 7 - end - - SUBROUTINE CTOA ( qc,qa,im,jm,km,itype ) -C -C ****************************************************************** -C **** **** -C **** This program converts 'C' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real*8 qa (im,jm,km) - real*8 qc (im,jm,km) - real*8 qz (im,jm,km) - - real*8 qcx ( im+2 ,km) - real*8 cx (2*(im+2),km) - real*8 qcy ( 2*jm ,km) - real*8 cy (2*(2*jm),km) - - real*8 cosx (im/2), sinx(im/2) - real*8 cosy (jm) , siny(jm) - integer IFX (100) , IFY (100) - REAL*8 TRIGX(3*(IM+1)) - REAL*8 TRIGY(3*(2*JM+1)) - REAL*8 pi,dx,dy - - parameter ( zero = 0.0 ) - parameter ( ahalf = 0.5 ) - - imh = IM/2 - JMM1 = JM-1 - JMM2 = JM-2 - JMM3 = JM-3 - JP = 2*jmm1 - - PI = 4.*ATAN(1.) - DX = 2*PI/IM - DY = PI/JMM1 - -C ********************************************************* -C **** define sinx, cosx and trigs coefficients **** -C ********************************************************* - - call fftfax (im,ifx,trigx) - do k=1,imh - thx = k*dx*ahalf - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - call fftfax (jp,ify,trigy) - do l=1,jmm1 - thy = l*dy*ahalf - cosy(l) = cos(thy) - siny(l) = sin(thy) - enddo - -C ********************************************************* -C **** load input array into temporary array **** -C ********************************************************* - - do i = 1,im*jm*km - qz(i,1,1) = qc(i,1,1) - enddo - -C ********************************************************* -C **** stagger in x-direction **** -C ********************************************************* - - if (itype.eq.1) then - do j=1,jm - - do l=1,km - do i=1,im - qcx(i,l) = qz(i,j,l) - enddo - enddo - call rfftmlt (qcx,cx,trigx,ifx,1 ,im+2,im,km,-1) - - do l=1,km - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qcx(kr,l)*cosx(k) + qcx(ki,l)*sinx(k) - ciprime = qcx(ki,l)*cosx(k) - qcx(kr,l)*sinx(k) - qcx(kr,l) = crprime - qcx(ki,l) = ciprime - enddo - enddo - - call rfftmlt (qcx,cx,trigx,ifx,1 ,im+2,im,km, 1) - do l=1,km - do i=1,im - qa(i,j,l) = qcx(i,l) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** stagger in y-direction **** -C ********************************************************* - - if (itype.eq.2) then - - do i=1,imh - - do l=1,km - do j=1,jmm1 - qcy(j,l) = qz(i,j,l) - qcy(j+jmm1,l) = -qz(i+imh,jmm1-j+1,l) - enddo - enddo - - call rfftmlt (qcy,cy,trigy,ify,1 ,jp+2,jp,km,-1) - - do l=1,km - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qcy(kr,l)*cosy(k) + qcy(ki,l)*siny(k) - ciprime = qcy(ki,l)*cosy(k) - qcy(kr,l)*siny(k) - qcy(kr,l) = crprime - qcy(ki,l) = ciprime - enddo - enddo - - call rfftmlt (qcy,cy,trigy,ify,1 ,jp+2,jp,km, 1) - - do l=1,km - do j=1,jmm1 - qa(i,j,l) = qcy(j,l) - qa(i+imh,jm-j+1,l) = -qcy(j+jmm1,l) - enddo - enddo - enddo - do l=1,km - do i=1,imh - qa(i+imh,1,l) = -qa(i,1,l) - qa(i,jm,l) = -qa(i+imh,jm,l) - enddo - enddo - endif - - return - END - - SUBROUTINE ATOC ( qa,qc,im,jm,km,itype ) -! -! ****************************************************************** -! **** **** -! **** This program converts 'A' gridded data **** -! **** to 'C' gridded data. **** -! **** **** -! **** An FFT shift transformation is made in x for itype = 1 **** -! **** An FFT shift transformation is made in y for itype = 2 **** -! **** **** -! ****************************************************************** - - real*8 qa (im,jm,km) - real*8 qc (im,jm,km) - real*8 qz (im,jm,km) - - real*8 qax ( im+2 ,km) - real*8 cx (2*(im+2),km) - real*8 qay ( 2*jm ,km) - real*8 cy (2*(2*jm),km) - - real*8 cosx (im/2), sinx(im/2) - real*8 cosy (jm) , siny(jm) - integer IFX (100) , IFY (100) - REAL*8 TRIGX( 3*(IM+1)) - REAL*8 TRIGY(3*(2*JM+1)) - REAL*8 dx,dy,pi - - parameter ( zero = 0.0 ) - parameter ( ahalf = 0.5 ) - - JMM1 = JM-1 - JMM2 = JM-2 - JMM3 = JM-3 - JP = 2*jmm1 - - IMD2 = IM/2 - PI = 4.0*ATAN(1.0) - DX = 2*PI/IM - DY = PI/JMM1 - -! ********************************************************* -! **** define sinx, cosx and trigs coefficients **** -! ********************************************************* - - call fftfax (im,ifx,trigx) - do k=1,im/2 - thx = k*dx*ahalf - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - call fftfax (jp,ify,trigy) - do l=1,jmm1 - thy = l*dy*ahalf - cosy(l) = cos(thy) - siny(l) = sin(thy) - enddo - -! ********************************************************* -! **** load input array into temporary array **** -! ********************************************************* - - do i = 1,im*jm*km - qz(i,1,1) = qa(i,1,1) - enddo - -! ********************************************************* -! **** stagger in x-direction **** -! ********************************************************* - - if (itype.eq.1) then - do j=1,jm - - do l=1,km - do i=1,im - qax(i,l) = qz(i,j,l) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,km,-1) - - do l=1,km - do k=1,IMD2 - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,l)*cosx(k) - qax(ki,l)*sinx(k) - ciprime = qax(ki,l)*cosx(k) + qax(kr,l)*sinx(k) - qax(kr,l) = crprime - qax(ki,l) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,km, 1) - do l=1,km - do i=1,im - qc(i,j,l) = qax(i,l) - enddo - enddo - - enddo - - endif - -C ********************************************************* -C **** stagger in y-direction **** -C ********************************************************* - - if (itype.eq.2) then - - do i=1,im/2 - - do l=1,km - do j=1,jmm1 - qay(j,l) = qz(i,j,l) - qay(j+jmm1,l) = -qz(i+imd2,jm-j+1,l) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,km,-1) - - do l=1,km - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,l)*cosy(k) - qay(ki,l)*siny(k) - ciprime = qay(ki,l)*cosy(k) + qay(kr,l)*siny(k) - qay(kr,l) = crprime - qay(ki,l) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,km, 1) - - do l=1,km - do j=1,jmm1 - qc(i,j,l) = qay(j,l) - qc(i+imd2,jmm1-j+1,l) = -qay(j+jmm1,l) - enddo - enddo - - enddo - - endif - - RETURN - END - - subroutine writit (q,im,jm,lm,ku) - real q(im,jm,lm) - real*4 a(im,jm) - do L=1,lm - a(:,:) = q(:,:,L) - write(ku) a - enddo - return - end - - subroutine atod ( qa,qd,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded data **** -C **** to 'D' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted left (westward), **** -C **** u is shifted down (southward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real qax ( im+2 ,lm) - real cx (2*(im+2),lm) - real qay ( 2*jm ,lm) - real cy (2*(2*jm),lm) - - real cosx (im/2), sinx(im/2) - real cosy (jm) , siny(jm) - real trigx(3*(im+1)) - real trigy(3*(2*jm)) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - -C ********************************************************* -C **** shift left (-dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qa(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) + qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) - qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qd(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift down (-dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qa(i,j+1,L) - qay(j+jmm1,L) = -qa(i+imh,jm-j,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) + qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) - qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qd(i,j+1,L) = qay(j,L) - qd(i+imh,jm-j+1,L) = -qay(j+jmm1,L) - enddo - enddo - enddo - - endif - - return - end - - subroutine dtoa ( qd,qa,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real qa (im,jm,lm) - real qd (im,jm,lm) - - real qax ( im+2 ,lm) - real cx (2*(im+2),lm) - real qay ( 2*jm ,lm) - real cy (2*(2*jm),lm) - - real cosx (im/2), sinx(im/2) - real cosy (jm) , siny(jm) - real trigx(3*(im+1)) - real trigy(3*(2*jm)) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - -C ********************************************************* -C **** shift right (dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qd(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) - qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) + qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qa(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift up (dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qd(i,j+1,L) - qay(j+jmm1,L) = -qd(i+imh,jm-j+1,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) - qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) + qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qa(i,j+1,L) = qay(j,L) - qa(i+imh,jm-j,L) = -qay(j+jmm1,L) - enddo - enddo - - enddo - - do L=1,lm - do i=1,imh - qa(i+imh,jm,L) = -qa(i,jm,L) - qa(i,1,L) = -qa(i+imh,1,L) - enddo - enddo - endif - - return - end - - subroutine rfftmlt (a,work,trigs,ifax,inc,jump,n,lot,isign) - integer INC, JUMP, N, LOT, ISIGN - real(kind=KIND(1.0)) A(N),WORK(N),TRIGS(N) - integer IFAX(*) -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR -! CALL Q8QST4 ( 4HXLIB, 6HFFT99F, 6HFFT991, 10HVERSION 01) -!FPP$ NOVECTOR R - integer NFAX, NH, NX, INK - integer I, J, IBASE, JBASE, L, IGO, IA, LA, K, M, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, - * INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, - * 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 -!DIR$ IVDEP - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END - - subroutine fftfax (n,ifax,trigs) - integer IFAX(13) - integer N - REAL(kind=KIND(1.0)) TRIGS(*) -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - integer I, MODE - DATA MODE /3/ -!FPP$ NOVECTOR R - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) WRITE(6,FMT="(//5X, ' FFTFAX -- INVALID N =', I5,/)") N - IF (IFAX(1) .LE. 0 ) STOP 999 - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END - - subroutine fft99a (a,work,trigs,inc,jump,n,lot) - integer inc, jump, N, lot - real(kind=KIND(1.0)) A(N),WORK(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 -! (SPECTRAL TO GRIDPOINT TRANSFORM) -! -!FPP$ NOVECTOR R - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) C, S - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - IA=1 - IB=N*INC+1 - JA=1 - JB=2 -!DIR$ IVDEP - DO 10 L=1,LOT - WORK(JA)=A(IA)+A(IB) - WORK(JB)=A(IA)-A(IB) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 10 CONTINUE -! -! REMAINING WAVENUMBERS - IABASE=2*INC+1 - IBBASE=(N-2)*INC+1 - JABASE=3 - JBBASE=N-1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - WORK(JA)=(A(IA)+A(IB))- - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JB)=(A(IA)+A(IB))+ - * (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+ - * (A(IA+INC)-A(IB+INC)) - WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))- - * (A(IA+INC)-A(IB+INC)) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 20 CONTINUE - IABASE=IABASE+INK - IBBASE=IBBASE-INK - JABASE=JABASE+2 - JBBASE=JBBASE-2 - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE -!DIR$ IVDEP - DO 40 L=1,LOT - WORK(JA)=2.0*A(IA) - WORK(JA+1)=-2.0*A(IA+INC) - IA=IA+JUMP - JA=JA+NX - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fft99b (work,a,trigs,inc,jump,n,lot) - integer INC, JUMP, N, LOT - real(kind=KIND(1.0)) WORK(N),A(N) - REAL(kind=KIND(1.0)) TRIGS(N) - integer NH, NX, INK, IA, IB, JA, JB, K, L - integer IABASE, IBBASE, JABASE, JBBASE - real(kind=KIND(1.0)) SCALE - real(kind=KIND(1.0)) C, S -! -! SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 -! (GRIDPOINT TO SPECTRAL TRANSFORM) -! -!FPP$ NOVECTOR R - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - SCALE=1.0/FLOAT(N) - IA=1 - IB=2 - JA=1 - JB=N*INC+1 -!DIR$ IVDEP - DO 10 L=1,LOT - A(JA)=SCALE*(WORK(IA)+WORK(IB)) - A(JB)=SCALE*(WORK(IA)-WORK(IB)) - A(JA+INC)=0.0 - A(JB+INC)=0.0 - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 10 CONTINUE -! -! REMAINING WAVENUMBERS - SCALE=0.5*SCALE - IABASE=3 - IBBASE=N-1 - JABASE=2*INC+1 - JBBASE=(N-2)*INC+1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) -!DIR$ IVDEP - DO 20 L=1,LOT - A(JA)=SCALE*((WORK(IA)+WORK(IB)) - * +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JB)=SCALE*((WORK(IA)+WORK(IB)) - * -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * +(WORK(IB+1)-WORK(IA+1))) - A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) - * -(WORK(IB+1)-WORK(IA+1))) - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 20 CONTINUE - IABASE=IABASE+2 - IBBASE=IBBASE-2 - JABASE=JABASE+INK - JBBASE=JBBASE-INK - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - SCALE=2.0*SCALE -!DIR$ IVDEP - DO 40 L=1,LOT - A(JA)=SCALE*WORK(IA) - A(JA+INC)=-SCALE*WORK(IA+1) - IA=IA+NX - JA=JA+JUMP - 40 CONTINUE -! - 50 CONTINUE - RETURN - END - - subroutine fax (ifax,n,mode) - integer IFAX(10) - integer N, MODE -!FPP$ NOVECTOR R - integer NN, K, L, INC, II, ISTOP, ITEM, NFAX, I - NN=N - IF (IABS(MODE).EQ.1) GO TO 10 - IF (IABS(MODE).EQ.8) GO TO 10 - NN=N/2 - IF ((NN+NN).EQ.N) GO TO 10 - IFAX(1)=-99 - RETURN - 10 K=1 -! TEST FOR FACTORS OF 4 - 20 IF (MOD(NN,4).NE.0) GO TO 30 - K=K+1 - IFAX(K)=4 - NN=NN/4 - IF (NN.EQ.1) GO TO 80 - GO TO 20 -! TEST FOR EXTRA FACTOR OF 2 - 30 IF (MOD(NN,2).NE.0) GO TO 40 - K=K+1 - IFAX(K)=2 - NN=NN/2 - IF (NN.EQ.1) GO TO 80 -! TEST FOR FACTORS OF 3 - 40 IF (MOD(NN,3).NE.0) GO TO 50 - K=K+1 - IFAX(K)=3 - NN=NN/3 - IF (NN.EQ.1) GO TO 80 - GO TO 40 -! NOW FIND REMAINING FACTORS - 50 L=5 - INC=2 -! INC ALTERNATELY TAKES ON VALUES 2 AND 4 - 60 IF (MOD(NN,L).NE.0) GO TO 70 - K=K+1 - IFAX(K)=L - NN=NN/L - IF (NN.EQ.1) GO TO 80 - GO TO 60 - 70 L=L+INC - INC=6-INC - GO TO 60 - 80 IFAX(1)=K-1 -! IFAX(1) CONTAINS NUMBER OF FACTORS - NFAX=IFAX(1) -! SORT FACTORS INTO ASCENDING ORDER - IF (NFAX.EQ.1) GO TO 110 - DO 100 II=2,NFAX - ISTOP=NFAX+2-II - DO 90 I=2,ISTOP - IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 - ITEM=IFAX(I) - IFAX(I)=IFAX(I+1) - IFAX(I+1)=ITEM - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN - END - - subroutine fftrig (trigs,n,mode) - REAL(kind=KIND(1.0)) TRIGS(*) - integer N, MODE -!FPP$ NOVECTOR R - real(kind=KIND(1.0)) PI - integer IMODE, NN, L, I, NH, LA - real(kind=KIND(1.0)) DEL, ANGLE - PI=2.0*ASIN(1.0) - IMODE=IABS(MODE) - NN=N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 - DEL=(PI+PI)/FLOAT(NN) - L=NN+NN - DO 10 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(I)=COS(ANGLE) - TRIGS(I+1)=SIN(ANGLE) - 10 CONTINUE - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - DEL=0.5*DEL - NH=(NN+1)/2 - L=NH+NH - LA=NN+NN - DO 20 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(LA+I)=COS(ANGLE) - TRIGS(LA+I+1)=SIN(ANGLE) - 20 CONTINUE - IF (IMODE.LE.3) RETURN - DEL=0.5*DEL - LA=LA+NN - IF (MODE.EQ.5) GO TO 40 - DO 30 I=2,NN - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=2.0*SIN(ANGLE) - 30 CONTINUE - RETURN - 40 CONTINUE - DEL=0.5*DEL - DO 50 I=2,N - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=SIN(ANGLE) - 50 CONTINUE - RETURN - END - - subroutine vpassm (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la) - integer INC1,INC2,INC3,INC4,LOT,N,IFAC,LA - real(kind=KIND(1.0)) A(N),B(N),C(N),D(N) - REAL(kind=KIND(1.0)) TRIGS(N) -! -! SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA" -! PERFORMS ONE PASS THROUGH DATA -! AS PART OF MULTIPLE COMPLEX FFT ROUTINE -! A IS FIRST REAL INPUT VECTOR -! B IS FIRST IMAGINARY INPUT VECTOR -! C IS FIRST REAL OUTPUT VECTOR -! D IS FIRST IMAGINARY OUTPUT VECTOR -! TRIGS IS PRECALCULATED TABLE OF SINES & COSINES -! INC1 IS ADDRESSING INCREMENT FOR A AND B -! INC2 IS ADDRESSING INCREMENT FOR C AND D -! INC3 IS ADDRESSING INCREMENT BETWEEN As & Bs -! INC4 IS ADDRESSING INCREMENT BETWEEN Cs & Ds -! LOT IS THE NUMBER OF VECTORS -! N IS LENGTH OF VECTORS -! IFAC IS CURRENT FACTOR OF N -! LA IS PRODUCT OF PREVIOUS FACTORS -! - real(kind=KIND(1.0)) SIN36, COS36, SIN72, COS72, SIN60 - DATA SIN36/0.587785252292473/,COS36/0.809016994374947/, - * SIN72/0.951056516295154/,COS72/0.309016994374947/, - * SIN60/0.866025403784437/ - integer M, IINK, JINK, JUMP, IBASE, JBASE, IGO, IA, JA, IB, JB - integer IC, JC, ID, JD, IE, JE - integer I, J, K, L, IJK, LA1, KB, KC, KD, KE - real(kind=KIND(1.0)) C1, S1, C2, S2, C3, S3, C4, S4 -! -!FPP$ NOVECTOR R - M=N/IFAC - IINK=M*INC1 - JINK=LA*INC2 - JUMP=(IFAC-1)*JINK - IBASE=0 - JBASE=0 - IGO=IFAC-1 - IF (IGO.GT.4) RETURN - GO TO (10,50,90,130),IGO -! -! CODING FOR FACTOR 2 -! - 10 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - DO 20 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 15 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=A(IA+I)-A(IB+I) - D(JB+J)=B(IA+I)-B(IB+I) - I=I+INC3 - J=J+INC4 - 15 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 20 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 40 K=LA1,M,LA - KB=K+K-2 - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - DO 30 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 25 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) - D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) - I=I+INC3 - J=J+INC4 - 25 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 30 CONTINUE - JBASE=JBASE+JUMP - 40 CONTINUE - RETURN -! -! CODING FOR FACTOR 3 -! - 50 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - DO 60 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 55 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))) - C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))) - D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))) - D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))) - I=I+INC3 - J=J+INC4 - 55 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 60 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 80 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - DO 70 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 65 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)= - * C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - D(JB+J)= - * S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) - * +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - C(JC+J)= - * C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - D(JC+J)= - * S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) - * +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - I=I+INC3 - J=J+INC4 - 65 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 70 CONTINUE - JBASE=JBASE+JUMP - 80 CONTINUE - RETURN -! -! CODING FOR FACTOR 4 -! - 90 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - DO 100 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 95 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) - C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) - C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) - D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) - D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) - I=I+INC3 - J=J+INC4 - 95 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 100 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 120 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - DO 110 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 105 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - C(JC+J)= - * C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - D(JC+J)= - * S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) - * +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - C(JB+J)= - * C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - D(JB+J)= - * S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) - * +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - C(JD+J)= - * C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - D(JD+J)= - * S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) - * +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 105 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 110 CONTINUE - JBASE=JBASE+JUMP - 120 CONTINUE - RETURN -! -! CODING FOR FACTOR 5 -! - 130 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - IE=ID+IINK - JE=JD+JINK - DO 140 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 135 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 135 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 140 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 160 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - KE=KD+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - C4=TRIGS(KE+1) - S4=TRIGS(KE+2) - DO 150 L=1,LA - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 145 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)= - * C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JB+J)= - * S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JE+J)= - * C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JE+J)= - * S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) - * +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) - * +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) - * -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JC+J)= - * C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JC+J)= - * S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - C(JD+J)= - * C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JD+J)= - * S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) - * +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) - * +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) - * -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - I=I+INC3 - J=J+INC4 - 145 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 150 CONTINUE - JBASE=JBASE+JUMP - 160 CONTINUE - RETURN - END - - subroutine checkfile ( filename ) - character(*) filename - logical file_exists - inquire( file=trim(filename), exist=file_exists ) - if( file_exists ) return - print * - print *, 'File: ',trim(filename),' does not exist!' - print * - stop - end - - subroutine windfix ( ua,va,plea, - . ub,vb,pleb, - . im,jm,lm,method ) - - integer im,jm,lm,method - real ua(im,jm,lm) - real va(im,jm,lm) - real plea(im,jm,lm+1) - real ub(im,jm,lm) - real vb(im,jm,lm) - real pleb(im,jm,lm+1) - - real dpa(im,jm,lm) - real dpb(im,jm,lm) - real diva(im,jm,lm) - real divb(im,jm,lm) - - real, allocatable :: uglo(:,:,:) - real, allocatable :: vglo(:,:,:) - real, allocatable :: dglo(:,:,:) - real, allocatable :: dpglo(:,:,:) - - real, allocatable :: sum1(:,:) - real, allocatable :: sum2(:,:) - real, allocatable :: sum3(:,:) - real, allocatable :: lambda(:,:) - - real, allocatable :: vor(:,:) - real, allocatable :: div(:,:) - real, allocatable :: chi(:,:) - real, allocatable :: psi(:,:) - real, allocatable :: chix(:,:) - real, allocatable :: chiy(:,:) - real, allocatable :: psix(:,:) - real, allocatable :: psiy(:,:) - - integer L - integer img, jmg - - img = im - jmg = jm - - allocate ( uglo(img,jmg,lm) ) - allocate ( vglo(img,jmg,lm) ) - allocate ( dglo(img,jmg,lm) ) - allocate ( dpglo(img,jmg,lm) ) - - allocate ( vor(img,jmg) ) - allocate ( div(img,jmg) ) - allocate ( chi(img,jmg) ) - allocate ( psi(img,jmg) ) - allocate ( chix(img,jmg) ) - allocate ( chiy(img,jmg) ) - allocate ( psix(img,jmg) ) - allocate ( psiy(img,jmg) ) - - allocate ( sum1(im,jm) ) - allocate ( sum2(im,jm) ) - allocate ( sum3(im,jm) ) - allocate ( lambda(im,jm) ) - -C ********************************************************************** -C **** Modify Winds to Produce Vanishing Divergence Increment **** -C ********************************************************************** - -! Compute Pressure Thickness -! -------------------------- - do L=1,lm - dpa(:,:,L) = ( plea(:,:,L+1)-plea(:,:,L) ) - dpb(:,:,L) = ( pleb(:,:,L+1)-pleb(:,:,L) ) - enddo - -c Compute Divergence on D-Grid -c ---------------------------- - do L=1,lm - call getdivd (ub(1,1,L),vb(1,1,L),dpb(1,1,L),divb(1,1,L),img,jmg ) - enddo - -c Perform 5 Iterations for Convergence -c ------------------------------------ - print * - do iter = 1,5 - -c Compute Divergence on C-Grid -c ---------------------------- - do L=1,lm - call getdivc (ua(1,1,L),va(1,1,L),dpa(1,1,L),diva(1,1,L),img,jmg ) - enddo - -c Minimize Change -c --------------- - if( method.eq.0 ) then - sum1(:,:) = 0.0 - sum2(:,:) = 0.0 - sum3(:,:) = 0.0 - do L=1,lm - sum1(:,:) = sum1(:,:) + diva(:,:,L) - sum2(:,:) = sum2(:,:) + divb(:,:,L) - enddo - lambda = (sum1-sum2) / lm - lambda = sum1 / lm - do L=1,lm - diva(:,:,L) = -lambda(:,:) - enddo - sum3(:,:) = sum1(:,:) - do L=1,lm - sum3(:,:) = sum3(:,:) + diva(:,:,L) - enddo - endif - -c Minimize Relative Change -c ------------------------ - if( method.eq.1 ) then - sum1(:,:) = 0.0 - sum2(:,:) = 0.0 - sum3(:,:) = 0.0 - do L=1,lm - sum1(:,:) = sum1(:,:) + diva(:,:,L) - sum2(:,:) = sum2(:,:) + divb(:,:,L) - sum3(:,:) = sum3(:,:) + (diva(:,:,L)-divb(:,:,L))**2 - enddo - where( sum3 .ne. 0.0 ) - lambda = (sum1-sum2) / sum3 - elsewhere - lambda = 0.0 - endwhere - do L=1,lm - diva(:,:,L) = -lambda(:,:)*( diva(:,:,L)-divb(:,:,L) )**2 - enddo - sum3(:,:) = sum1(:,:) - do L=1,lm - sum3(:,:) = sum3(:,:) + diva(:,:,L) - enddo - endif - -c Minimize Absolute Change -c ------------------------ - if( method.eq.2 ) then - sum1(:,:) = 0.0 - sum2(:,:) = 0.0 - sum3(:,:) = 0.0 - do L=1,lm - sum1(:,:) = sum1(:,:) + diva(:,:,L) - sum2(:,:) = sum2(:,:) + divb(:,:,L) - sum3(:,:) = sum3(:,:) + dpa(:,:,L)**2 - enddo - lambda = (sum1-sum2) / sum3 - do L=1,lm - diva(:,:,L) = -lambda(:,:)*dpa(:,:,L)**2 - enddo - sum3(:,:) = sum1(:,:) - do L=1,lm - sum3(:,:) = sum3(:,:) + diva(:,:,L) - enddo - endif - - call writit ( sum1,im,jm,1,55 ) - call writit ( sum2,im,jm,1,55 ) - call writit ( sum3,im,jm,1,55 ) - - dsum = 0.0 - do j=1,jm - do i=1,im - dsum = dsum + ( sum1(i,j)-sum2(i,j) )**2 - enddo - enddo - -c Compute Wind Increments Associated with Divergence Increment -c ------------------------------------------------------------ - do L=1,lm - call laplace (diva(1,1,L),chi,img,jmg) - call gradq (chi, chix,chiy,img,jmg) - - do j=1,jm - i = im - do ip1=1,im - sum1(i,j) = 2*chix(i,j)/( dpa(i,j,L)+dpa(ip1,j,L) ) - i=ip1 - enddo - enddo - chix = sum1 - - do j=1,jm-1 - do i=1,im - sum1(i,j) = 2*chiy(i,j)/( dpa(i,j,L)+dpa(i,j+1,L) ) - enddo - enddo - sum1(:,jm) = 0.0 - chiy = sum1 - - ua(:,:,L) = ua(:,:,L) + chix(:,:) - va(:,:,L) = va(:,:,L) + chiy(:,:) - enddo - - print *, 'Iter # ',iter,' Dsum: ',dsum - enddo - print * - - deallocate ( sum1,sum2,sum3,lambda ) - deallocate ( chi,chix,chiy ) - deallocate ( uglo,vglo,dglo,dpglo ) - - return - end - - subroutine minmax (q,im,jm,qmin,qmax) - real q(im,jm) - do j=1,jm - do i=1,im - if( q(i,j).gt.qmax ) qmax = q(i,j) - if( q(i,j).lt.qmin ) qmin = q(i,j) - enddo - enddo - return - end - - SUBROUTINE GETDIVD ( U,V,DP,DIV,IM,JM ) -C ******************************************************************** -C **** **** -C **** THIS PROGRAM CALCULATES DIVERGENCE **** -C **** AT EACH LEVEL FOR A NON-STAGGERED A-GRID **** -C **** **** -C **** INPUT: **** -C **** U ....... ZONAL WIND **** -C **** V ....... MERIDIONAL WIND **** -C **** IM ...... NUMBER OF LONGITUDE POINTS **** -C **** JM ...... NUMBER OF LATITUDE POINTS **** -C **** **** -C **** OUTPUT: **** -C **** DIV (IM,JM) .... DIVERGENCE **** -C **** **** -C ******************************************************************** - - real U(IM,JM) - real V(IM,JM) - real DP(IM,JM) - real DIV(IM,JM) - - real u1y (IM,JM) - real v1x (IM,JM) - real P1X (IM,JM) - real P1Y (IM,JM) - real TMP1(IM,JM) - real TMP2(IM,JM) - real cosij(IM,JM) - - DIMENSION MSGN(2) - - DATA MSGN /-1,1/ - -C ********************************************************* -C **** INITIALIZATION FOR DIVERGENCE **** -C ********************************************************* - - A = 6.372e6 - pi = 4.*atan(1.) - dlon = 2*pi/ im - dlat = pi/(jm-1) - - C11 = 1.0 / (4.0*A*IM*(1.0-COS(0.5*dlat))) - - CX1 = 1.0 / (4.0*A*dlon) - CY1 = 1.0 / (4.0*A*dlat) - - do j=2,jm-1 - phi = -pi/2.+(j-1)*dlat - cosphi = cos(phi) - do i=1,im - cosij(i,j) = cosphi - enddo - enddo - cosij(:,1) = 0.0 - cosij(:,jm) = 0.0 - -C ******************************************************** -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - DO j=2,jm-1 - DO i=1,im - u1y(i,j) = ( U(i,j)+U(i,j+1) )*0.5 - ENDDO - ENDDO - - DO j=2,jm-1 - i=im - DO Ip1=1,im - v1x(I,j) = ( V(I,J)+V(Ip1,j) )*0.5 - i=ip1 - ENDDO - ENDDO - v1x(:, 1) = 0.0 - v1x(:,jm) = 0.0 - -C ******************************************************** -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - DO j=2,jm-1 - i =im - DO ip1=1,im - P1X(i,j) = ( U1y(ip1,j)+U1y(i,j) )*( DP(ip1,j)+DP(i,j) ) - i =ip1 - ENDDO - ENDDO - - DO j=1,jm-1 - DO I=1,im - P1Y(I,j) = ( V1x(I,J+1)*COSIJ(I,J+1)+V1x(I,j)*COSIJ(I,j) )*( DP(I,J+1)+DP(I,J) ) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE **** -C ********************************************************* - - DO j=2,jm-1 - im1=im - DO i=1,im - TMP1(i,j) = ( P1X(i,j)-P1X(im1,j) )*CX1 - im1=i - ENDDO - - DO I=1,im - TMP2(I,j) = ( P1Y(I,j) -P1Y(I,j-1) )*CY1 - DIV (I,j) = ( TMP1(I,j)+TMP2(I,j) )/(cosij(i,j)) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE AT POLES **** -C ********************************************************* - - DO 100 M=1,2 - JPOLE = 1 + (M-1)*(jm-1) - JPH = 1 + (M-1)*(jm-2) - - SUM11 = 0.0 - DO I=1,im - SUM11 = SUM11 + P1Y(I,JPH) - ENDDO - - DO I=1,im - DIV(I,JPOLE) = - MSGN(M) * C11*SUM11 - ENDDO - 100 CONTINUE - - RETURN - END - SUBROUTINE GETDIVC( U,V,DP,DIV,IM,JM ) -C ******************************************************************** -C **** **** -C **** THIS PROGRAM CALCULATES DIVERGENCE **** -C **** AT EACH LEVEL FOR A NON-STAGGERED A-GRID **** -C **** **** -C **** INPUT: **** -C **** U ....... ZONAL WIND **** -C **** V ....... MERIDIONAL WIND **** -C **** IM ...... NUMBER OF LONGITUDE POINTS **** -C **** JM ...... NUMBER OF LATITUDE POINTS **** -C **** **** -C **** OUTPUT: **** -C **** DIV (IM,JM) .... DIVERGENCE **** -C **** **** -C ******************************************************************** - - real U(IM,JM) - real V(IM,JM) - real DP(IM,JM) - real DIV(IM,JM) - - real P1X (IM,JM) - real P1Y (IM,JM) - real TMP1(IM,JM) - real TMP2(IM,JM) - real cosij(IM,JM) - - DIMENSION MSGN(2) - - DATA MSGN /-1,1/ - -C ********************************************************* -C **** INITIALIZATION FOR DIVERGENCE **** -C ********************************************************* - - A = 6.372e6 - pi = 4.*atan(1.) - dlon = 2*pi/ im - dlat = pi/(jm-1) - - C11 = 1.0 / (4.0*A*IM*(1.0-COS(0.5*dlat))) - - CX1 = 1.0 / (4.0*A*dlon) - CY1 = 1.0 / (4.0*A*dlat) - - do j=2,jm-1 - phi = -pi/2.+(j-1)*dlat - cosphi = cos(phi) - do i=1,im - cosij(i,j) = cosphi - enddo - enddo - cosij(:,1) = 0.0 - cosij(:,jm) = 0.0 - -C ******************************************************** -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - DO j=2,jm-1 - i =im - DO ip1=1,im - P1X(i,j) = ( 2*U(i,j) )*( DP(ip1,j)+DP(i,j) ) - i =ip1 - ENDDO - ENDDO - - DO j=1,jm-1 - DO I=1,im - P1Y(I,j) = V(I,j)*( COSIJ(I,J+1)+COSIJ(I,j) )*( DP(I,J+1)+DP(I,J) ) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE **** -C ********************************************************* - - DO j=2,jm-1 - im1=im - DO i=1,im - TMP1(i,j) = ( P1X(i,j)-P1X(im1,j) )*CX1 - im1=i - ENDDO - - DO I=1,im - TMP2(I,j) = ( P1Y(I,j) -P1Y(I,j-1) )*CY1 - DIV (I,j) = ( TMP1(I,j)+TMP2(I,j) )/(cosij(i,j)) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE AT POLES **** -C ********************************************************* - - DO 100 M=1,2 - JPOLE = 1 + (M-1)*(jm-1) - JPH = 1 + (M-1)*(jm-2) - - SUM11 = 0.0 - DO I=1,im - SUM11 = SUM11 + P1Y(I,JPH) - ENDDO - - DO I=1,im - DIV(I,JPOLE) = - MSGN(M) * C11*SUM11 - ENDDO - 100 CONTINUE - - RETURN - END - SUBROUTINE GETDIV ( U,V,DP,DIV,IM,JM ) -C ******************************************************************** -C **** **** -C **** THIS PROGRAM CALCULATES DIVERGENCE **** -C **** AT EACH LEVEL FOR A NON-STAGGERED A-GRID **** -C **** **** -C **** INPUT: **** -C **** U ....... ZONAL WIND **** -C **** V ....... MERIDIONAL WIND **** -C **** IM ...... NUMBER OF LONGITUDE POINTS **** -C **** JM ...... NUMBER OF LATITUDE POINTS **** -C **** **** -C **** OUTPUT: **** -C **** DIV (IM,JM) .... DIVERGENCE **** -C **** **** -C ******************************************************************** - - real U(IM,JM) - real V(IM,JM) - real DP(IM,JM) - real DIV(IM,JM) - - real P1X (IM,JM) - real P1Y (IM,JM) - real TMP1(IM,JM) - real TMP2(IM,JM) - real cosij(IM,JM) - - DIMENSION MSGN(2) - - DATA MSGN /-1,1/ - -C ********************************************************* -C **** INITIALIZATION FOR DIVERGENCE **** -C ********************************************************* - - A = 6.372e6 - pi = 4.*atan(1.) - dlon = 2*pi/ im - dlat = pi/(jm-1) - - C11 = 1.0 / (4.0*A*IM*(1.0-COS(0.5*dlat))) - - CX1 = 1.0 / (4.0*A*dlon) - CY1 = 1.0 / (4.0*A*dlat) - - do j=2,jm-1 - phi = -pi/2.+(j-1)*dlat - cosphi = cos(phi) - do i=1,im - cosij(i,j) = cosphi - enddo - enddo - cosij(:,1) = 0.0 - cosij(:,jm) = 0.0 - -C ******************************************************** -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - DO j=2,jm-1 - i =im - DO ip1=1,im - P1X(i,j) = ( U(ip1,j)+U(i,j) )*( DP(ip1,j)+DP(i,j) ) - i =ip1 - ENDDO - ENDDO - - DO j=1,jm-1 - DO I=1,im - P1Y(I,j) = ( V(I,J+1)*COSIJ(I,J+1)+V(I,j)*COSIJ(I,j) )*( DP(I,J+1)+DP(I,J) ) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE **** -C ********************************************************* - - DO j=2,jm-1 - im1=im - DO i=1,im - TMP1(i,j) = ( P1X(i,j)-P1X(im1,j) )*CX1 - im1=i - ENDDO - - DO I=1,im - TMP2(I,j) = ( P1Y(I,j) -P1Y(I,j-1) )*CY1 - DIV (I,j) = ( TMP1(I,j)+TMP2(I,j) )/(cosij(i,j)) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE AT POLES **** -C ********************************************************* - - DO 100 M=1,2 - JPOLE = 1 + (M-1)*(jm-1) - JPH = 1 + (M-1)*(jm-2) - - SUM11 = 0.0 - DO I=1,im - SUM11 = SUM11 + P1Y(I,JPH) - ENDDO - - DO I=1,im - DIV(I,JPOLE) = - MSGN(M) * C11*SUM11 - ENDDO - 100 CONTINUE - - RETURN - END - SUBROUTINE GRADQ0(Q,DQDX,DQDY,IM,JM) -C ********************************************************* -C **** **** -C **** THIS PROGRAM CALCULATES THE HORIZONTAL **** -C **** GRADIENT OF THE INPUT FIELD Q **** -C **** **** -C **** ARGUMENTS: **** -C **** Q ....... FIELD TO BE DIFFERENTIATED **** -C **** DQDX .... LONGITUDINAL Q-DERIVATIVE **** -C **** DQDY .... MERIDIONAL Q-DERIVATIVE **** -C **** IM ...... NUMBER OF LONGITUDINAL POINTS **** -C **** JM ...... NUMBER OF LATITUDINAL POINTS **** -C **** **** -C ********************************************************* - - use MAPL_ConstantsMod - implicit none - integer im,jm - - real Q(IM,JM) - real DQDX(IM,JM) - real DQDY(IM,JM) - real Q1X(IM,JM) - real Q2X(IM,JM) - real Q1Y(IM,JM) - real Q2Y(IM,JM) - real acos(JM) - real sinl(IM) - real cosl(IM) - - real cx1,cx2,cy1,cy2,uc,vc,us,vs - real dl,dp,a,pi,fjeq,phi - integer i,j,m,ip1,ip2,jpole,msgn - -C ********************************************************* -C **** INITIALIZATION **** -C ********************************************************* - - a = MAPL_RADIUS - pi = 4.0*atan(1.0) - dl = 2.0*pi/im - dp = pi/(jm-1) - - CX1 = 2.0 / ( 3.0*A*DL) - CX2 = 1.0 / (12.0*A*DL) - CY1 = 2.0 / ( 3.0*A*DP) - CY2 = 1.0 / (12.0*A*DP) - - Q1X(:,:) = 0.0 - Q2X(:,:) = 0.0 - Q1Y(:,:) = 0.0 - Q2Y(:,:) = 0.0 - - fjeq = ( jm+1 )*0.5 - do j=2,jm-1 - phi = dp * (j-fjeq) - acos(j) = 1.0/( cos(phi) ) - enddo - do i=1,im/2 - cosl(i) = -cos((i-1)*dl) - cosl(i+im/2) = -cosl(i) - sinl(i) = -sin((i-1)*dl) - sinl(i+im/2) = -sinl(i) - enddo - -C ********************************************************* -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - do j = 2,jm-1 - i = im-1 - ip1 = im - do ip2 = 1,im - Q1X(i ,j) = Q(ip1,j) + Q(i,j) - Q2X(ip1,j) = Q(ip2,j) + Q(i,j) - i = ip1 - ip1 = ip2 - enddo - enddo - - do j=1,jm-1 - do i=1,im - Q1Y(i,j) = Q(i,j+1) + Q(i,j) - enddo - enddo - - do j=2,jm-1 - do i=1,im - Q2Y(i,j) = Q(i,j+1) + Q(i,j-1) - enddo - enddo - - do i=1,im/2 - Q2Y(i, 1) = Q(i,2) - Q2Y(i,jm) = Q(i,jm-1) - enddo - - do i=1,im/2 - Q2Y(i , 1) = Q(i+im/2,2) + Q2Y(i,1) - Q2Y(i+im/2, 1) = Q2Y(i,1) - Q2Y(i ,jm) = Q(i+im/2,jm-1) + Q2Y(i,jm) - Q2Y(i+im/2,jm) = Q2Y(i,jm) - enddo - -C ********************************************************* -C **** CALCULATE Q-GRADIENTS **** -C ********************************************************* - - do j = 2,jm-1 - i = im-1 - ip1 = im - do ip2 = 1,im - DQDX(ip1,j) = ACOS(j) * ( ( Q1X(ip1,j)-Q1X(i,j) )*CX1 - . - ( Q2X(ip2,j)-Q2X(i,j) )*CX2 ) - i = ip1 - ip1 = ip2 - enddo - enddo - - do j=2,jm-1 - do i=1,im - DQDY(i,j) = ( Q1Y(i,j) -Q1Y(i,j-1) )*CY1 - . - ( Q2Y(i,j+1)-Q2Y(i,j-1) )*CY2 - enddo - enddo - -C ********************************************************* -C **** CALCULATE Q-GRADIENTS (POLES) **** -C ********************************************************* - - do i=1,im/2 - Q1Y(i, 2) = Q(i, 1) + Q(i+im/2,2) - Q1Y(i+im/2, 2) = Q(i+im/2, 1) + Q(i, 2) - Q2Y(i, 1) = Q(i, 1) + Q(i+im/2,3) - Q2Y(i+im/2, 1) = Q(i+im/2, 1) + Q(i, 3) - - Q1Y(i, jm) = Q(i, jm) + Q(i+im/2,jm-1) - Q1Y(i+im/2,jm) = Q(i+im/2,jm) + Q(i, jm-1) - Q2Y(i, jm) = Q(i, jm) + Q(i+im/2,jm-2) - Q2Y(i+im/2,jm) = Q(i+im/2,jm) + Q(i, jm-2) - enddo - - do i=1,im - DQDY(i,jm) = ( Q1Y(i,jm)-Q1Y(i,jm-1) )*CY1 - . - ( Q2Y(i,jm)-Q2Y(i,jm-1) )*CY2 - - DQDY(i, 1) = ( Q1Y(i,1)-Q1Y(i,2) )*CY1 - . - ( Q2Y(i,2)-Q2Y(i,1) )*CY2 - enddo - -C APPLY BOUNDARY CONDITIONS AT THE POLES -C ========================================== - - DO 170 M=1,2 - MSGN = (-1)**M - JPOLE = 1 + (M-1)*(jm - 1) - - VC = 0.0 - VS = 0.0 - DO 180 I=1,IM - VC = VC + DQDY(I,JPOLE)*COSL(I) - VS = VS + DQDY(I,JPOLE)*SINL(I) - 180 CONTINUE - VC = 2.0 * VC / IM - VS = 2.0 * VS / IM - - UC = - MSGN*VS - US = MSGN*VC - - DO 190 I=1,IM - DQDX(I,JPOLE) = US*SINL(I) + UC*COSL(I) - DQDY(I,JPOLE) = VS*SINL(I) + VC*COSL(I) - 190 CONTINUE - - 170 CONTINUE - - RETURN - END - SUBROUTINE GRADQ (Q,DQDX,DQDY,IM,JM) -C ********************************************************* -C **** **** -C **** THIS PROGRAM CALCULATES THE HORIZONTAL **** -C **** GRADIENT OF THE INPUT FIELD Q **** -C **** **** -C **** ARGUMENTS: **** -C **** Q ....... FIELD TO BE DIFFERENTIATED **** -C **** DQDX .... LONGITUDINAL Q-DERIVATIVE **** -C **** DQDY .... MERIDIONAL Q-DERIVATIVE **** -C **** IM ...... NUMBER OF LONGITUDINAL POINTS **** -C **** JM ...... NUMBER OF LATITUDINAL POINTS **** -C **** **** -C ********************************************************* - - use MAPL_ConstantsMod - implicit none - integer im,jm - - real Q(IM,JM) - real DQDX(IM,JM) - real DQDY(IM,JM) - real acos(JM) - - real cx1,cy1 - real dl,dp,a,pi,fjeq,phi - integer i,j,ip1 - -C ********************************************************* -C **** INITIALIZATION **** -C ********************************************************* - - a = MAPL_RADIUS - pi = 4.0*atan(1.0) - dl = 2.0*pi/im - dp = pi/(jm-1) - - CX1 = 1.0 / (A*DL) - CY1 = 1.0 / (A*DP) - - fjeq = ( jm+1 )*0.5 - do j=2,jm-1 - phi = dp * (j-fjeq) - acos(j) = 1.0/( cos(phi) ) - enddo - -C ********************************************************* -C **** CALCULATE Q-GRADIENTS **** -C ********************************************************* - - do j = 2,jm-1 - i = im - do ip1 = 1,im - DQDX(i,j) = ACOS(j)*( Q(ip1,j)-Q(i,j) )*CX1 - i = ip1 - enddo - enddo - - do j=1,jm-1 - do i=1,im - DQDY(i,j) = ( Q(i,j+1)-Q(i,j) )*CY1 - enddo - enddo - - RETURN - END - SUBROUTINE LAPLACE (DIV,VELP,im,jnp) - - integer IM,JNP - real DIV(IM,JNP) - real VELP(IM,JNP) - - real*8, allocatable :: VP(:,:) - real*8, allocatable :: w(:) - real*8, allocatable :: bdtf(:) - real*8, allocatable :: bdts(:) - real*8, allocatable :: bdps(:) - real*8, allocatable :: bdpf(:) - real*8 ts,tf,ps,pf,elmbda,pertrb,pi - - imp = im+1 - iwk = 11*jnp+6*imp - - allocate ( vp(jnp,imp) ) - allocate ( w(iwk) ) - allocate ( bdtf(imp) ) - allocate ( bdts(imp) ) - allocate ( bdps(jnp) ) - allocate ( bdpf(jnp) ) - - vp(:,:)=0.0 - w(:)=0.0 - bdtf(:)=0.0 - bdts(:)=0.0 - bdps(:)=0.0 - bdpf(:)=0.0 - -c Transpose the input array -c ------------------------- - do j=1,jnp - do i=1,im - vp(j,i) = div(i,j) - enddo - vp(j,imp) = vp(j,1) - enddo - -C === SET THE INPUT VARIABLES - RAD = 6371000.0 - PI = 3.14159265358979D0 - INTL=0 - TS=0.0 - TF=PI - M=JNP-1 - MBDCND=9 - PS=0.0 - PF=2*PI - N=IM - NBDCND=0 - ELMBDA=0 - PERTRB=0 - IDIMF=M+1 - - CALL PWSSSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS, - * BDPF,ELMBDA,VP,IDIMF,PERTRB,IERROR,W) - - if( ierror.ne.0 ) then - print *, 'PWSSSP IERROR = ',ierror - stop - endif - -c Scale by earth radius -c --------------------- - do j=1,jnp - do i=1,im - VELP(I,J) = VP(J,I) * RAD * RAD - enddo - enddo - -c Remove global mean -c ------------------ - CALL ZEROG (VELP,IM,JNP) - - deallocate ( vp ) - deallocate ( w ) - deallocate ( bdtf ) - deallocate ( bdts ) - deallocate ( bdps ) - deallocate ( bdpf ) - RETURN - END - - SUBROUTINE ZEROG (VEL,IM,JNP) - integer IM,JNP - real VEL(IM,JNP) - - pi = 4.0*atan(1.0) - dl = 2*pi/im - dp = pi/(jnp-1) - cap = 1-cos(0.5*dp) - -c Ensure unique pole values -c ------------------------- - sum1 = 0.0 - sum2 = 0.0 - do i=1,im - sum1 = sum1 + vel(i,1) - sum2 = sum2 + vel(i,jnp) - enddo - sum1 = sum1/im - sum2 = sum2/im - do i=1,im - vel(i,1) = sum1 - vel(i,jnp) = sum2 - enddo - -c Compute global average -c ---------------------- - sum1 = 0.0 - sum2 = 0.0 - do i=1,im - sum1 = sum1 + cap*vel(i,1) - sum2 = sum2 + cap - enddo - - do j=2,jnp-1 - cosj = cos( -pi/2 + (j-1)*dp ) - do i=1,im - sum1 = sum1 + cosj*dp*vel(i,j) - sum2 = sum2 + cosj*dp - enddo - enddo - - do i=1,im - sum1 = sum1 + cap*vel(i,jnp) - sum2 = sum2 + cap - enddo - - qave = sum1/sum2 - - do j=1,jnp - do i=1,im - vel(i,j) = vel(i,j)-qave - enddo - enddo - -c print *, 'Remove Global Average: ', qave - - RETURN - END - - SUBROUTINE VORDIV ( UZ,VZ,VOR,DIV,IMAX,JMAX ) -C ******************************************************************** -C **** **** -C **** THIS PROGRAM CALCULATES VORTICITY AND DIVERGENCE **** -C **** AT EACH LEVEL FOR A NON-STAGGERED A-GRID **** -C **** **** -C **** INPUT: **** -C **** UZ ...... ZONAL WIND **** -C **** VZ ...... MERIDIONAL WIND **** -C **** IMAX .... NUMBER OF LONGITUDE POINTS **** -C **** JMAX .... NUMBER OF LATITUDE POINTS **** -C **** **** -C **** OUTPUT: **** -C **** VOR (IMAX,JMAX) .... VORTICITY **** -C **** DIV (IMAX,JMAX) .... DIVERGENCE **** -C **** **** -C ******************************************************************** - - real UZ(IMAX,JMAX) - real VZ(IMAX,JMAX) - real DIV(IMAX,JMAX) - real VOR(IMAX,JMAX) - - real P1X (IMAX,JMAX) - real P2X (IMAX,JMAX) - real P1Y (IMAX,JMAX) - real P2Y (IMAX,JMAX) - real TMP1(IMAX,JMAX) - real TMP2(IMAX,JMAX) - real cosij(IMAX,JMAX) - - PARAMETER ( ZERO = 0.0 ) - PARAMETER ( ONE = 1.0 ) - PARAMETER ( TWO = 2.0 ) - PARAMETER ( THREE = 3.0 ) - PARAMETER ( FOUR = 4.0 ) - PARAMETER ( TWELVE = 12.0 ) - - DIMENSION MSGN(2) - - DATA MSGN /-1,1/ - -C ********************************************************* -C **** INITIALIZATION FOR DIVERGENCE **** -C ********************************************************* - - im = imax - imm1 = im-1 - - IMR = IMAX - JMR = JMAX-1 - IMJMR = IMR*(JMR+1) - IMJMR = IMR*(JMR+1) - IMJMM1R = IMR* JMR - IMJMM2R = IMR*(JMR-1) - - A = 6.372e6 - pi = 4.*atan(1.) - dl = 2*pi/imr - dp = pi/jmr - - C11 = FOUR / (THREE *A*IM*(ONE-COS(DP)) ) - C12 = ONE / (THREE *A*IM*(ONE-COS(TWO*DP))) - CX1 = TWO / (THREE *A*DL) - CX2 = ONE / (TWELVE*A*DL) - CY1 = TWO / (THREE *A*DP) - CY2 = ONE / (TWELVE*A*DP) - - do j=1,jmax - phi = -pi/2.+(j-1)*dp - cosphi = cos(phi) - do i=1,imax - cosij(i,j) = cosphi - enddo - enddo - -C ******************************************************** -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - DO j=1,jmax - DO I=1,imax - P1X (I,j) = ZERO - P2X (I,j) = ZERO - P1Y (I,j) = ZERO - P2Y (I,j) = ZERO - TMP1(I,j) = UZ(I,j) - TMP2(I,j) = VZ(I,j)*COSIJ(I,j) - ENDDO - ENDDO - - DO j=2,jmax-1 - DO I=1,imax - P1X(I ,j) = TMP1(I+1,j) + TMP1(I,j) - P2X(I+1,j) = TMP1(I+2,j) + TMP1(I,j) - ENDDO - ENDDO - - DO J=2,JMR - P1X(IM,J) = TMP1(1,J) + TMP1(IM ,J) - P2X(IM,J) = TMP1(1,J) + TMP1(IMM1,J) - P2X( 1,J) = TMP1(2,J) + TMP1(IM ,J) - ENDDO - - DO j=1,jmax-1 - DO I=1,imax - P1Y(I, j) = TMP2(I,J+1) + TMP2(I,j) - ENDDO - ENDDO - DO j=2,jmax-1 - DO I=1,imax - P2Y(I, j) = TMP2(I,j+1) + TMP2(I,j-1) - ENDDO - ENDDO - - DO I=1,IMR - P2Y(I, 1) = ZERO - P2Y(I,jmax) = ZERO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE **** -C ********************************************************* - - DO j=2,jmax-1 - DO I=1,imax - TMP1(I+1,j) = ( P1X(I+1,j)-P1X(I,j) )*CX1 - . - ( P2X(I+2,j)-P2X(I,j) )*CX2 - ENDDO - ENDDO - DO J=2,JMR - TMP1( 1,J) = ( P1X( 1,J)-P1X(IM ,J) )*CX1 - . - ( P2X( 2,J)-P2X(IM ,J) )*CX2 - TMP1(IM,J) = ( P1X(IM,J)-P1X(IMM1,J) )*CX1 - . - ( P2X( 1,J)-P2X(IMM1,J) )*CX2 - ENDDO - - DO j=2,jmax-1 - DO I=1,imax - TMP2(I,j) = ( P1Y(I,j) -P1Y(I,j-1) )*CY1 - . - ( P2Y(I,j+1)-P2Y(I,j-1) )*CY2 - DIV (I,j) = ( TMP1(I,j)+TMP2(I,j) )/(cosij(i,j)) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL DIVERGENCE AT POLES **** -C ********************************************************* - - DO 100 M=1,2 - JPOLE = 1 + (M-1)*(jmax-1) - JPH = 1 + (M-1)*(jmax-2) - JSTAR1 = 2 + (M-1)*(jmax-3) - JSTAR2 = 3 + (M-1)*(jmax-5) - - SUM11 = ZERO - SUM12 = ZERO - DO I=1,IMR - SUM11 = SUM11 + P1Y(I,JPH ) - SUM12 = SUM12 + P2Y(I,JSTAR1) - ENDDO - - DO I=1,IMR - DIV(I,JPOLE) = - MSGN(M) * ( C11*SUM11 - C12*SUM12 ) - ENDDO - - 100 CONTINUE - -C ******************************************************** -C **** CALCULATE AVERAGE QUANTITIES **** -C ********************************************************* - - DO j=1,jmax - DO I=1,imax - P1X (I,j) = ZERO - P2X (I,j) = ZERO - P1Y (I,j) = ZERO - P2Y (I,j) = ZERO - TMP1(I,j) = VZ(I,j) - TMP2(I,j) = UZ(I,j)*COSIJ(I,j) - ENDDO - ENDDO - - DO j=2,jmax-1 - DO I=1,imax - P1X(I ,j) = TMP1(I+1,j) + TMP1(I,j) - P2X(I+1,j) = TMP1(I+2,j) + TMP1(I,j) - ENDDO - ENDDO - - DO J=2,JMR - P1X(IM,J) = TMP1(1,J) + TMP1(IM ,J) - P2X(IM,J) = TMP1(1,J) + TMP1(IMM1,J) - P2X( 1,J) = TMP1(2,J) + TMP1(IM ,J) - ENDDO - - DO j=1,jmax-1 - DO I=1,imax - P1Y(I, j) = TMP2(I,J+1) + TMP2(I,j) - ENDDO - ENDDO - DO j=2,jmax-1 - DO I=1,imax - P2Y(I, j) = TMP2(I,j+1) + TMP2(I,j-1) - ENDDO - ENDDO - - DO I=1,IMR - P2Y(I, 1) = ZERO - P2Y(I,jmax) = ZERO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL VORTICITY **** -C ********************************************************* - - DO j=2,jmax-1 - DO I=1,imax - TMP1(I+1,j) = ( P1X(I+1,j)-P1X(I,j) )*CX1 - . - ( P2X(I+2,j)-P2X(I,j) )*CX2 - ENDDO - ENDDO - DO J=2,JMR - TMP1( 1,J) = ( P1X( 1,J)-P1X(IM ,J) )*CX1 - . - ( P2X( 2,J)-P2X(IM ,J) )*CX2 - TMP1(IM,J) = ( P1X(IM,J)-P1X(IMM1,J) )*CX1 - . - ( P2X( 1,J)-P2X(IMM1,J) )*CX2 - ENDDO - - DO j=2,jmax-1 - DO I=1,imax - TMP2(I,j) = ( P1Y(I,j) -P1Y(I,j-1) )*CY1 - . - ( P2Y(I,j+1)-P2Y(I,j-1) )*CY2 - VOR (I,j) = ( TMP1(I,j)-TMP2(I,j) )/(cosij(i,j)) - ENDDO - ENDDO - -C ********************************************************* -C **** CALCULATE HORIZONTAL VORTICITY AT POLES **** -C ********************************************************* - - DO 200 M=1,2 - JPOLE = 1 + (M-1)*(jmax-1) - JPH = 1 + (M-1)*(jmax-2) - JSTAR1 = 2 + (M-1)*(jmax-3) - JSTAR2 = 3 + (M-1)*(jmax-5) - - SUM11 = ZERO - SUM12 = ZERO - DO I=1,IMR - SUM11 = SUM11 + P1Y(I,JPH ) - SUM12 = SUM12 + P2Y(I,JSTAR1) - ENDDO - - DO I=1,IMR - VOR(I,JPOLE) = MSGN(M) * ( C11*SUM11 - C12*SUM12 ) - ENDDO - - 200 CONTINUE - RETURN - END - - subroutine sigtopl ( qprs,q,logpl,logps,logpt,logp,im,jm,lm,undef ) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** -C - implicit none - integer i,j,l,im,jm,lm - - real*8 qprs(im,jm) - real*8 q (im,jm,lm) - real*8 logpl(im,jm,lm) - real*8 logps(im,jm) - real*8 logpt(im,jm) - - real*8 undef - real*8 logp,temp - -c Initialize to UNDEFINED -c ----------------------- - do i=1,im*jm - qprs(i,1) = undef - enddo - -c Interpolate to Pressure Between Model Levels -c -------------------------------------------- - do L=1,lm-1 - if( all( logpl(:,:,L )>logp ) ) exit - if( all( logpl(:,:,L+1) collections(nc)%fields_2d - fields_3d => collections(nc)%fields_3d - - if( trim(expid).ne."" ) then - if( trim(collections(nc)%name).ne.'default' ) then - tag = trim(expid) // "." // trim(collections(nc)%name) // "." - else - tag = trim(expid) // "." - endif - else - if( trim(collections(nc)%name).ne.'default' ) then - tag = trim(collections(nc)%name) // "." - else - tag = "" - endif - endif - - undef = 1.0e15 - nymdb = dates(1,1) - nhmsb = dates(2,1) - do n=1,ndates - if( dates(1,n).lt.nymdb ) nymdb = dates(1,n) - if( dates(1,n).eq.nymdb .and. dates(2,n).lt.nhmsb ) nhmsb = dates(2,n) - enddo - nymde = nymdb - nhmse = nhmsb - call tick (nymde,nhmse,fhour*3600) - - ndt0 = nsecf(timinc) - if( nfreq.eq.-999 ) then - ndt = nsecf(timinc) - else - ndt = nsecf(nfreq) - endif - - nymd = nymdb - nhms = nhmsb - - write(bdate,3001) nymdb - write(xdate,3003) nhmsb - statfile = trim(tag) // 'globl.' // bdate // "." // xdate // ".data" - open (51,file=trim(statfile),form='unformatted',access='sequential') - - print * - print *, ' Begdate: ',nymdb,' ',nhmsb - print *, ' Enddate: ',nymde,' ',nhmse - print *, 'Forecast Frequency: ',ndt/3600,' (hrs)' - print * - -! ********************************************************************** -! **** Define variables and descriptions **** -! ********************************************************************** - - allocate( corr(nr,nl,n2d+n3d,100) ) ! Note: Hardwired for 100 time periods (Max) - allocate( rms(nr,nl,n2d+n3d,100,5) ) ! Note: Hardwired for 100 time periods (Max) - - allocate( qname(6*(n2d+n3d)) ) - allocate( qdesc(6*(n2d+n3d)) ) - - do n=1,6 - if(n.eq.1) then - do k=1,n2d - qname(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%name) // 'cor ' - qdesc(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%desc) // ' Anomaly Correlation' - enddo - do k=1,n3d - qname(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%name) // 'cor ' - qdesc(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%desc) // ' Anomaly Correlation' - enddo - endif - - if(n.eq.2) then - do k=1,n2d - qname(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%name) // 'rms ' - qdesc(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%desc) // ' Root Mean Square Error' - enddo - do k=1,n3d - qname(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%name) // 'rms ' - qdesc(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%desc) // ' Root Mean Square Error' - enddo - endif - - if(n.eq.3) then - do k=1,n2d - qname(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%name) // 'rms_ran' - qdesc(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%desc) // ' Root Mean Square Error Random' - enddo - do k=1,n3d - qname(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%name) // 'rms_ran' - qdesc(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%desc) // ' Root Mean Square Error Random' - enddo - endif - - if(n.eq.4) then - do k=1,n2d - qname(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%name) // 'rms_bar' - qdesc(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%desc) // ' Root Mean Square Error Bias' - enddo - do k=1,n3d - qname(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%name) // 'rms_bar' - qdesc(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%desc) // ' Root Mean Square Error Bias' - enddo - endif - - if(n.eq.5) then - do k=1,n2d - qname(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%name) // 'rms_dis' - qdesc(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%desc) // ' Root Mean Square Error Dissipation' - enddo - do k=1,n3d - qname(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%name) // 'rms_dis' - qdesc(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%desc) // ' Root Mean Square Error Dissipation' - enddo - endif - - if(n.eq.6) then - do k=1,n2d - qname(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%name) // 'rms_dsp' - qdesc(k +(n-1)*(n2d+n3d)) = trim(fields_2d(k)%desc) // ' Root Mean Square Error Dispersion' - enddo - do k=1,n3d - qname(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%name) // 'rms_dsp' - qdesc(k+n2d+(n-1)*(n2d+n3d)) = trim(fields_3d(k)%desc) // ' Root Mean Square Error Dispersion' - enddo - endif - enddo - -! ---------------------------------- - - if( n2d.ne.0 .or. n3d.ne.0 ) then - print *, 'COLLECTION: ',trim(collections(nc)%name) - print * - endif - if( n2d.ne.0 ) then - do n=1,n2d - print *, 'FIELDS_2D: ',trim(fields_2d(n)%name) - print *, ' DESC: ',trim(fields_2d(n)%desc) - do k=1,size(fields_2d(n)%alias) - print *, ' ALIASES: ',trim(fields_2d(n)%alias(k)) - enddo - print * - enddo - endif - if( n3d.ne.0 ) then - do n=1,n3d - print *, 'FIELDS_3D: ',trim(fields_3d(n)%name) - print *, ' DESC: ',trim(fields_3d(n)%desc) - do k=1,size(fields_3d(n)%alias) - print *, ' ALIASES: ',trim(fields_3d(n)%alias(k)) - enddo - print * - enddo - endif - print * - -! ********************************************************************** - - pi = 4.0*atan(1.0) - dl = 2*pi/im - dp = pi/(jm-1) - -!for land-only option -!-------------------- - if ( landonly ) then - allocate ( landmask (im,jm ) ) - print *, ' landmask filename: ', trim(lndfname) - call load_landmask ( lndfname,landmask,im,jm,undef ) - endif - -! Loop over Forecast Times -! ------------------------ - nt = 0 - do while( (nymd.lt.nymde) .or. & - (nymd.eq.nymde .and. nhms.le.nhmse) ) - - nt = nt + 1 - if( nt.eq.1 ) then - hour = 0 - else - call interp_time ( nymdb,nhmsb, nymd,nhms, nt, num ) - hour = num*(nt-1) - endif - printout = .false. - -! Read Forecast -! ------------- - call timebeg ('__read_fcst') - call read_fcst( fname,num_fcst_files,dates,ndates,nymd,nhms,fields_2d,fields_3d,n2d,n3d,im,jm,nl,zlev,fundef ) - call timeend ('__read_fcst') - - nhms = 10000*(nhms/10000) ! Kludge to strip off minutes/seconds from Model Time - -! Find Analysis and Climatology for Forecast Time: nymd,nhms -! ---------------------------------------------------------- - call timebeg ('__read_anal') - call read_anal ( nymd,nhms,fields_2d,fields_3d,n2d,n3d,im,jm,nl,zlev,aname,num_ana_files,aundef ) - call timeend ('__read_anal') - - call timebeg ('__read_clim') - call read_clim_hdf ( nymd,nhms,fields_2d,fields_3d,n2d,n3d,im,jm,nl,zlev,cname,num_clm_files,cundef ) - call timeend ('__read_clim') - -! Read Systematic Error File and Modify Forecast Fields -! ----------------------------------------------------- - if( syserr ) then - call timebeg ('__read_serr') - call read_syserr( fields_2d,fields_3d,n2d,n3d,im,jm,nl,zlev,ename,ndt,eundef ) - call timeend ('__read_serr') - - do n=1,n2d - ! print *, '2D n: ',n - ! call minmax (fields_2d(n)%serr(1,1,1),im,jm,eundef) - do j=1,jm - do i=1,im - if( defined( fields_2d(n)%fcst(i,j,1),fundef ) .and. & - defined( fields_2d(n)%serr(i,j,1),eundef ) ) & - fields_2d(n)%fcst(i,j,1) = fields_2d(n)%fcst(i,j,1) - fields_2d(n)%serr(i,j,1) - enddo - enddo - enddo - - do n=1,n3d - do L=1,nl - ! print *, '3D n: ',n,' L: ',L - ! call minmax (fields_3d(n)%serr(1,1,L),im,jm,eundef) - do j=1,jm - do i=1,im - if( defined( fields_3d(n)%fcst(i,j,L),fundef ) .and. & - defined( fields_3d(n)%serr(i,j,L),eundef ) ) & - fields_3d(n)%fcst(i,j,L) = fields_3d(n)%fcst(i,j,L) - fields_3d(n)%serr(i,j,L) - enddo - enddo - enddo - enddo - endif - -! Write Global Data -! ----------------- - do n=1,n2d - call writit ( fields_2d(n)%fcst,im,jm,1 ,fundef,undef ) - enddo - do n=1,n3d - call writit ( fields_3d(n)%fcst,im,jm,nl,fundef,undef ) - enddo - - do n=1,n2d - call writit ( fields_2d(n)%anal,im,jm,1 ,aundef,undef ) - enddo - do n=1,n3d - call writit ( fields_3d(n)%anal,im,jm,nl,aundef,undef ) - enddo - - do n=1,n2d - call writit ( fields_2d(n)%clim,im,jm,1 ,cundef,undef ) - enddo - do n=1,n3d - call writit ( fields_3d(n)%clim,im,jm,nl,cundef,undef ) - enddo - -!for land-only option -!-------------------- - if (landonly) then - do n=1,n2d - call landmk ( fields_2d(n)%fcst,im,jm,1 ,landmask,undef ) - enddo - do n=1,n3d - call landmk ( fields_3d(n)%fcst,im,jm,nl,landmask,undef ) - enddo - endif - -! Loop over Geographical Regions -! ------------------------------ - call timebeg ('__stats') - do 1000 iregion = 1,nr - lat1 = zlat1(iregion) - lat2 = zlat2(iregion) - lon1 = zlon1(iregion) - lon2 = zlon2(iregion) - -! Determine beginning and ending i&j for Region -! --------------------------------------------- - call bounds (lat1,lat2,lon1,lon2, & - jbeg,jend,ibeg,iend,im,jm) - - -! Loop over Fields and Levels -! --------------------------- - do 2000 nfield = 1,n2d+n3d - - if( nfield.le.n2d ) then - n = nfield - nlev = 1 - name = fields_2d(n)%name - else - n = nfield-n2d - nlev = nl - name = fields_3d(n)%name - endif - - do 3000 lev = 1,nlev - - if( nfield.le.n2d ) then - c(:,:) = fields_2d(n)%clim(:,:,1) - f(:,:) = fields_2d(n)%fcst(:,:,1) - a(:,:) = fields_2d(n)%anal(:,:,1) - else - c(:,:) = fields_3d(n)%clim(:,:,lev) - f(:,:) = fields_3d(n)%fcst(:,:,lev) - a(:,:) = fields_3d(n)%anal(:,:,lev) - endif - -! Compute Regional Area Means -! --------------------------- - fmean = 0 - amean = 0 - cmean = 0 - area = 0 - do j=jbeg,jend - phi = -pi/2 + (j-1)*dp - cosp = cos(phi) - do i=ibeg,iend - if( defined(f(i,j),fundef) .and. & - defined(a(i,j),aundef) .and. & - defined(c(i,j),cundef) ) then - fmean = fmean + f(i,j)*cosp - amean = amean + a(i,j)*cosp - cmean = cmean + c(i,j)*cosp - area = area + cosp - endif - enddo - enddo - if( area.ne.0.0 ) then - fmean = fmean / area - amean = amean / area - cmean = cmean / area - else - fmean = fundef - amean = aundef - cmean = cundef - endif - - -! Define Deviations from Area Means -! --------------------------------- - do j=jbeg,jend - do i=ibeg,iend - if( defined(f(i,j),fundef) .and. & - defined(a(i,j),aundef) .and. & - defined(c(i,j),cundef) ) then - fstar(i,j) = f(i,j)-fmean - astar(i,j) = a(i,j)-amean - cstar(i,j) = c(i,j)-cmean - else - fstar(i,j) = fundef - astar(i,j) = aundef - cstar(i,j) = cundef - endif - enddo - enddo - - -! Subtract Climatology Deviations and Compute Variances -! ----------------------------------------------------- - do j=jbeg,jend - do i=ibeg,iend - if( defined(fstar(i,j),fundef) .and. & - defined(astar(i,j),aundef) .and. & - defined(cstar(i,j),cundef) ) then - fsprime(i,j) = fstar(i,j)- cstar(i,j) - asprime(i,j) = astar(i,j)- cstar(i,j) - fvar(i,j) = fsprime(i,j)*fsprime(i,j) - avar(i,j) = asprime(i,j)*asprime(i,j) - cvar(i,j) = fsprime(i,j)*asprime(i,j) - varf(i,j) = fstar(i,j)* fstar(i,j) - vara(i,j) = astar(i,j)* astar(i,j) - varc(i,j) = fstar(i,j)* astar(i,j) - else - fsprime(i,j) = fundef - asprime(i,j) = aundef - fvar(i,j) = fundef - avar(i,j) = aundef - cvar(i,j) = cundef - varf(i,j) = fundef - vara(i,j) = aundef - varc(i,j) = cundef - endif - enddo - enddo - - -! Compute Regional Mean Variances and Anomaly Correlation -! ------------------------------------------------------- - c1 = 0 - c2 = 0 - c3 = 0 - d1 = 0 - d2 = 0 - d3 = 0 - r1 = 0 - r2 = 0 - r3 = 0 - area = 0 - do j=jbeg,jend - phi = -pi/2 + (j-1)*dp - cosp = cos(phi) - do i=ibeg,iend - if( defined( f(i,j),fundef) .and. & - defined( a(i,j),aundef) .and. & - defined(fvar(i,j),fundef) .and. & - defined(avar(i,j),aundef) .and. & - defined(cvar(i,j),cundef) ) then - c1 = c1 + cvar(i,j) * cosp - c2 = c2 + fvar(i,j) * cosp - c3 = c3 + avar(i,j) * cosp - d1 = d1 + varc(i,j) * cosp - d2 = d2 + varf(i,j) * cosp - d3 = d3 + vara(i,j) * cosp - r1 = r1 + ( f(i,j)- a(i,j))**2 * cosp - r2 = r2 + (fstar(i,j)-astar(i,j))**2 * cosp - r3 = r3 + (fmean -amean )**2 * cosp - area = area + cosp - endif - enddo - enddo - if( area.ne.0 ) then - c1 = c1 / area - c2 = c2 / area - c3 = c3 / area - d1 = d1 / area - d2 = d2 / area - d3 = d3 / area - r1 = r1 / area - r2 = r2 / area - r3 = r3 / area - else - c1 = undef - c2 = undef - c3 = undef - d1 = undef - d2 = undef - d3 = undef - r1 = undef - r2 = undef - r3 = undef - endif - - if( c1.ne.undef ) then - if( c1.eq.0.0 .and. c2*c3.eq.0.0 ) then - corr(iregion,lev,nfield,nt) = 1.0 - else - corr(iregion,lev,nfield,nt) = c1/(sqrt(c2)*sqrt(c3)) - endif - rms(iregion,lev,nfield,nt,1) = sqrt(r1) - rms(iregion,lev,nfield,nt,2) = sqrt(r2) - rms(iregion,lev,nfield,nt,3) = sqrt(r3) - - if( d1.eq.0.0 .and. d2*d3.eq.0.0 ) then - rho = 1.0 - else - rho = d1/(sqrt(d2)*sqrt(d3)) - endif - rms(iregion,lev,nfield,nt,4) = (sqrt(d2)-sqrt(d3))**2 + (fmean-amean)**2 - rms(iregion,lev,nfield,nt,5) = 2*(1-rho)*sqrt(d2)*sqrt(d3) - else - corr(iregion,lev,nfield,nt) = undef - rms(iregion,lev,nfield,nt,1) = undef - rms(iregion,lev,nfield,nt,2) = undef - rms(iregion,lev,nfield,nt,3) = undef - rms(iregion,lev,nfield,nt,4) = undef - rms(iregion,lev,nfield,nt,5) = undef - endif - - if( n3d.gt.0 .and. nfield.gt.n2d ) then - if( trim(fields_3d(n)%name).eq.'h' .and. iregion.eq.2 .and. zlev(lev).eq.pref ) then - write(6,1003) int(pref),nymd,nhms,hour,corr(iregion,lev,nfield,nt),fmean,amean,cmean - printout = .true. - endif - endif - - ! if requested, write out stats info for GMAOpy - ! --------------------------------------------- - if (gmaopy) then - do iii=0,5 - if (iii==0) then - cstnm = 'cor' - write( cstat,*) corr(iregion,lev,nfield,nt) - endif - if (iii==1) then - cstnm = 'rms' - write( cstat,*) rms (iregion,lev,nfield,nt,iii) - endif - if (iii==2) then - cstnm = 'rms_ran' - write( cstat,*) rms (iregion,lev,nfield,nt,iii) - endif - if (iii==3) then - cstnm = 'rms_bar' - write( cstat,*) rms (iregion,lev,nfield,nt,iii) - endif - if (iii==4) then - cstnm = 'rms_dis' - write( cstat,*) rms (iregion,lev,nfield,nt,iii) - endif - if (iii==5) then - cstnm = 'rms_dsp' - write( cstat,*) rms (iregion,lev,nfield,nt,iii) - endif - write( cdate,'(i8.8,i2.2)') nymdb, nhmsb/10000 - write( czlev,*) zlev(lev) - write( cstep,*) hour - write( ceast,*) zlon2(iregion) - write( cwest,*) zlon1(iregion) - write(cnorth,*) zlat2(iregion) - write(csouth,*) zlat1(iregion) - write(record,'(f3.1,34a)') 0.0, '|', & ! count (dummy for this code) - trim(adjustl(cdate)),'|', & ! date - trim(adjustl(region(iregion))),'|', & ! domain_name - trim(adjustl(ceast)),'|', & ! east - trim(adjustl(expid)),'|', & ! expver - trim(adjustl(fcsource)),'|', & ! forecast - trim(adjustl(czlev)),'|', & ! level - 'pl','|', & ! levtype - trim(adjustl(cnorth)),'|', & ! north - trim(adjustl(name)),'|', & ! variable - trim(adjustl(fcsource)),'|', & ! source=forecast - trim(adjustl(csouth)),'|', & ! south - trim(adjustl(cstnm)),'|', & ! statistic - trim(adjustl(cstep)),'|', & ! step - 'fc','|', & ! type - trim(adjustl(cstat)),'|', & ! value - trim(adjustl(averify)),'|', & ! verify - trim(adjustl(cwest)) ! west - write(luout,'(a)') trim(adjustl(record)) - enddo ! loop over all available stats (this is wired-in) - endif - - 3000 continue ! end level loop - 2000 continue ! end field loop - 1000 continue ! end region loop - call timeend ('__stats') - - if( .not.printout ) write(6,1004) nymd,nhms,hour - - call tick (nymd,nhms,ndt) - if( hour.eq.fhour ) exit - enddo ! end loop for all forecast files - print * - -! Write out correlation and rms data -! ---------------------------------- - year = nymdb/10000 - month = mod(nymdb,10000)/100 - day = mod(nymdb,100) - hour = nhmsb/10000 - minute = mod(nhmsb,10000)/100 - - write(bdate,3001) nymdb - write(bhour,3004) nhmsb/10000 - write(edate,3002) nymde - write(ehour,3004) nhmse/10000 - 3001 format('b',i8.8) - 3002 format('e',i8.8) - 3003 format('x',i6.6) - 3004 format('_',i2.2,'z') - - close(51) - datafile = trim(tag) // 'globl.' // bdate // bhour // "." // edate // ehour // ".data" - call execute_command_line ("/bin/mv " // trim(statfile) // " " // trim(datafile) ) - - statfile = trim(tag) // 'stats.' // bdate // bhour // "." // edate // ehour // ".data" - open (85,file=trim(statfile),form='unformatted',access='sequential') - - ctlfile1 = trim(tag) // 'stats.' // bdate // bhour // "." // edate // ehour // ".ctl1" - open (86,file=trim(ctlfile1),form='formatted' ,access='sequential') - - ctlfile2 = trim(tag) // 'stats.' // bdate // bhour // "." // edate // ehour // ".ctl2" - open (87,file=trim(ctlfile2),form='formatted' ,access='sequential') - - ctlfile3 = trim(tag) // 'globl.' // bdate // bhour // "." // edate // ehour // ".ctl" - open (88,file=trim(ctlfile3),form='formatted' ,access='sequential') - -! ----------------------------------------------- - - do ntime =1,nt - - do nfield=1,n2d+n3d - if( nfield.le.n2d ) then - nlev = 1 - else - nlev = nl - endif - - do level=1,nlev - do i=1,nr - dum(i) = corr(i,level,nfield,ntime) - enddo - write(85) dum - enddo - enddo - - do m=1,5 - do nfield=1,n2d+n3d - if( nfield.le.n2d ) then - nlev = 1 - else - nlev = nl - endif - do level=1,nlev - do i=1,nr - dum(i) = rms(i,level,nfield,ntime,m) - enddo - write(85) dum - enddo - enddo - enddo - - enddo - -! Write out correlation tabl ctl1 (uniform times) -! ----------------------------------------------- - call interp_time ( nymdb,nhmsb, nymde,nhmse, nt, num ) - - write(86,5001) trim(statfile) - write(86,5002) - write(86,5003) undef - write(86,5004) nr - write(86,5005) - write(86,5006) nl,(zlev(k),k=1,nl) - write(86,5007) nt, months(month),year, num - write(86,5008) 6*(n2d+n3d) ! Note: 6 Types of Statistical Output per Field (cor, rms, rms_bar, rms_ran, rms_dis, rms_dsp) - do k=1,6 - do n=1,n2d+n3d - m=n+(k-1)*(n2d+n3d) - if( n.le.n2d ) then - lmax = 0 - else - lmax = nl - endif - write(86,5009) trim(qname(m)),lmax,trim(qdesc(m)) - enddo - enddo - write(86,5010) - -! Write out correlation tabl ctl2 (actual times) -! ---------------------------------------------- - write(87,5001) trim(statfile) - write(87,5002) - write(87,5003) undef - write(87,5004) nr - write(87,5005) - write(87,5006) nl,(zlev(k),k=1,nl) - write(87,6007) nt,hour,minute,day,months(month),year, num - write(87,5008) 6*(n2d+n3d) ! Note: 6 Types of Statistical Output per Field (cor, rms, rms_bar, rms_ran, rms_dis, rms_dsp) - do k=1,6 - do n=1,n2d+n3d - m=n+(k-1)*(n2d+n3d) - if( n.le.n2d ) then - lmax = 0 - else - lmax = nl - endif - write(87,5009) trim(qname(m)),lmax,trim(qdesc(m)) - enddo - enddo - write(87,5010) - -! Write out global data tabl ctl3 (actual times) -! ---------------------------------------------- - write(88,5001) trim(datafile) - write(88,5002) - write(88,5003) undef - write(88,8004) im, 360.0/float(im) - write(88,8005) jm, 180.0/float(jm-1) - write(88,5006) nl,(zlev(k),k=1,nl) - write(88,6007) nt,hour,minute,day,months(month),year, num - write(88,5008) 3*(n2d+n3d) ! Note: 3 Sets of Fields (forecast, analysis, climatology) - do m=1,3 - if( m.eq.1 ) suffix = 'f' - if( m.eq.2 ) suffix = 'a' - if( m.eq.3 ) suffix = 'c' - do n=1,n2d+n3d - if( n.le.n2d ) then - lmax = 0 - name = trim(fields_2d(n)%name) // trim(suffix) - dummy = trim(fields_2d(n)%desc) - else - lmax = nl - name = trim(fields_3d(n-n2d)%name) // trim(suffix) - dummy = trim(fields_3d(n-n2d)%desc) - endif - write(88,5009)trim(name),lmax,trim(dummy) - enddo - enddo - write(88,5010) - - 5001 format('DSET ^',a) - 5002 format('TITLE Stats',/,'FORMAT sequential big_endian') - 5003 format('UNDEF ',g12.6) - 5004 format('XDEF ',i3,' LINEAR 1 1') - 8004 format('XDEF ',i3,' LINEAR -180 ',f8.5) - 5005 format('YDEF 1 LINEAR 1 1') - 8005 format('YDEF ',i3,' LINEAR -90 ',f8.5) - 5006 format('ZDEF ',i3,' LEVELS ',5(f7.2,1x),/, & - 50(18x, 5(f7.2,1x),/) ) - 5007 format('TDEF ',i3,' LINEAR ', '00:00', 'Z01' ,a3,i4,' ',i2.2,'hr') - 6007 format('TDEF ',i3,' LINEAR ',i2.2,':',i2.2,'Z',i2.2,a3,i4,' ',i2.2,'hr') - 5008 format('VARS ',i3) - 5009 format(a,2x,i3,' 0 ',a) - 5010 format('ENDVARS') - - 1003 format(1x,i4,'-mb NH Height at ',i8,2x,i6.6,' (',i3,' hrs) corr: ',f9.7, & - 3x,'fcst: ',f7.2,2x,'ana: ',f7.2,2x,'cli: ',f7.2,' (m)') - 1004 format(1x,'Date: ',i8,2x,i6.6,' (',i3,' hrs)') - -! ********************************************************************** -! **** End Collection Loop **** -! ********************************************************************** - - deallocate( corr ) - deallocate( rms ) - deallocate( qname ) - deallocate( qdesc ) - - close(85) - close(86) - close(87) - close(88) - - enddo - - call timeend ('_colls') - - if (gmaopy) close(luout) - -! Write Timing Information -! ------------------------ - call timeend ('main') - call timepri (6) - - call ESMF_Finalize() - end - - SUBROUTINE BOUNDS (LAT1,LAT2,LONG1,LONG2, & - JBEG,JEND,IBEG,IEND,IM,JM) - real lat1,lat2,long1,long2 - IMP1 = IM+1 - PI = 180. - DL = 2.*PI/IM - DP = PI/(JM-1) - jbeg = int((lat1 + 90.)/dp)+1 - jend = int((lat2 + 90.)/dp)+1 - IF( JBEG.GT.JM) JBEG = JM - IF( (JEND-1)*DP-90.LT.LAT2) JEND= JEND+1 - - IF( JEND.GT.JM) JEND = JM - - ibeg = int((long1+180.)/dl)+1 - iend = int((long2+180.)/dl)+1 - IF( IBEG.GT.IM) IBEG = IM - IF((IEND-1)*DL-180.LT.LONG2) IEND=IEND+1 - IF( IEND.GT.IM) IEND = IM - -! write(6,100) lat1 ,jbeg, lat2,jend, & -! long1,ibeg,long2,iend - 100 format(/1x,f6.1,' (',i3,')',2x,f6.1,' (',i3,')',/, & - 1x,f6.1,' (',i3,')',2x,f6.1,' (',i3,')',/) - return - end - - subroutine read_clim_hdf ( nymd,nhms,fields_2d,fields_3d,n2d,n3d,idim,jdim,nl,zlev,cli_files,num,undef ) - use stats_mod - use ESMF - implicit none - integer n2d,n3d - type(fields) :: fields_2d(n2d) - type(fields) :: fields_3d(n3d) - - integer num - integer nymd,nhms - integer idim,jdim,nl - real zlev(nl) - - real, allocatable :: var2d_1( :,:,: ) - real, allocatable :: var3d_1( :,:,:,: ) - - real, allocatable :: var2d_2( :,:,: ) - real, allocatable :: var3d_2( :,:,:,: ) - - integer nid,ncl,im,jm,lm,nvars,rc - integer ntime,ngatts,timinc - real undef - integer L,m,n - character*256 cli_files(num) - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - real, allocatable :: q(:,:) - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: kmvar(:) - - integer, allocatable :: id(:) - integer, allocatable :: yymmdd(:,:) - integer, allocatable :: hhmmss(:,:) - - logical check_names - logical first, shift, defined - integer LL, i,j,k,kk, loc, len - data shift /.false./ - data first /.true./ - save - - integer ISCM, ISCP, ISC - real FACM, FACP - integer MIDMON - integer IMNP, IMNM - integer IMONP, IMONM - DATA IMONP/0/, IMONM/0/ - - INTEGER MONTH, DAY, SEC - INTEGER DAYS(12) - DATA DAYS /31,28,31,30,31,30,31,31,30,31,30,31/ - - INTEGER NSECF, NMONF, NDAYF - -!********************************************************************* -!**** Find Proper Month Boundaries from INPUT Date and Time **** -!********************************************************************* - - SEC = NSECF(NHMS) - MONTH = NMONF(NYMD) - DAY = NDAYF(NYMD) - - MIDMON = DAYS(MONTH)/2 + 1 - - IF(DAY.LT.MIDMON) THEN - imnm = month - 1 - imnp = month - ELSE - IMNM = MONTH - IMNP = MONTH + 1 - ENDIF - - if( imnm.eq.0 ) imnm = 12 - if( imnp.eq.13 ) imnp = 1 - -!********************************************************************* -!**** Open Climatology DataSet and Initialization **** -!********************************************************************* - - if( first ) then - allocate ( yymmdd(12,num) ) - allocate ( hhmmss(12,num) ) - allocate ( id(num) ) - - do n=1,num - call gfio_open ( cli_files(n),1,id(n),rc ) - if( rc.ne.0 ) then - print *, 'Climatology File: ',trim(cli_files(n)),' NOT found!' - call ESMF_Finalize() - stop - endif - call gfio_diminquire ( id(n),im,jm,lm,ntime,nvars,ngatts,rc ) - - if( ntime.ne.12 ) then - print *, 'Climatology data should consist of 12 monthly means' - print *, 'Current file: ',trim(cli_files(n)),' contains ',ntime,' time periods!' - call ESMF_Finalize() - stop - endif - - if( first ) then - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - endif - - call gfio_inquire ( id(n),im,jm,lm,ntime,nvars, & - title,source,contact,undef, & - lon,lat,lev,levunits, & - yymmdd(1,n),hhmmss(1,n),timinc, & - vname,vtitle,vunits,kmvar, & - vrange,prange,rc ) - first = .false. - enddo - - if( lon(1).eq.0.0 ) then - ! print *, 'Climatology data begins at lon: ',lon(1) - ! print *, 'Horizontal Shift will be performed' - ! print * - shift = .true. - endif - - allocate ( var2d_1(idim,jdim, n2d), var2d_2(idim,jdim, n2d) ) - allocate ( var3d_1(idim,jdim,nl,n3d), var3d_2(idim,jdim,nl,n3d) ) - endif - - if( size(var2d_1,3).ne.n2d ) then - deallocate( var2d_1,var2d_2 ) - allocate( var2d_1(idim,jdim, n2d), var2d_2(idim,jdim, n2d) ) - endif - if( size(var3d_1,4).ne.n3d ) then - deallocate( var3d_1,var3d_2 ) - allocate( var3d_1(idim,jdim,nl,n3d), var3d_2(idim,jdim,nl,n3d) ) - endif - -! Initial Forecast Fields to ZERO -! ------------------------------- - do n=1,n2d - fields_2d(n)%clim = 0.0 - enddo - do n=1,n3d - fields_3d(n)%clim = 0.0 - enddo - -! Determine Climatology TOD Dataset -! --------------------------------- - if( num.eq.1 ) then - nid = id(num) - ncl = num - else - nid = -999 - do n=1,num - if( nhms.eq.hhmmss(1,n) ) then - nid = id(n) - ncl = n - endif - enddo - if( nid.eq.-999 ) then - print *, 'Climatology Datasets do not have desired TOD: ',nhms - call ESMF_Finalize() - stop - endif - endif - -!********************************************************************* -!**** Read for (-) Month and (+) Month **** -!********************************************************************* - - IMONM = IMNM - IMONP = IMNP - - allocate ( q(im,jm) ) - - do k=1,ntime - MONTH = NMONF(yymmdd(k,ncl)) - - if( month.eq.imnm .or. month.eq.imnp ) then - do n=1,nvars - - do m=1,n2d - len = size( fields_2d(m)%alias ) - do kk = 1,len - if( check_names( vname(n),fields_2d(m)%alias(kk) ) ) then - call gfio_getvar ( nid,vname(n),yymmdd(k,ncl),hhmmss(k,ncl),im,jm,0,1,q,rc ) - if( shift ) call hshift ( q,im,jm ) - if( check_names( fields_2d(m)%name,'p' ) ) then - do j=1,jm - do i=1,im - if( defined(q(i,j),undef) .and. q(i,j).gt.10000.0 ) then - q(i,j) = q(i,j)*0.01 ! Convert Pa=>mb - endif - enddo - enddo - endif - if( check_names( fields_2d(m)%type,'aerosol' ) ) then - do j=1,jm - do i=1,im - if( defined(q(i,j),undef) ) q(i,j) = log( q(i,j)+0.01 ) - enddo - enddo - endif - call bin ( q,im,jm,fields_2d(m)%clim,idim,jdim,undef,fields_2d(m)%msgn ) - endif - enddo - enddo - - - do L=1,nl - loc = -1 - do LL=1,lm - if( lev(LL).eq.zlev(L) ) loc = LL - enddo - - do m=1,n3d - len = size( fields_3d(m)%alias ) - do kk = 1,len - if( check_names( vname(n),fields_3d(m)%alias(kk) ) ) then - if( loc.ne.-1 ) then - call gfio_getvar ( nid,vname(n),yymmdd(k,ncl),hhmmss(k,ncl),im,jm,loc,1,q,rc ) - else - q = undef - endif - if( shift ) call hshift ( q,im,jm ) - call bin ( q,im,jm,fields_3d(m)%clim(1,1,L),idim,jdim,undef,fields_3d(m)%msgn ) - - endif - enddo - enddo - - enddo - - enddo - - if( month.eq.imnm ) then - do kk=1,n2d - var2d_1(:,:,kk) = fields_2d(kk)%clim(:,:,1) - enddo - do kk=1,n3d - var3d_1(:,:,:,kk) = fields_3d(kk)%clim(:,:,:) - enddo - endif - if( month.eq.imnp ) then - do kk=1,n2d - var2d_2(:,:,kk) = fields_2d(kk)%clim(:,:,1) - enddo - do kk=1,n3d - var3d_2(:,:,:,kk) = fields_3d(kk)%clim(:,:,:) - enddo - endif - endif - enddo - - deallocate ( q ) - -!********************************************************************* -!**** INTERPOLATE DATA TO CURRENT TIME **** -!********************************************************************* - - IF(DAY.LT.MIDMON) THEN - ISC = (DAY+DAYS(IMONM))*86400 + SEC - ELSE - ISC = (DAY )*86400 + SEC - ENDIF - - ISCM = (DAYS(IMONM)/2+1 )*86400 - ISCP = (DAYS(IMONP)/2+1 + DAYS(IMONM) )*86400 - - FACP = (ISC-ISCM) / REAL(ISCP-ISCM) - FACM = 1-FACP - -! write(6,100) imonm,facm,imonp,facp -!100 format(1x,'Interpolating Climatology for Month ',i2, -! . ' (',f5.3,') and Month ',i2,' (',f5.3,')') - - do n=1,n2d - do J=1,JDIM - do I=1,IDIM - if( var2d_1(i,j,n).ne.undef .and. var2d_2(i,j,n).ne.undef ) then - fields_2d(n)%clim(I,J,1) = var2d_1(I,J,n)*FACM + var2d_2(I,J,n)*FACP - else - if( var2d_1(i,j,n).ne.undef ) then - fields_2d(n)%clim(I,J,1) = var2d_1(I,J,n) - else - if( var2d_2(i,j,n).ne.undef ) then - fields_2d(n)%clim(I,J,1) = var2d_2(I,J,n) - else - fields_2d(n)%clim(I,J,1) = undef - endif - endif - endif - enddo - enddo - enddo - - do n=1,n3d - do L=1,NL - do J=1,JDIM - do I=1,IDIM - if( var3d_1(i,j,L,n).ne.undef .and. var3d_2(i,j,L,n).ne.undef ) then - fields_3d(n)%clim(I,J,L) = var3d_1(I,J,L,n)*FACM + var3d_2(I,J,L,n)*FACP - else - if( var3d_1(i,j,L,n).ne.undef ) then - fields_3d(n)%clim(I,J,L) = var3d_1(I,J,L,n) - else - if( var3d_2(i,j,L,n).ne.undef ) then - fields_3d(n)%clim(I,J,L) = var3d_2(I,J,L,n) - else - fields_3d(n)%clim(I,J,L) = undef - endif - endif - endif - enddo - enddo - enddo - enddo - - return - end - - subroutine read_clim_bin ( nymd,nhms,p,u,v,t,q,h,idim,jdim,ldim,undef ) - - use iso_fortran_env - implicit none -!*********************************************************************** -!* GODDARD LABORATORY FOR ATMOSPHERES * -!* Note: Climatology Data is in Grads Format from the files: * -!* ncep_1x1_clim.ctl * -!* ncep_1x1_clim.data * -!* Climatology Data is stored: January through December * -!*********************************************************************** - - integer :: IM, JM, LM - integer :: idim, jdim, ldim - PARAMETER ( IM = 360 ) - PARAMETER ( JM = 181 ) - PARAMETER ( LM = 10 ) - - real(kind=REAL32) bum(IM,JM) - real dum(IM,JM) - - real p ( IDIM,JDIM ) - real u ( IDIM,JDIM,LDIM ) - real v ( IDIM,JDIM,LDIM ) - real t ( IDIM,JDIM,LDIM ) - real q ( IDIM,JDIM,LDIM ) - real h ( IDIM,JDIM,LDIM ) - - real, allocatable, save :: p1( :,: ) - real, allocatable, save :: u1( :,:,: ) - real, allocatable, save :: v1( :,:,: ) - real, allocatable, save :: t1( :,:,: ) - real, allocatable, save :: q1( :,:,: ) - real, allocatable, save :: h1( :,:,: ) - - real, allocatable, save :: p2( :,: ) - real, allocatable, save :: u2( :,:,: ) - real, allocatable, save :: v2( :,:,: ) - real, allocatable, save :: t2( :,:,: ) - real, allocatable, save :: q2( :,:,: ) - real, allocatable, save :: h2( :,:,: ) - - real undef - logical first - data first /.true./ - - DATA IMONP/0/, IMONM/0/, ku /90/ - SAVE imonp, imonm - - INTEGER DAYS(12) - DATA DAYS /31,28,31,30,31,30,31,31,30,31,30,31/ - - integer :: N, SEC, MONTH, DAY, MIDMON - integer :: imnm, imnp, i, j, l - integer :: ISC, ISCM, ISCP, MONTH2, KU, IMONM, IMONP, MONTH1 - real :: FACP, FACM - - INTEGER :: NSECF, NMONF, NDAYF, NHMS, NYMD - - if( first ) then - open (90,file='ncep_1x1_clim.data', & - form='unformatted',access='direct',recl=im*jm ) -! form='unformatted',access='direct',recl=im*jm*4, -! convert='little_endian') - allocate ( p1(idim,jdim) , p2(idim,jdim) ) - allocate ( u1(idim,jdim,ldim), u2(idim,jdim,ldim) ) - allocate ( v1(idim,jdim,ldim), v2(idim,jdim,ldim) ) - allocate ( t1(idim,jdim,ldim), t2(idim,jdim,ldim) ) - allocate ( q1(idim,jdim,ldim), q2(idim,jdim,ldim) ) - allocate ( h1(idim,jdim,ldim), h2(idim,jdim,ldim) ) - first = .false. - endif - - undef = 1e15 - -!********************************************************************* -!**** FIND PROPER MONTH BOUNDARIES **** -!********************************************************************* - - SEC = NSECF(NHMS) - MONTH = NMONF(NYMD) - DAY = NDAYF(NYMD) - - MIDMON = DAYS(MONTH)/2 + 1 - - IF(DAY.LT.MIDMON) THEN - imnm = month - 1 - imnp = month - ELSE - IMNM = MONTH - IMNP = MONTH + 1 - ENDIF - - if( imnm.eq.0 ) imnm = 12 - if( imnp.eq.13 ) imnp = 1 - -!********************************************************************* -!**** READ DATA SET TWICE TO GET BOTH MONTHS **** -!********************************************************************* - - IF(IMONM.NE.IMNM .OR. IMONP.NE.IMNP) THEN - - IMONM = IMNM - IMONP = IMNP - -! Read First Month -! ---------------- - month1 = imonm - if( month1.lt.1 ) month1 = month1 + 12 - - n = (month1-1)*(1+LM*5) - read(ku,rec=n+1) bum - dum = bum - call bin ( dum,im,jm,p1,idim,jdim,undef,0 ) - - do L=1,LM - read(ku,rec=n+1+L) bum - dum = bum - call bin ( dum,im,jm,u1(1,1,L),idim,jdim,undef,1 ) - enddo - - do L=1,LM - read(ku,rec=n+1+L+LM) bum - dum = bum - call bin ( dum,im,jm,v1(1,1,L),idim,jdim,undef,1 ) - enddo - - do L=1,LM - read(ku,rec=n+1+L+2*LM) bum - dum = bum - call bin ( dum,im,jm,t1(1,1,L),idim,jdim,undef,0 ) - enddo - - do L=1,LM - read(ku,rec=n+1+L+3*LM) bum - dum = bum - call bin ( dum,im,jm,q1(1,1,L),idim,jdim,undef,0 ) - enddo - - do L=1,LM - read(ku,rec=n+1+L+4*LM) bum - dum = bum - call bin ( dum,im,jm,h1(1,1,L),idim,jdim,undef,0 ) - enddo - -! Read Second Month -! ----------------- - month2 = imonp - if( month2.lt.1 ) month2 = month2 + 12 - - n = (month2-1)*(1+LM*5) - read(ku,rec=n+1) bum - dum = bum - call bin ( dum,im,jm,p2,idim,jdim,undef,0 ) - - do L=1,LM - read(ku,rec=n+1+L) bum - dum = bum - call bin ( dum,im,jm,u2(1,1,L),idim,jdim,undef,1 ) - enddo - - do L=1,LM - read(ku,rec=n+1+L+LM) bum - dum = bum - call bin ( dum,im,jm,v2(1,1,L),idim,jdim,undef,1 ) - enddo - - do L=1,LM - read(ku,rec=n+1+L+2*LM) bum - dum = bum - call bin ( dum,im,jm,t2(1,1,L),idim,jdim,undef,0 ) - enddo - - do L=1,LM - read(ku,rec=n+1+L+3*LM) bum - dum = bum - call bin ( dum,im,jm,q2(1,1,L),idim,jdim,undef,0 ) - enddo - - do L=1,LM - read(ku,rec=n+1+L+4*LM) bum - dum = bum - call bin ( dum,im,jm,h2(1,1,L),idim,jdim,undef,0 ) - enddo - - ENDIF - -!********************************************************************* -!**** INTERPOLATE DATA TO CURRENT TIME **** -!********************************************************************* - - IF(DAY.LT.MIDMON) THEN - ISC = (DAY+DAYS(IMONM))*86400 + SEC - ELSE - ISC = (DAY )*86400 + SEC - ENDIF - - ISCM = (DAYS(IMONM)/2+1 )*86400 - ISCP = (DAYS(IMONP)/2+1 + DAYS(IMONM) )*86400 - - FACP = (ISC-ISCM) / REAL(ISCP-ISCM) - FACM = 1-FACP - -! write(6,100) imonm,facm,imonp,facp -!100 format(1x,'Interpolating Climatology for Month ',i2, -! . ' (',f5.3,') and Month ',i2,' (',f5.3,')') - - do J=1,JDIM - do I=1,IDIM - p(I,J) = p1(I,J)*FACM + p2(I,J)*FACP - enddo - enddo - do L=1,LDIM - do J=1,JDIM - do I=1,IDIM - u(I,J,L) = u1(I,J,L)*FACM + u2(I,J,L)*FACP - v(I,J,L) = v1(I,J,L)*FACM + v2(I,J,L)*FACP - t(I,J,L) = t1(I,J,L)*FACM + t2(I,J,L)*FACP - q(I,J,L) = q1(I,J,L)*FACM + q2(I,J,L)*FACP - h(I,J,L) = h1(I,J,L)*FACM + h2(I,J,L)*FACP - enddo - enddo - enddo - - RETURN - END - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*abs(undef) - return - end - - subroutine hshift ( q,im,jm ) - real q(im,jm), dum(im,jm) - dum(1:im/2,:) = q(1:im/2,:) - q(1:im/2,:) = q(1+im/2:im,:) - q(1+im/2:im,:) = dum(1:im/2,:) - return - end - - subroutine minmax (q,im,jm,undef) - real q(im,jm) - qmin = 1e33 - qmax = -1e33 - do j=1,jm - do i=1,im - if(q(i,j).ne.undef) qmin = min( qmin,q(i,j) ) - if(q(i,j).ne.undef) qmax = max( qmax,q(i,j) ) - enddo - enddo - print *, ' qmin: ',qmin,' qmax: ',qmax - return - end - - subroutine bin ( qin,im_in,jm_in,qout,im_out,jm_out,undef,msgn ) - implicit none - integer im_in ,jm_in ,msgn - integer im_out,jm_out - real undef - real qin(im_in ,jm_in ) - real qout(im_out,jm_out) - real q10x10(360*6,180*6) - -! Parse Arbitray Field (im,jm) to 10'x10' Variable -! ------------------------------------------------ - call timebeg ('___bin') - call bin_10x10 ( qin,im_in,jm_in,q10x10 ) - -! Bin 10'x10' Variable to Output Field (im_out,jm_out) -! ---------------------------------------------------- - call averaged_10x10 ( q10x10,qout,im_out,jm_out,undef,msgn ) - call timeend ('___bin') - - return - end - - subroutine averaged_10x10 ( z10x10,z,im,jm,undef,msgn ) -!*********************************************************************** -! -! PURPOSE: -! ======== -! Average a (10m X 10m) input array to an output array (im,jm) -! -! INPUT: -! ====== -! z10x10 ..... Input array(360*6,180*6) -! msgn ....... Integer Flag for scalar (0) or vector (1) -! -! OUTPUT: -! ======= -! z .......... Output array(im,jm) -! im ......... Longitudinal dimension of z -! jm ......... Latitudinal dimension of z -! -! NOTES: -! ====== -! Input array z10x10 represents values within a 10min X 10min grid-box. -! Each box is referenced by the latitude and longitude of -! its southwest corner, not its center point. Thus, -! the height associated with a coordinate actually -! represents the heights centered to the northeast of that point. -! -! Output array z(im,jm) is assumed to be on an A-grid. -! z(i,j) represents the value at the center of the grid-box. -! z(1,j) is located at lon=-180. -! z(i,1) is located at lat=-90. -! z(i,jm) is located at lat=+90. -! -!*********************************************************************** -!* GODDARD LABORATORY FOR ATMOSPHERES * -!*********************************************************************** - - implicit none - integer im,jm,msgn - real z(im,jm) - real dlam(im), dphi(jm) - real z10x10(360*6,180*6) - - integer i,j,ibeg,iend,jbeg,jend - integer ii,jj,itmp - real sum1,sum2 - real zlat,zlon - real lon1,lon2,wx - real lat1,lat2,wy - real lonbeg,lonend,lat,coslat - real latbeg,latend - real undef - real pi,dz - real lon_cmp(im) - real lat_cmp(jm) - logical defined - - call timebeg ('____ave_10x10') - pi = 4.*atan(1.) - dz = pi/(6.*180) - dlam = 2*pi/ im - dphi = pi/(jm-1) - -! Compute Computational Lambda's and Phi's -! ---------------------------------------- - lon_cmp(1) = -pi - do i=2,im - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_cmp(1) = -pi*0.5 - do j=2,jm-1 - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_cmp(jm) = pi*0.5 - - -! Compute average away from poles -! ------------------------------- - do j=2,jm-1 - do i=1,im - - zlat = lat_cmp(j) - zlon = lon_cmp(i) - - latbeg = zlat-dphi(j-1)/2 - latend = zlat+dphi(j) /2 - if( i.eq.1 ) then - lonbeg = zlon-dlam(im) /2 - else - lonbeg = zlon-dlam(i-1)/2 - endif - lonend = zlon+dlam(i) /2 - - ibeg = 1.+(lonbeg+pi) /dz - iend = 1.+(lonend+pi) /dz - jbeg = 1.+(latbeg+pi/2)/dz - jend = 1.+(latend+pi/2)/dz - - sum1 = 0 - sum2 = 0 - do jj=jbeg,jend - lat = -pi/2+(jj-0.5)*dz - coslat = cos(lat) - lat1 = -pi/2 + (jj-1)*dz - lat2 = -pi/2 + jj *dz - wy = 1.0 - if( lat1.lt.latbeg ) wy = (lat2-latbeg)/dz - if( lat2.gt.latend ) wy = (latend-lat1)/dz - - if(ibeg.ge.1) then - do ii=ibeg,iend - if( defined(z10x10(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + z10x10(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - else - itmp = 1.+(lonbeg+0.1*dz+3*pi)/dz - do ii=itmp,360*6 - if( defined(z10x10(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg+2*pi ) wx = (lon2-lonbeg-2*pi)/dz - if( lon2.gt.lonend+2*pi ) wx = (2*pi+lonend-lon1)/dz - sum1 = sum1 + z10x10(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - do ii=1,iend - if( defined(z10x10(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + z10x10(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - endif - - enddo - if( sum2.ne.0.0 ) then - z(i,j) = sum1/sum2 - else - z(i,j) = undef - endif - enddo - enddo - -! Compute average at South Pole -! ----------------------------- - j=1 - do i=1,im - - zlat = lat_cmp(j) - zlon = lon_cmp(i) - - latbeg = zlat - latend = zlat+dphi(j) /2 - if( i.eq.1 ) then - lonbeg = zlon-dlam(im) /2 - else - lonbeg = zlon-dlam(i-1)/2 - endif - lonend = zlon+dlam(i) /2 - - ibeg = 1.+(lonbeg+pi) /dz - iend = 1.+(lonend+pi) /dz - jbeg = 1 - jend = 1.+(latend+pi/2)/dz - - sum1 = 0 - sum2 = 0 - do jj=jbeg,jend - lat = -pi/2+(jj-0.5)*dz - coslat = cos(lat) - lat1 = -pi/2 + (jj-1)*dz - lat2 = -pi/2 + jj *dz - wy = 1.0 - if( lat1.lt.latbeg ) wy = (lat2-latbeg)/dz - if( lat2.gt.latend ) wy = (latend-lat1)/dz - - if(ibeg.ge.1) then - do ii=ibeg,iend - if( defined(z10x10(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + z10x10(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - else - itmp = 1.+(lonbeg+0.1*dz+3*pi)/dz - do ii=itmp,360*6 - if( defined(z10x10(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg+2*pi ) wx = (lon2-lonbeg-2*pi)/dz - if( lon2.gt.lonend+2*pi ) wx = (2*pi+lonend-lon1)/dz - sum1 = sum1 + z10x10(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - do ii=1,iend - if( defined(z10x10(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + z10x10(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - endif - - enddo - if( sum2.ne.0.0 ) then - z(i,j) = sum1/sum2 - else - z(i,j) = undef - endif - enddo - -! Compute average at North Pole -! ----------------------------- - j=jm - do i=1,im - - zlat = lat_cmp(j) - zlon = lon_cmp(i) - - latbeg = zlat-dphi(j-1)/2 - latend = zlat - if( i.eq.1 ) then - lonbeg = zlon-dlam(im) /2 - else - lonbeg = zlon-dlam(i-1)/2 - endif - lonend = zlon+dlam(i) /2 - - ibeg = 1.+(lonbeg+pi) /dz - iend = 1.+(lonend+pi) /dz - jbeg = 1.+(latbeg+pi/2)/dz - jend = 1080 - - sum1 = 0 - sum2 = 0 - do jj=jbeg,jend - lat = -pi/2+(jj-0.5)*dz - coslat = cos(lat) - lat1 = -pi/2 + (jj-1)*dz - lat2 = -pi/2 + jj *dz - wy = 1.0 - if( lat1.lt.latbeg ) wy = (lat2-latbeg)/dz - if( lat2.gt.latend ) wy = (latend-lat1)/dz - - if(ibeg.ge.1) then - do ii=ibeg,iend - if( defined(z10x10(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + z10x10(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - else - itmp = 1.+(lonbeg+0.1*dz+3*pi)/dz - do ii=itmp,360*6 - if( defined(z10x10(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg+2*pi ) wx = (lon2-lonbeg-2*pi)/dz - if( lon2.gt.lonend+2*pi ) wx = (2*pi+lonend-lon1)/dz - sum1 = sum1 + z10x10(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - do ii=1,iend - if( defined(z10x10(ii,jj),undef) ) then - lon1 = -pi + (ii-1)*dz - lon2 = -pi + ii *dz - wx = 1.0 - if( lon1.lt.lonbeg ) wx = (lon2-lonbeg)/dz - if( lon2.gt.lonend ) wx = (lonend-lon1)/dz - sum1 = sum1 + z10x10(ii,jj)*coslat*wx*wy - sum2 = sum2 + coslat*wx*wy - endif - enddo - endif - - enddo - if( sum2.ne.0.0 ) then - z(i,j) = sum1/sum2 - else - z(i,j) = undef - endif - enddo - -! Average Pole Values -! ------------------- - if( msgn.eq.0 ) then - sum1 = 0 - j = 0 - do i=1,im - if( defined(z(i,1),undef) ) then - sum1 = sum1 + z(i,1) - j = j + 1 - endif - enddo - if( j.ne.0 ) then - z(:,1) = sum1/j - else - z(:,1) = undef - endif - - sum2 = 0 - j = 0 - do i=1,im - if( defined(z(i,jm),undef) ) then - sum2 = sum2 + z(i,jm) - j = j + 1 - endif - enddo - if( j.ne.0 ) then - z(:,jm) = sum2/j - else - z(:,jm) = undef - endif - - endif - - call timeend ('____ave_10x10') - return - end - - subroutine bin_10x10 ( z,im,jm,z10x10 ) -!*********************************************************************** -! -! PURPOSE: -! ======== -! Compute a (10m X 10m) array binned from an input array (im,jm) -! -! INPUT: -! ====== -! z .......... Input array(im,jm) -! im ......... Longitudinal dimension of z -! jm ......... Latitudinal dimension of z -! -! OUTPUT: -! ======= -! z10x10 ..... Output array(360*6,180*6) -! -! NOTES: -! ====== -! Input array z(im,jm) is assumed to be on an A-grid. -! z(i,j) represents the value at the center of the grid-box. -! z(1,j) is located at lon=-180. -! z(i,1) is located at lat=-90. -! z(i,jm) is located at lat=+90. -! -! Output array z10x10 represents values within a 10min X 10min grid-box. -! Each box is referenced by the latitude and longitude of -! its southwest corner, not its center point. Thus, -! the height associated with a coordinate actually -! represents the heights centered to the northeast of that point. -! -!*********************************************************************** -!* GODDARD LABORATORY FOR ATMOSPHERES * -!*********************************************************************** - - implicit none - integer im,jm - real z(im,jm) - real z10x10(360*6,180*6) - - integer i,j,ii,jj,ibeg,iend,jbeg,jend - real zlatc,zlonc - real lonbeg,lonend - real latbeg,latend - real pi,dl,dp,dz - - call timebeg ('____bin_10x10') - pi = 4.*atan(1.) - dl = 2*pi/im - dp = pi/(jm-1) - dz = pi/(6.*180) - - do j=1,180*6 - do i=1,360*6 - - zlatc = -pi/2+(j-0.5)*dz ! Latitude at center of 10x10 box - zlonc = -pi +(i-0.5)*dz ! Longitude at center of 10x10 box - -! Find bounding lat and lon on IMxJM grid -! --------------------------------------- - iend = nint( 1.+(zlonc+pi)/dl ) - lonend = -pi + (iend-1)*dl - if( lonend.ge.zlonc ) then - lonbeg = -pi + (iend-2)*dl - else - iend = iend+1 - lonbeg = lonend - lonend = -pi + (iend-1)*dl - endif - ibeg = iend-1 - - jend = nint( 1.+(zlatc+pi/2)/dp ) - latend = -pi/2 + (jend-1)*dp - if( latend.ge.zlatc ) then - latbeg = -pi/2 + (jend-2)*dp - else - jend = jend+1 - latbeg = latend - latend = -pi/2 + (jend-1)*dp - endif - jbeg = jend-1 - - - if(iend.gt.im) iend=iend-im - - if( zlonc.le.lonbeg+0.5*dl ) then - ii = ibeg - else - ii = iend - endif - if( zlatc.le.latbeg+0.5*dp ) then - jj = jbeg - else - jj = jend - endif - - z10x10(i,j) = z(ii,jj) - - enddo - enddo - - call timeend ('____bin_10x10') - return - end - - subroutine read_anal( nymd,nhms,fields_2d,fields_3d,n2d,n3d,idim,jdim,nl,zlev,ana_files,num_ana_files,undef ) - use stats_mod - use MAPL_ConstantsMod - implicit none - integer nymd,nhms,n2d,n3d - type(fields) :: fields_2d(n2d) - type(fields) :: fields_3d(n3d) - - integer idim,jdim,nl,num_ana_files - real zlev(nl) - - integer id,im,jm,lm,nvars,rc - integer ntime,ngatts,timinc - real undef - integer L,m,n - character*256 ana_files(num_ana_files) - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - real, allocatable :: q(:,:) - real, allocatable :: sp(:,:) - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - integer, allocatable :: dates(:,:) - integer, allocatable :: datez(:,:) - - logical found_2d(n2d) - logical found_3d(n3d) - - logical check_names - logical shift, defined, first - integer num, LL, i,j,k, loc, ndates, len - real Td, pp, ee - real tice, epsln, ec0, ec1, ec2 - data id /0/ - data num /0/ - data shift /.false./ - data first /.true./ - save - - -! Read All ANA Files to Gather Date and Time Information -! ------------------------------------------------------ - if( first ) then - call timebeg ('__init_anal') - print *, 'Examining ANA Files ...' - print * - ndates = 0 - do num=1,num_ana_files - call gfio_open ( ana_files(num),1,id,rc ) - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, & - title,source,contact,undef, & - lon,lat,lev,levunits, & - yymmdd,hhmmss,timinc, & - vname,vtitle,vunits,kmvar, & - vrange,prange,rc ) - - if( ndates.eq.0 ) then - ndates = ndates + ntime - allocate ( dates(3,ndates) ) - allocate ( datez(3,ndates) ) - dates(1,ndates-ntime+1:ndates) = yymmdd(:) - dates(2,ndates-ntime+1:ndates) = hhmmss(:) - dates(3,ndates-ntime+1:ndates) = num - datez = dates - else - deallocate(dates) - ndates = ndates + ntime - allocate ( dates(3,ndates) ) - dates(1,1:ndates-ntime) = datez(1,1:ndates-ntime) - dates(2,1:ndates-ntime) = datez(2,1:ndates-ntime) - dates(3,1:ndates-ntime) = datez(3,1:ndates-ntime) - dates(1,ndates-ntime+1:ndates) = yymmdd(:) - dates(2,ndates-ntime+1:ndates) = hhmmss(:) - dates(3,ndates-ntime+1:ndates) = num - deallocate(datez) - allocate ( datez(3,ndates) ) - datez = dates - endif - - call gfio_close(id,rc) - deallocate ( lon,lat,lev,yymmdd,hhmmss,vname,vtitle,vunits,kmvar,vrange,prange ) - enddo - first = .false. - call timeend ('__init_anal') - endif - - -! Initial Analysis Fields to NOT Found -! ------------------------------------ - do n=1,n2d - found_2d(n) = .false. - enddo - do n=1,n3d - found_3d(n) = .false. - enddo - -! Read Appropriate ANA Files to Get Data -! -------------------------------------- - do num=1,ndates - if( dates(1,num).eq.nymd .and. dates(2,num).eq.nhms ) then - call gfio_open ( ana_files(dates(3,num)),1,id,rc ) - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, & - title,source,contact,undef, & - lon,lat,lev,levunits, & - yymmdd,hhmmss,timinc, & - vname,vtitle,vunits,kmvar, & - vrange,prange,rc ) - - shift = .false. - if( lon(1).eq.0.0 ) then - ! print *, 'Analysis data begins at lon: ',lon(1) - ! print *, 'Horizontal Shift will be performed' - ! print * - shift = .true. - endif - - allocate ( q(im,jm) ) - - do n=1,nvars - - do m=1,n2d - if( .not.found_2d(m) ) then - len = size( fields_2d(m)%alias ) - do k = 1,len - if( check_names( vname(n),fields_2d(m)%alias(k) ) ) then - found_2d(m) = .true. - call gfio_getvar ( id,vname(n),nymd,nhms,im,jm,0,1,q,rc ) - - if( trim(vname(n)) == 'N2_metre_dewpoint_temperature' ) then - tice= MAPL_TICE - epsln = MAPL_EPSILON - !! empirical coeff. (Bolton 1980) - ec0 = 6.112 - ec1 = 17.67 - ec2 = 243.5 - - allocate( sp(im, jm) ) - call gfio_getvar ( id,'Surface_pressure',nymd,nhms,im,jm,0,1,sp,rc ) - do j=1,jm - do i=1,im - if( defined(q(i,j),undef) .and. defined(sp(i,j),undef) )then - Td = q(i,j)-tice ! to C - pp = sp(i,j)/100. ! to mb - ee= ec0*exp((ec1*Td)/(Td + ec2)) - q(i,j) = (epsln * ee)/(pp - (1.0-epsln) * ee) - else - print*, 'Td conversion fails,set q2m to UNDEF' - q(i,j) = undef - endif - enddo - enddo - deallocate ( sp ) - endif - !------ - - if( shift ) call hshift ( q,im,jm ) - if( check_names( fields_2d(m)%name,'p' ) ) then - do j=1,jm - do i=1,im - if( defined(q(i,j),undef) .and. q(i,j).gt.10000.0 ) then - q(i,j) = q(i,j)*0.01 ! Convert Pa=>mb - endif - enddo - enddo - endif - if( check_names( fields_2d(m)%type,'aerosol' ) ) then - do j=1,jm - do i=1,im - if( defined(q(i,j),undef) ) q(i,j) = log( q(i,j)+0.01 ) - enddo - enddo - endif - call bin ( q,im,jm,fields_2d(m)%anal,idim,jdim,undef,fields_2d(m)%msgn ) - endif - enddo - endif - enddo - - do m=1,n3d - if( .not.found_3d(m) ) then - len = size( fields_3d(m)%alias ) - do k = 1,len - if( check_names( vname(n),fields_3d(m)%alias(k) ) ) then - found_3d(m) = .true. - - do L=1,nl - loc = -1 - do LL=1,lm - if( lev(LL).eq.zlev(L) ) loc = LL - enddo - if( loc.ne.-1 ) then - call gfio_getvar ( id,vname(n),nymd,nhms,im,jm,loc,1,q,rc ) - else - q = undef - endif - if( shift ) call hshift ( q,im,jm ) - call bin ( q,im,jm,fields_3d(m)%anal(1,1,L),idim,jdim,undef,fields_3d(m)%msgn ) - enddo - endif - enddo - endif - enddo - - enddo - call gfio_close(id,rc) - deallocate ( q,lon,lat,lev,yymmdd,hhmmss,vname,vtitle,vunits,kmvar,vrange,prange ) - endif - enddo - -! Set Analysis Fields to UNDEF if NOT Found -! ----------------------------------------- - do n=1,n2d - if( .not.found_2d(n) ) fields_2d(n)%anal = undef - enddo - do n=1,n3d - if( .not.found_3d(n) ) fields_3d(n)%anal = undef - enddo - - return - end - - subroutine init_levs( fname,lm,lev ) - implicit none - character*256 fname - real, pointer :: lev(:) - - integer id,im,jm,lm,nvars,rc - integer ntime,ngatts,timinc - real undef - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, pointer :: vname(:) - character*256, pointer :: vtitle(:) - character*256, pointer :: vunits(:) - - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: kmvar(:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - -! Read Forecast File to Gather Lev Information -! -------------------------------------------- - - call gfio_open ( fname,1,id,rc ) - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, & - title,source,contact,undef, & - lon,lat,lev,levunits, & - yymmdd,hhmmss,timinc, & - vname,vtitle,vunits,kmvar, & - vrange,prange,rc ) - - call gfio_close(id,rc) - deallocate ( lon,lat,yymmdd,hhmmss,vname,vtitle,vunits,kmvar,vrange,prange ) - - return - end - - subroutine init_fcst( fname,nfiles,dates,ndates,timinc,undef,collections,ncoll ) - use stats_mod - use ESMF - implicit none - integer ncoll - - type(collection) :: collections(ncoll) - - integer id,im,jm,lm,nvars,rc - integer ntime,ngatts,timinc,nfiles - real undef - integer j,k,m,n,len - character*256 fname(nfiles) - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: kmvar(:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - - integer dates(3,1000) - integer ndates,num - logical check_names - -! Read All Forecast Files to Gather Date and Time Information -! ----------------------------------------------------------- - print *, 'Examining Forecast Files ...' - ndates = 0 - do num=1,nfiles - call gfio_open ( fname(num),1,id,rc ) - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, & - title,source,contact,undef, & - lon,lat,lev,levunits, & - yymmdd,hhmmss,timinc, & - vname,vtitle,vunits,kmvar, & - vrange,prange,rc ) - - do n=1,nvars - do j=1,ncoll - do m=1,collections(j)%n2d - len = size( collections(j)%fields_2d(m)%alias ) - do k = 1,len - if( check_names( vname(n),collections(j)%fields_2d(m)%alias(k) ) ) then - if( trim(vtitle(n)).ne.'**' ) collections(j)%fields_2d(m)%desc = vtitle(n) - endif - enddo - enddo - do m=1,collections(j)%n3d - len = size( collections(j)%fields_3d(m)%alias ) - do k = 1,len - if( check_names( vname(n),collections(j)%fields_3d(m)%alias(k) ) ) then - if( trim(vtitle(n)).ne.'**' ) collections(j)%fields_3d(m)%desc = vtitle(n) - endif - enddo - enddo - enddo - enddo - - ndates = ndates + ntime - - if( ndates.gt.1000 ) then - print * - print *, 'Forecast Files have exceeded 1000 Time Periods!' - print * - call ESMF_Finalize() - stop - endif - - dates(1,ndates-ntime+1:ndates) = yymmdd(:) - dates(2,ndates-ntime+1:ndates) = hhmmss(:) - dates(3,ndates-ntime+1:ndates) = num - - call gfio_close(id,rc) - deallocate ( lon,lat,lev,yymmdd,hhmmss,vname,vtitle,vunits,kmvar,vrange,prange ) - enddo - - return - end - - subroutine read_fcst( fname,nfiles,dates,ndates,nymd,nhms,fields_2d,fields_3d,n2d,n3d,idim,jdim,nl,zlev,undef ) - use stats_mod - implicit none - integer n2d,n3d - type(fields) :: fields_2d(n2d) - type(fields) :: fields_3d(n3d) - - logical check_names - logical defined - integer nymd,nhms - integer idim,jdim,nl - real zlev(nl) - - integer id,im,jm,lm,nvars,rc - real undef - integer i,j,k,L,m,n - integer LL,loc,len - logical shift - integer ndates,nfiles,num - integer dates(3,ndates) - - real, allocatable :: q(:,:) - - character*256 fname(nfiles) - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - character*256, allocatable :: vname (:) - - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: kmvar(:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - - integer ntime,ngatts,timinc - logical found_2d(n2d) - logical found_3d(n3d) - -! Initial Forecast Fields to NOT Found -! ------------------------------------ - do n=1,n2d - found_2d(n) = .false. - enddo - do n=1,n3d - found_3d(n) = .false. - enddo - -! Loop Through All Dates within Forecast Files -! -------------------------------------------- - do num=1,ndates - if( dates(1,num).eq.nymd .and. dates(2,num).eq.nhms ) then - - call gfio_open ( fname(dates(3,num)),1,id,rc ) - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( vname(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, & - title,source,contact,undef, & - lon,lat,lev,levunits, & - yymmdd,hhmmss,timinc, & - vname,vtitle,vunits,kmvar, & - vrange,prange,rc ) - - shift = .false. - if( lon(1).eq.0.0 ) then - ! print *, 'Forecast data begins at lon: ',lon(1) - ! print *, 'Horizontal Shift will be performed' - ! print * - shift = .true. - endif - - allocate ( q(im,jm) ) - -! READ Forecast Fields from Forecast Files -! ---------------------------------------- - do n=1,nvars - - do m=1,n2d - if( .not.found_2d(m) ) then - len = size( fields_2d(m)%alias ) - do k = 1,len - if( check_names( vname(n),fields_2d(m)%alias(k) ) ) then - found_2d(m) = .true. - call gfio_getvar ( id,vname(n),nymd,nhms,im,jm,0,1,q,rc ) - if( shift ) call hshift ( q,im,jm ) - if( check_names( fields_2d(m)%name,'p' ) ) then - do j=1,jm - do i=1,im - if( defined(q(i,j),undef) .and. q(i,j).gt.10000.0 ) then - q(i,j) = q(i,j)*0.01 ! Convert Pa=>mb - endif - enddo - enddo - endif - if( check_names( fields_2d(m)%type,'aerosol' ) ) then - do j=1,jm - do i=1,im - if( defined(q(i,j),undef) ) q(i,j) = log( q(i,j)+0.01 ) - enddo - enddo - endif - call bin ( q,im,jm,fields_2d(m)%fcst,idim,jdim,undef,fields_2d(m)%msgn ) - endif - enddo - endif - enddo - - do m=1,n3d - if( .not.found_3d(m) ) then - len = size( fields_3d(m)%alias ) - do k = 1,len - if( check_names( vname(n),fields_3d(m)%alias(k) ) ) then - found_3d(m) = .true. - - do L=1,nl - loc = -1 - do LL=1,lm - if( lev(LL).eq.zlev(L) ) loc = LL - enddo - - if( loc.ne.-1 ) then - call gfio_getvar ( id,vname(n),nymd,nhms,im,jm,loc,1,q,rc ) - else - q = undef - endif - if( shift ) call hshift ( q,im,jm ) - call bin ( q,im,jm,fields_3d(m)%fcst(1,1,L),idim,jdim,undef,fields_3d(m)%msgn ) - enddo - - endif - enddo - endif - enddo - - enddo ! End Loop: n=1,nvars - - call gfio_close(id,rc) - deallocate ( q,lon,lat,lev,yymmdd,hhmmss,vname,vtitle,vunits,kmvar,vrange,prange ) - - endif ! End Dates Test - enddo ! End Loop: num=1,ndates - -! Set Forecast Fields to UNDEF if NOT Found -! ----------------------------------------- - do n=1,n2d - if( .not.found_2d(n) ) fields_2d(n)%fcst = undef - enddo - do n=1,n3d - if( .not.found_3d(n) ) fields_3d(n)%fcst = undef - enddo - - return - end - - subroutine read_syserr( fields_2d,fields_3d,n2d,n3d,idim,jdim,nl,zlev,efile,ndt,undef ) - use stats_mod - use ESMF - implicit none - - integer :: n2d,n3d - type(fields) :: fields_2d(n2d) - type(fields) :: fields_3d(n3d) - - logical check_names - - integer nymd ,nhms - integer nymd0,nhms0 - integer idim,jdim,nl - real zlev(nl) - - integer id,im,jm,lm,nvars,rc - integer ntime,ngatts,timinc - integer nsecf - real undef - integer k,L,m,n - integer len,ndt,num,nt - character*256 efile - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - real, allocatable :: q(:,:) - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - logical found, shift, defined - integer LL, i,j, loc - data id /0/ - data num /0/ - data shift /.false./ - save - - 10 continue - if( id.eq.0 ) then - call gfio_open ( efile,1,id,rc ) - if( rc.ne.0 ) then - print *, 'Systematic Error File: ',trim(efile),' NOT found!' - call ESMF_Finalize() - stop - endif - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - - call gfio_inquire ( id,im,jm,lm,ntime,nvars, & - title,source,contact,undef, & - lon,lat,lev,levunits, & - yymmdd,hhmmss,timinc, & - vname,vtitle,vunits,kmvar, & - vrange,prange,rc ) - - ! print *, 'SYSERR TIMINC: ',timinc - ! print *, 'SYSERR UNDEF: ',undef - if( ndt .ne. nsecf(timinc) ) then - ! print *, 'Error!' - print *, 'Warning!' - print *, 'Forecast File Frequency: ',ndt,' (sec)' - print *, 'Systematic Error File Frequency: ',nsecf(timinc),' (sec)' - ! stop - endif - - ! print *, 'YYMMDD: ',yymmdd - ! print *, 'HHMMSS: ',hhmmss - - if( lon(1).eq.0.0 ) then - ! print *, 'Systematic Error data begins at lon: ',lon(1) - ! print *, 'Horizontal Shift will be performed' - ! print * - shift = .true. - endif - - nymd0 = yymmdd(1) - nhms0 = hhmmss(1) - endif - -! Tick Clock for Next Desired Time Period -! --------------------------------------- - nymd = nymd0 - nhms = nhms0 - nt = num*ndt - call tick (nymd,nhms,nt) - num = num+1 - - found = .false. - do n=1,ntime - if( yymmdd(n).eq.nymd .and. hhmmss(n).eq.nhms ) found = .true. - enddo - if( .not.found ) then - write(6,100) nymd,nhms - do n=1,n2d - fields_2d(n)%serr = 0.0 - enddo - do n=1,n3d - fields_3d(n)%serr = 0.0 - enddo - return - endif - 100 format(/,1x,'Cannot find matching SysError Time for ',i8,2x,i6.6,' ZEROs will be used',/) - - allocate ( q(im,jm) ) - - do n=1,n2d - fields_2d(n)%serr = 0.0 - enddo - do n=1,n3d - fields_3d(n)%serr = 0.0 - enddo - - do n=1,nvars - - do m=1,n2d - len = size( fields_2d(m)%alias ) - do k = 1,len - if( check_names( vname(n),fields_2d(m)%alias(k) ) ) then - call gfio_getvar ( id,vname(n),nymd,nhms,im,jm,0,1,q,rc ) - if( shift ) call hshift ( q,im,jm ) - if( check_names( fields_2d(m)%name,'p' ) ) then - do j=1,jm - do i=1,im - if( defined(q(i,j),undef) .and. q(i,j).gt.10000.0 ) then - q(i,j) = q(i,j)*0.01 ! Convert Pa=>mb - endif - enddo - enddo - endif - if( check_names( fields_2d(m)%type,'aerosol' ) ) then - do j=1,jm - do i=1,im - if( defined(q(i,j),undef) ) q(i,j) = log( q(i,j)+0.01 ) - enddo - enddo - endif - call bin ( q,im,jm,fields_2d(m)%serr,idim,jdim,undef,fields_2d(m)%msgn ) - endif - enddo - enddo - - - do L=1,nl - loc = -1 - do LL=1,lm - if( lev(LL).eq.zlev(L) ) loc = LL - enddo - - do m=1,n3d - len = size( fields_3d(m)%alias ) - do k = 1,len - if( check_names( vname(n),fields_3d(m)%alias(k) ) ) then - if( loc.ne.-1 ) then - call gfio_getvar ( id,vname(n),nymd,nhms,im,jm,loc,1,q,rc ) - else - q = 0.0 - endif - if( shift ) call hshift ( q,im,jm ) - call bin ( q,im,jm,fields_3d(m)%serr(1,1,L),idim,jdim,undef,fields_3d(m)%msgn ) - - endif - enddo - enddo - - - enddo - enddo - - deallocate ( q ) - return - end - - subroutine interp_time ( nymd1,nhms1, nymd2,nhms2, ntimes, num ) - - integer nymd1, nhms1, nymd2, nhms2, ntimes, num - INTEGER YEAR1, MONTH1, DAY1, SEC1 - INTEGER YEAR2, MONTH2, DAY2, SEC2 - - real time1, time2 - - INTEGER DAYSCY - PARAMETER (DAYSCY = 365*4+1) - - REAL MNDY(12,4), DUM(48) - DATA MNDY /0,31,60,91,121,152,182,213,244,274,305,335,366,397,34*0/ - EQUIVALENCE ( DUM(1), MNDY(1,1) ) - - DO I=15,48 - DUM(I) = DUM(I-12) + 365 - ENDDO - -! DO I=15,48 -! MNDY(I,1) = MNDY(I-12,1) + 365 -! ENDDO - - YEAR1 = NYMD1 / 10000 - MONTH1 = MOD(NYMD1,10000) / 100 - DAY1 = MOD(NYMD1,100) - SEC1 = NSECF(NHMS1) - - YEAR2 = NYMD2 / 10000 - MONTH2 = MOD(NYMD2,10000) / 100 - DAY2 = MOD(NYMD2,100) - SEC2 = NSECF(NHMS2) - - time1 = DAY1 + MNDY(MONTH1,MOD(YEAR1,4)+1) + float(sec1)/86400. - time2 = DAY2 + MNDY(MONTH2,MOD(YEAR2,4)+1) + float(sec2)/86400. - - if( time2.lt.time1 ) time2 = time2 + dayscy - - num = 24.0*(time2-time1)/float(ntimes-1) - - RETURN - END - - subroutine writit ( q,im,jm,lm,qundef,undef ) - use iso_fortran_env - implicit none - integer im,jm,lm - real q(im,jm,lm) - real(kind=REAL32) dum(im,jm) - real(kind=REAL32) qundef, undef - logical defined - integer i,j,L - do L=1,lm - do j=1,jm - do i=1,im - if( defined(q(i,j,L),qundef) ) then - dum(i,j) = q(i,j,L) - else - dum(i,j) = undef - endif - enddo - enddo - write(51) dum - enddo - return - end - -!for land-only option -!-------------------- - subroutine landmk ( q,im,jm,lm,landmask,undef ) - implicit none - integer im,jm,lm - real q(im,jm,lm) - real*4 undef - real*4 landmask(im,jm) - integer i,j,L - - do L=1,lm - do j=1,jm - do i=1,im - if(landmask(i,j) == 0 ) then - q(i,j,L) = undef - endif - enddo - enddo - enddo - return - end - -! for land-only option -!-------------------- - subroutine load_landmask (filename,frland,imbin,jmbin,undef ) - use stats_mod - implicit none - - character*256 filename - integer id,im,jm,lm,nvars,rc - integer ntime,ngatts,timinc - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:) - character*256, allocatable :: vtitle(:) - character*256, allocatable :: vunits(:) - - real, allocatable :: q(:,:) - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real, allocatable :: vrange(:,:) - real, allocatable :: prange(:,:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: kmvar(:) - - integer imbin,jmbin, n - character*256 landname - real frland (imbin,jmbin ) - logical shift - real undef - - call gfio_open ( trim(filename) ,1,id,rc ) - call gfio_diminquire ( id,im,jm,lm,ntime,nvars,ngatts,rc ) - print *, ' landmask dimension: ',im, jm - allocate ( lon(im) ) - allocate ( lat(jm) ) - allocate ( lev(lm) ) - allocate ( yymmdd(ntime) ) - allocate ( hhmmss(ntime) ) - allocate ( vname(nvars) ) - allocate ( vtitle(nvars) ) - allocate ( vunits(nvars) ) - allocate ( kmvar(nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - call gfio_inquire ( id,im,jm,lm,ntime,nvars, & - title,source,contact,undef, & - lon,lat,lev,levunits, & - yymmdd,hhmmss,timinc, & - vname,vtitle,vunits,kmvar, & - vrange,prange,rc ) - shift = .false. - if( lon(1).eq.0.0 ) then - print *, 'landmask begins at lon: ',lon(1) - print *, 'Horizontal Shift will be performed' - shift = .true. - endif - - do n=1, nvars - if ( trim(vname(n)) == 'FRLAND') then - landname = trim(vname(n)) - print *, ' landmask varname :', trim(landname) - endif - enddo - - allocate (q(im,jm)) - call gfio_getvar ( id,trim(landname),yymmdd,hhmmss, & - im,jm,0,1,q,rc ) - - if( shift ) call hshift ( q,im,jm ) - call bin ( q,im,jm,frland,imbin,jmbin,undef,0 ) - call gfio_close(id,rc) - return - end - - - subroutine usage() - print *, "Usage: " - print * - print *, " stats_$ARCH.x -fcst fcst_fname(s)" - print *, " -ana ana_fname(s)" - print *, " -cli climatology(s)" - print *, " <-tag tag>" - print *, " <-pref PREF>" - print *, " <-nfreq HHMMSS>" - print *, " <-landonly landmaskfile>" - print *, " <-syserror SYSERR>" - print * - print *, "where:" - print * - print *, " -fcst fcst_fname(s): Filename(s) of pressure-level forecast data (HDF)" - print *, " -ana ana_fname(s): Filename(s) in pressure-level analysis data (HDF)" - print *, " -cli climatology(s): Filename(s) in pressure-level climatology data (HDF)" - print *, " Note:" - print *, " A single Mean Climatology, or a" - print *, " Set of 4 Climatologies (00,06,12,18z) may be used" - print * - print *, " -tag tag : Optional Tag for Output Names" - print *, " -pref PREF : Optional Reference Pressure for STD Output Printing" - print *, " (Default: 500-mb)" - print *, " -nfreq HHMMSS : Optional Frequency for Forecast Time Periods" - print *, " -landonly landmaskfile : Optional calculate stats overland" - print *, " -syserr SYSERR File : Optional Systematic Error File" - print *, " to be Subtracted from Forecasts" - print * - print *, "creates:" - print * - print *, "Tag_Name.stats.b{YYYYMMDD}.e{YYYYMMDD}.data" - print *, "Tag_Name.stats.b{YYYYMMDD}.e{YYYYMMDD}.ctl1" - print *, "Tag_Name.stats.b{YYYYMMDD}.e{YYYYMMDD}.ctl2" - print * - error stop 7 - end subroutine usage - - subroutine tick (nymd,nhms,ndt) -!*********************************************************************** -! Purpose -! Tick the Date (nymd) and Time (nhms) by NDT (seconds) -! -!*********************************************************************** -!* GODDARD LABORATORY FOR ATMOSPHERES * -!*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - end subroutine tick - - function incymd (NYMD,M) -!*********************************************************************** -! PURPOSE -! INCYMD: NYMD CHANGED BY ONE DAY -! MODYMD: NYMD CONVERTED TO JULIAN DATE -! DESCRIPTION OF PARAMETERS -! NYMD CURRENT DATE IN YYMMDD FORMAT -! M +/- 1 (DAY ADJUSTMENT) -! -!*********************************************************************** -!* GODDARD LABORATORY FOR ATMOSPHERES * -!*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -!*********************************************************************** - - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -!*********************************************************************** -! E N T R Y M O D Y M D -!*********************************************************************** - - ENTRY MODYMD (NYMD) - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - RETURN - end function incymd - - function nsecf (nhms) -!*********************************************************************** -! Purpose -! Converts NHMS format to Total Seconds -! -!*********************************************************************** -!* GODDARD LABORATORY FOR ATMOSPHERES * -!*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end function nsecf - - function nmonf (nymd) -!*********************************************************************** -! Purpose -! Converts NYMD format to month -! -!*********************************************************************** -!* GODDARD LABORATORY FOR ATMOSPHERES * -!*********************************************************************** - implicit none - integer nymd, nmonf - nmonf = mod(nymd,10000)/100 - return - end function nmonf - - function ndayf (nymd) -!*********************************************************************** -! Purpose -! Converts NYMD format to day -! -!*********************************************************************** -!* GODDARD LABORATORY FOR ATMOSPHERES * -!*********************************************************************** - implicit none - integer nymd, ndayf - ndayf = mod(nymd,100) - return - end function ndayf - - function nhmsf (nsec) -!*********************************************************************** -! Purpose -! Converts Total Seconds to NHMS format -! -!*********************************************************************** -!* GODDARD LABORATORY FOR ATMOSPHERES * -!*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end function nhmsf - - function check_names (name1,name2) - implicit none - logical check_names - character(*) name1,name2 - integer len,i - character*256 uname1,uname2 - character*1 c - -! Convert name1 to All UpperCase uname1 -! ------------------------------------- - len = len_trim(name1) - uname1 = '' - do i=1,len - c = name1(i:i) - if( ichar(c).ge.97 .and. ichar(c).le.122 ) then - c = achar( ichar(c)-32 ) - endif - uname1 = trim(uname1) // c - enddo - -! Convert name2 to All UpperCase uname2 -! ------------------------------------- - len = len_trim(name2) - uname2 = '' - do i=1,len - c = name2(i:i) - if( ichar(c).ge.97 .and. ichar(c).le.122 ) then - c = achar( ichar(c)-32 ) - endif - uname2 = trim(uname2) // c - enddo - -! Compare uname1 and uname2 -! ------------------------- - check_names = ( trim(uname1) == trim(uname2) ) - return - end diff --git a/GEOS_Util/post/swapendian_FV.f90 b/GEOS_Util/post/swapendian_FV.f90 deleted file mode 100644 index a0be5ffb..00000000 --- a/GEOS_Util/post/swapendian_FV.f90 +++ /dev/null @@ -1,62 +0,0 @@ -program swapFV - - implicit none - - integer :: int_pack(6) - integer :: unitR - integer :: unitW - integer :: IM, JM, KM - integer :: L, status - real*8,allocatable :: C(:) - real*8,allocatable :: A(:,:) - character(128) :: str, f_in, f_out - - -! Begin - - if (command_argument_count() /= 2) then - call get_command_argument(0,str) - write(*,*) "Usage:",trim(str)," " - error stop 2 - end if - - call get_command_argument(1,f_in) - call get_command_argument(2,f_out) - - unitR = 7 - unitW = 8 - - open(unit=unitR, file=trim(f_in), convert="big_endian", form="unformatted") - open(unit=unitW, file=trim(f_out), convert="native", form="unformatted") - - read (unitR) int_pack(1:6) - write(unitW) int_pack(1:6) - read (unitR) int_pack(1:5) - write(unitW) int_pack(1:5) - - IM = int_pack(1) - JM = int_pack(2) - KM = int_pack(3) - - print *, 'Converting FV restart: ',trim(f_in) - print *, ' Resolution: ',im,jm,km - - allocate(C(KM+1), A(IM,JM), stat=status) - if (status /=0 ) error stop 1 - - read (unitR) C !AK - write(unitW) C - read (unitR) C !BK - write(unitW) C - - do L = 1, 5*KM+1 ! 5 vars (U,V,PT,PE,PKZ), PE is edge quantity and has extra level - read (unitR) A - write(unitW) A - end do - - deallocate(a, c) - - close(unitR) - close(unitW) - -end program swapFV diff --git a/GEOS_Util/post/swapendian_RST.f90 b/GEOS_Util/post/swapendian_RST.f90 deleted file mode 100644 index 2783c6c1..00000000 --- a/GEOS_Util/post/swapendian_RST.f90 +++ /dev/null @@ -1,56 +0,0 @@ -program endian_convert - implicit none - - real, pointer :: var(:) - - integer :: i, bpos, epos, status - integer :: rsize - character(128) :: str, f_in, f_out - integer*4 :: ftell - external :: ftell - -! Begin - - if (command_argument_count() /= 2) then - call get_command_argument(0,str) - write(*,*) "Usage:",trim(str)," " - error stop 2 - end if - - call get_command_argument(1,f_in) - call get_command_argument(2,f_out) - - open(unit=10, file=trim(f_in), form='unformatted', convert="big_endian") - open(unit=20, file=trim(f_out), form='unformatted', convert="native") - - print *,'Converting File: ',trim(f_in) - - bpos=0 - do - read(10, end=100, err=200) ! skip to next record - epos = ftell(10) ! ending position of file pointer - backspace(10) - - rsize = (epos-bpos)/4-2 ! record size (in 4 byte words; - ! 2 is the number of fortran control words) - bpos=epos - allocate(var(rsize), stat=status) - if (status /= 0) then - print *, 'Error: allocation ', rsize, ' failed!' - error stop 11 - end if - - read (10) var - write(20) var - deallocate(var) - end do - -100 continue - close(10) - close(20) - stop - -200 print *,'Error reading file ',trim(f_in) - error stop 11 - -end diff --git a/GEOS_Util/post/tick.F b/GEOS_Util/post/tick.F deleted file mode 100644 index 0591133a..00000000 --- a/GEOS_Util/post/tick.F +++ /dev/null @@ -1,185 +0,0 @@ - program main - integer nymd - integer nhms - integer ndt - integer nargs - character*256, allocatable :: arg(:) - - nargs = command_argument_count() - if( nargs .lt.1 .or. nargs .gt.3 ) then - call usage - else - - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - - read( arg(1),*) nymd - nhms = 0 - ndt = 86400 - if( nargs.ge.2 ) read( arg(2),*) nhms - if( nargs.eq.3 ) read( arg(3),*) ndt - - call tick (nymd,nhms,ndt) - write(6,100) nymd,nhms - 100 format(i8.8,1x,i6.6) - - endif - stop - end - - subroutine usage - print * - print *, ' NAME' - print *, ' tick - Increments date and time' - print * - print *, ' SYNOPSIS' - print *, ' tick nymd [ nhms [nsecs] ]' - print * - print *, ' DESCRIPTION' - print *, ' Increments date (nymd) and time (nhms) by nsecs seconds.' - print *, ' By default, nhms = 000000 and nsecs = 86400 (one day).' - print * - print *, ' EXAMPLES' - print *, ' tick 20000228 ===> 20000229' - print *, ' tick 19990930 120000 ===> 19991001 120000' - print *, ' tick 19990930 060000 120 ===> 19990930 060200' - print * - stop - end - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - end subroutine tick - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end function nsecf - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end function nhmsf - - function incymd (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - RETURN - end function incymd diff --git a/GEOS_Util/post/time_ave.F b/GEOS_Util/post/time_ave.F deleted file mode 100644 index 80bcee27..00000000 --- a/GEOS_Util/post/time_ave.F +++ /dev/null @@ -1,1346 +0,0 @@ - program time_ave - - use ESMF - - use dynamics_lattice_module - use ieee_arithmetic, only: isnan => ieee_is_nan - implicit none - type ( dynamics_lattice_type ) lattice - -#ifdef mpi - include 'mpif.h' -#endif - - integer comm,myid,npes,ierror - integer imglobal - integer jmglobal - integer npex,npey - logical root - -c ********************************************************************** -c ********************************************************************** -c **** **** -c **** Program to create time-averaged HDF files **** -c **** **** -c ********************************************************************** -c ********************************************************************** - - integer im,jm,lm - - integer nymd, nhms - integer nymd0,nhms0 - integer nymdp,nhmsp - integer nymdm,nhmsm - integer ntod, ndt, ntods - integer month, year - integer monthp, yearp - integer monthm, yearm - integer begdate, begtime - integer enddate, endtime - - integer id,rc,sumrc,precision,timeinc,timeid - integer ntime,nvars,ngatts,ncvid,nvars2 - - character*256, allocatable :: arg(:) - character*256, allocatable :: fname(:) - character*256 template - character*256 name - character*256 ext - character*256 output, doutput, hdfile, rcfile - character*8 date0 - character*2 time0 - character*1 char - data output /'monthly_ave'/ - data rcfile /'NULL'/ - data doutput /'NULL'/ - data template/'NULL'/ - - integer n,m,nargs,L,nfiles,nv,km,mvars,mv,ndvars - - real plev,qming,qmaxg - real undef - real, allocatable :: lat(:) - real, allocatable :: lon(:) - real, allocatable :: lev(:) - real*8, allocatable :: lon2(:,:), lat2(:,:) - logical :: twoDimLat - real, allocatable :: vrange(:,:), vrange2(:,:) - real, allocatable :: prange(:,:), prange2(:,:) - integer, allocatable :: kmvar(:) , kmvar2(:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: nloc(:) - integer, allocatable :: iloc(:) - - character*256 title - character*256 source - character*256 contact - character*256 levunits - character*256, allocatable :: vname(:), vname2(:) - character*256, allocatable :: vtitle(:), vtitle2(:) - character*256, allocatable :: vunits(:), vunits2(:) - character*256, allocatable :: coords(:), coords2(:) - - real, allocatable :: qmin(:) - real, allocatable :: qmax(:) - real, allocatable :: dumz1(:,:) - real, allocatable :: dumz2(:,:) - real, allocatable :: dum(:,:,:) - real*8, allocatable :: q(:,:,:,:) - integer, allocatable :: ntimes(:,:,:,:) - - integer timinc,i,j,k,nmax,kbeg,kend,loc1,loc2 - integer nstar - logical defined, tend, first, strict, diurnal, mdiurnal, lquad, ldquad - logical ignore_nan - data first /.true./ - data strict /.true./ - - type(ESMF_Config) :: config - - integer, allocatable :: qloc(:,:) - character*256, allocatable :: quadratics(:,:) - character*256, allocatable :: quadtmp(:,:) - character*256, allocatable :: aliases(:,:) - character*256, allocatable :: aliastmp(:,:) - character*256 name1, name2, name3, dummy - integer nquad - integer nalias - logical, allocatable :: lzstar(:) - - integer NSECF, ntmin, ntcrit, nhmsf, nc - -C ********************************************************************** -C **** Initialization **** -C ********************************************************************** - - call timebeg ('main') - -#ifdef mpi - call mpi_init ( ierror ) ; comm = mpi_comm_world - call mpi_comm_rank ( comm,myid,ierror ) - call mpi_comm_size ( comm,npes,ierror ) - npex = nint ( sqrt( float(npes) ) ) - npey = npex - do while ( npex*npey .ne. npes ) - npex = npex-1 - npey = nint ( float(npes)/float(npex) ) - enddo - call ESMF_Initialize(logKindFlag=ESMF_LOGKIND_NONE, - . mpiCommunicator=MPI_COMM_WORLD, rc=rc) -#else - comm = 0 - npes = 1 - npex = 1 - npey = 1 - myid = 0 - call ESMF_Initialize(logKindFlag=ESMF_LOGKIND_NONE, rc=rc) -#endif - root = myid.eq.0 - -c Read Command Line Arguments -c --------------------------- - begdate = -999 - begtime = -999 - enddate = -999 - endtime = -999 - ndt = -999 - ntod = -999 - ntmin = -999 - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage(root) - else - lquad = .TRUE. - ldquad = .FALSE. - diurnal = .FALSE. - mdiurnal = .FALSE. - ignore_nan = .FALSE. - allocate ( arg(nargs) ) - do n=1,nargs - call get_command_argument(n,arg(n)) - enddo - do n=1,nargs - if( trim(arg(n)).eq.'-template' ) template = arg(n+1) - if( trim(arg(n)).eq.'-tag' ) output = arg(n+1) - if( trim(arg(n)).eq.'-rc' ) rcfile = arg(n+1) - if( trim(arg(n)).eq.'-begdate' ) read ( arg(n+1),* ) begdate - if( trim(arg(n)).eq.'-begtime' ) read ( arg(n+1),* ) begtime - if( trim(arg(n)).eq.'-enddate' ) read ( arg(n+1),* ) enddate - if( trim(arg(n)).eq.'-endtime' ) read ( arg(n+1),* ) endtime - if( trim(arg(n)).eq.'-ntmin' ) read ( arg(n+1),* ) ntmin - if( trim(arg(n)).eq.'-ntod' ) read ( arg(n+1),* ) ntod - if( trim(arg(n)).eq.'-ndt' ) read ( arg(n+1),* ) ndt - if( trim(arg(n)).eq.'-strict' ) read ( arg(n+1),* ) strict - if( trim(arg(n)).eq.'-noquad' ) lquad = .FALSE. - if( trim(arg(n)).eq.'-ignore_nan' ) ignore_nan = .TRUE. - - if( trim(arg(n)).eq.'-dv'.or. trim(arg(n)).eq.'-mdv') ldquad = .true. - - if( trim(arg(n)).eq.'-d' .or. trim(arg(n)).eq.'-dv' ) then - diurnal = .TRUE. - if( n+1.le.nargs ) then - read(arg(n+1),fmt='(a1)') char - if( char.ne.'-' ) doutput = arg(n+1) - endif - endif - - if( trim(arg(n)).eq.'-md' .or. trim(arg(n)).eq.'-mdv' ) then - mdiurnal = .TRUE. - if( n+1.le.nargs ) then - read(arg(n+1),fmt='(a1)') char - if( char.ne.'-' ) doutput = arg(n+1) - endif - endif - - if( trim(arg(n)).eq.'-eta' .or. - . trim(arg(n)).eq.'-hdf' ) then ! Backward compatable for old interface - nfiles = 1 - read(arg(n+nfiles),fmt='(a1)') char - do while (char.ne.'-' .and. n+nfiles.ne.nargs ) - nfiles = nfiles+1 - read(arg(n+nfiles),fmt='(a1)') char - enddo - if( char.eq.'-' ) nfiles = nfiles-1 - allocate ( fname(nfiles) ) - do m=1,nfiles - fname(m) = arg(n+m) - enddo - endif - - enddo - endif - - if( (diurnal.or.mdiurnal) .and. trim(doutput).eq.'NULL' ) then - doutput = trim(output) // "_diurnal" - if( mdiurnal ) diurnal = .FALSE. - endif - - if (ignore_nan) print *,' ignore nan is true' - - -c Read RC Quadratics -c ------------------ - if( trim(rcfile).eq.'NULL' ) then - nquad = 0 - nalias = 0 - else - - config = ESMF_ConfigCreate ( rc=rc ) - call ESMF_ConfigLoadFile ( config, trim(rcfile), rc=rc ) - call ESMF_ConfigFindLabel ( config, 'QUADRATICS:', rc=rc ) - tend = .false. - m = 0 - do while (.not.tend) - m = m+1 - allocate( quadtmp(3,m) ) - call ESMF_ConfigGetAttribute ( config,value=name1, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=name2, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=name3,default='XXX',rc=rc ) - call ESMF_ConfigNextLine ( config,tableEnd=tend, rc=rc ) - if( m==1 ) then - quadtmp(1,m) = name1 - quadtmp(2,m) = name2 - quadtmp(3,m) = name3 - allocate( quadratics(3,m) ) - quadratics = quadtmp - else - quadtmp(1,1:m-1) = quadratics(1,:) - quadtmp(2,1:m-1) = quadratics(2,:) - quadtmp(3,1:m-1) = quadratics(3,:) - quadtmp(1,m) = name1 - quadtmp(2,m) = name2 - quadtmp(3,m) = name3 - deallocate( quadratics ) - allocate( quadratics(3,m) ) - quadratics = quadtmp - endif - deallocate (quadtmp) - enddo - nquad = m - -c Read RC Aliases -c --------------- - call ESMF_ConfigFindLabel ( config, 'ALIASES:', rc=rc ) - tend = .false. - m = 0 - do while (.not.tend) - m = m+1 - allocate( aliastmp(2,m) ) - call ESMF_ConfigGetAttribute ( config,value=name1, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=name2, rc=rc ) - call ESMF_ConfigNextLine ( config,tableEnd=tend ,rc=rc ) - if( m==1 ) then - aliastmp(1,m) = name1 - aliastmp(2,m) = name2 - allocate( aliases(2,m) ) - aliases = aliastmp - else - aliastmp(1,1:m-1) = aliases(1,:) - aliastmp(2,1:m-1) = aliases(2,:) - aliastmp(1,m) = name1 - aliastmp(2,m) = name2 - deallocate( aliases ) - allocate( aliases(2,m) ) - aliases = aliastmp - endif - deallocate (aliastmp) - enddo - nalias = m - endif - -C ********************************************************************** -C **** Read HDF File **** -C ********************************************************************** - - call timebeg(' initialize') - - if( trim(template).ne.'NULL' ) then - name = template - else - name = fname(1) - endif - - n = index(trim(name),'.',back=.true.) - ext = trim(name(n+1:)) - - call gfio_open ( trim(name),1,ID,rc ) - call gfio_diminquireCF(id,imglobal,jmglobal,lm,ntime,nvars,ngatts,twoDimLat,rc) - nvars2 = nvars - - call create_dynamics_lattice ( lattice,npex,npey ) - call init_dynamics_lattice ( lattice,comm,imglobal,jmglobal,lm ) - - im = lattice%im( lattice%pei ) - jm = lattice%jm( lattice%pej ) - - allocate ( lon(imglobal) ) - allocate ( lat(jmglobal) ) - if (twoDimLat) then - allocate ( lon2(imglobal,jmglobal) ) - allocate ( lat2(imglobal,jmglobal) ) - endif - allocate ( lev(lm) ) - allocate ( yymmdd( ntime) ) - allocate ( hhmmss( ntime) ) - allocate ( vname( nvars) ) - allocate ( vtitle( nvars) ) - allocate ( vunits( nvars) ) - allocate ( kmvar( nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - allocate ( coords( nvars) ) - - call gfio_inquireCF ( id,imglobal,jmglobal,lm,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,coords, twoDimLat, lat2, lon2, rc) - call gfio_close ( id,rc ) - -c Set NDT for Strict Time Testing -c ------------------------------- - if( ntod.ne.-999 ) ndt = 86400 - if( ndt .eq.-999 ) ndt = nsecf (timinc) - if( timinc .eq. 0 ) then - timeId = ncvid (id, 'time', rc) - call ncagt (id, timeId, 'time_increment', timinc, rc) - if( timinc .eq. 0 ) then - if( root ) then - print * - print *, 'Warning, GFIO Inquire states TIMINC = ',timinc - print *, ' This will be reset to 060000 ' - print *, ' Use -ndt NNN (in seconds) to overide this' - endif - timinc = 060000 - endif - ndt = nsecf (timinc) - endif - -c Determine Number of Time Periods within 1-Day -c --------------------------------------------- - ntods = 0 - if( diurnal .or. mdiurnal ) then - if( ndt.lt.86400 ) ntods = 86400/ndt - endif - -c Set Minimum Required Times for Time Average (Default: 10 Days for Monthly Mean) -c ------------------------------------------------------------------------------- - if( ntmin.eq.-999 ) then - if( ntod.eq.-999 ) then - ntcrit = 10 * ( 86400.0/real(nsecf(timinc)) ) - else - ntcrit = 10 - endif - else - ntcrit = ntmin - endif - -c Determine Location Index for Each Variable in File -c -------------------------------------------------- - if( root ) print * - allocate ( nloc(nvars) ) - nloc(1) = 1 - if( root ) write(6,7000) 1,trim(vname(1)),nloc(1),trim(vtitle(1)),max(1,kmvar(1)) - do n=2,nvars - nloc(n) = nloc(n-1)+max(1,kmvar(n-1)) - if( root ) write(6,7000) n,trim(vname(n)),nloc(n),trim(vtitle(n)),max(1,kmvar(n)) - 7000 format(1x,'Primary Field: ',i4,' Name: ',a12,' at location: ',i4,3x,a40,2x,i2,3x,i2,3x,i2) - enddo - - nmax = nloc(nvars)+max(1,kmvar(nvars))-1 - allocate( dum (im,jm,nmax) ) - allocate( dumz1(im,jm) ) - allocate( dumz2(im,jm) ) - -c Append Default Quadratics to User-Supplied List -c ----------------------------------------------- - if( lquad ) then - if( nquad.eq.0 ) then - allocate( quadratics(3,nvars) ) - do n=1,nvars - quadratics(1,n) = trim( vname(n) ) - quadratics(2,n) = trim( vname(n) ) - quadratics(3,n) = 'XXX' - enddo - nquad = nvars - else - allocate( quadtmp(3,nquad+nvars) ) - quadtmp(1,1:nquad) = quadratics(1,:) - quadtmp(2,1:nquad) = quadratics(2,:) - quadtmp(3,1:nquad) = quadratics(3,:) - do n=1,nvars - quadtmp(1,nquad+n) = trim( vname(n) ) - quadtmp(2,nquad+n) = trim( vname(n) ) - quadtmp(3,nquad+n) = 'XXX' - enddo - nquad = nquad + nvars - deallocate( quadratics ) - allocate( quadratics(3,nquad) ) - quadratics = quadtmp - deallocate( quadtmp ) - endif - endif - - allocate ( qloc(2,nquad) ) - allocate ( lzstar(nquad) ) ; lzstar = .FALSE. - -c Determine Possible Quadratics -c ----------------------------- - km=kmvar(nvars) - m= nvars - do n=1,nquad - call check_quad ( quadratics(1,n),vname,nvars,aliases,nalias,qloc(1,n) ) - if( qloc(1,n)*qloc(2,n).ne.0 ) then - m=m+1 - allocate ( iloc(m) ) - iloc(1:m-1) = nloc - iloc(m) = iloc(m-1)+max(1,km) - deallocate ( nloc ) - allocate ( nloc(m) ) - nloc = iloc - deallocate ( iloc ) - km=kmvar( qloc(1,n) ) - endif - enddo - - mvars = m - nmax = nloc(m)+max(1,km)-1 - - allocate ( vname2( mvars) ) - allocate ( vtitle2( mvars) ) - allocate ( vunits2( mvars) ) - allocate ( kmvar2( mvars) ) - allocate ( vrange2(2,mvars) ) - allocate ( prange2(2,mvars) ) - allocate ( coords2( mvars) ) - - vname2( 1:nvars) = vname - vtitle2( 1:nvars) = vtitle - vunits2( 1:nvars) = vunits - kmvar2( 1:nvars) = kmvar - vrange2(:,1:nvars) = vrange - prange2(:,1:nvars) = prange - - coords2 = '' - coords2( 1:nvars) = coords - - if( root .and. mvars.gt.nvars ) print * - mv= nvars - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv = mv+1 - - if( trim(quadratics(1,nv)).eq.trim(quadratics(2,nv)) ) then - vname2(mv) = "Var_" // trim(vname(qloc(1,nv))) - vtitle2(mv) = "Variance_of_" // trim(vname(qloc(1,nv))) - else - vname2(mv) = "Cov_" // trim(vname(qloc(1,nv))) // "_" // trim(vname(qloc(2,nv))) - vtitle2(mv) = "Covariance_of_" // trim(vname(qloc(1,nv))) // "_and_" // trim(vname(qloc(2,nv))) - endif - - if( trim(quadratics(3,nv)).ne.'XXX' ) vname2(mv) = trim(quadratics(3,nv)) - - nstar = index( trim(quadratics(1,nv)),'star',back=.true. ) - if( nstar.ne.0 ) then - lzstar(nv) = .TRUE. - vtitle2(mv) = "Product_of_Zonal_Mean_Deviations_of_" - . // trim(vname(qloc(1,nv))) // "_and_" // trim(vname(qloc(2,nv))) - endif - - vunits2(mv) = trim(vunits(qloc(1,nv))) // " " // trim(vunits(qloc(2,nv))) - coords2(mv) = coords(qloc(1,nv)) - kmvar2(mv) = kmvar(qloc(1,nv)) - vrange2(:,mv) = undef - prange2(:,mv) = undef - if( root ) write(6,7001) mv,trim(vname2(mv)),nloc(mv),trim(vtitle2(mv)),max(1,kmvar(qloc(1,nv))),qloc(1,nv),qloc(2,nv) - 7001 format(1x,' Quad Field: ',i4,' Name: ',a12,' at location: ',i4,3x,a50,2x,i2,3x,i3,3x,i3) - endif - enddo - - deallocate ( lon ) - deallocate ( lat ) - deallocate ( lev ) - deallocate ( yymmdd ) - deallocate ( hhmmss ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( kmvar ) - deallocate ( vrange ) - deallocate ( prange ) - deallocate ( coords ) - - allocate( qmin(nmax) ) - allocate( qmax(nmax) ) - allocate( q(im,jm,nmax,0:ntods) ) - allocate( ntimes(im,jm,nmax,0:ntods) ) - ntimes = 0 - q = 0 - qmin = abs(undef) - qmax = -abs(undef) - - if( root ) then - print * - write(6,7002) mvars,nmax,im,jm,nmax,ntods - 7002 format(1x,'Total Number of Variables: ',i3,/ - . 1x,'Total Size: ',i5,/ - . 1x,'Allocating q(',i4,',',i3,',',i5,',0:',i2.2,')') - print * - print *, 'Files: ' - do n=1,nfiles - print *, n,trim(fname(n)) - enddo - print * - if( ntod.eq.-999 ) then - print *, 'Averging Time-Period NHMS: ',ntod,' (ALL Possible Time Periods Used)' - else - print *, 'Averging Time-Period NHMS: ',ntod - endif - if( begdate.ne.-999 .or. begtime.ne.-999 ) print *, 'Beginning Date for Averaging: ',begdate,begtime - if( enddate.ne.-999 .or. endtime.ne.-999 ) print *, ' Ending Date for Averaging: ',enddate,endtime - if( strict ) then - print *, 'Every Time Period Required for Averaging, STRICT = ',strict - else - print *, 'Only Averaging Time Periods Supplied, STRICT = ',strict - endif - write(6,7003) ntcrit - 7003 format(1x,'Required Minimum Number of Defined Time Periods: ',i3,' (Otherwise, UNDEF)') - print * - endif - - call timeend(' initialize') - -C ********************************************************************** -C **** Read HDF Files **** -C ********************************************************************** - - k = 0 - - do n=1,nfiles - if( root ) then - call gfio_open ( trim(fname(n)),1,ID,rc ) - call gfio_diminquireCF ( id,imglobal,jmglobal,lm,ntime,nvars,ngatts,twoDimLat,rc ) - endif - -#ifdef mpi - call mpi_bcast ( imglobal,1,mpi_integer,0,comm,ierror ) - call mpi_bcast ( jmglobal,1,mpi_integer,0,comm,ierror ) - call mpi_bcast ( lm,1,mpi_integer,0,comm,ierror ) - call mpi_bcast ( ntime,1,mpi_integer,0,comm,ierror ) - call mpi_bcast ( nvars,1,mpi_integer,0,comm,ierror ) -#endif - - allocate ( lon(imglobal) ) - allocate ( lat(jmglobal) ) - allocate ( lev(lm) ) - allocate ( yymmdd( ntime) ) - allocate ( hhmmss( ntime) ) - allocate ( vname( nvars) ) - allocate ( vtitle( nvars) ) - allocate ( vunits( nvars) ) - allocate ( kmvar( nvars) ) - allocate ( vrange(2,nvars) ) - allocate ( prange(2,nvars) ) - allocate ( coords( nvars) ) - - if( root ) then - call gfio_inquireCF ( id,imglobal,jmglobal,lm,ntime,nvars, - . title,source,contact,undef, - . lon,lat,lev,levunits, - . yymmdd,hhmmss,timinc, - . vname,vtitle,vunits,kmvar, - . vrange,prange,coords,twoDimLat, lat2, lon2, rc ) - endif - -#ifdef mpi - call mpi_bcast ( yymmdd,ntime,mpi_integer,0,comm,ierror ) - call mpi_bcast ( hhmmss,ntime,mpi_integer,0,comm,ierror ) - call mpi_bcast ( timinc,1, mpi_integer,0,comm,ierror ) - call mpi_bcast ( kmvar,nvars, mpi_integer,0,comm,ierror ) -#endif - - do m=1,ntime - nymd = yymmdd(m) - nhms = hhmmss(m) - if( nhms<0 ) then - nhms = nhmsf( nsecf(nhms) + 86400 ) - call tick (nymd,nhms,-86400) - endif - - if( ( begdate.ne.-999 .and. begtime.ne.-999 ) .and. - . ( begdate.gt.nymd .or. - . ( begdate.eq.nymd.and.begtime.gt.nhms ) ) ) cycle - - if( ( enddate.ne.-999 .and. endtime.ne.-999 ) .and. - . ( enddate.lt.nymd .or. - . ( enddate.eq.nymd.and.endtime.lt.nhms ) ) ) cycle - - k = k+1 - if( k.gt.ntods ) k = 1 - if( ntod.eq.-999 .or. ntod.eq.nhms ) then - if( root ) write(6,3000) nymd,nhms,timinc,trim(fname(n)),k - 3000 format(1x,'Reading nymd: ',i8.8,' nhms: ',i6.6,' TimInc: ',i6.6,' from File: ',a,' tod = ',i2) - year = nymd/10000 - month = mod(nymd,10000)/100 - -c Check for Correct First Dataset -c ------------------------------- - if( strict .and. first ) then - nymdm = nymd - nhmsm = nhms - call tick (nymdm,nhmsm,-ndt) - yearm = nymdm/10000 - monthm = mod(nymdm,10000)/100 - if( year.eq.yearm .and. month.eq.monthm ) then - if( root ) print *, 'Date: ',nymd,' Time: ',nhms,' is NOT correct First Time Period!' - call my_finalize - stop 1 - endif - endif - -c Check Date and Time for STRICT Time Testing -c ------------------------------------------- - if( strict .and. .not.first ) then - if( nymd.ne.nymdp .or. nhms.ne.nhmsp ) then - if( root ) print *, 'Date: ',nymdp,' Time: ',nhmsp,' not found!' - call my_finalize - stop 1 - endif - endif - nymdp = nymd - nhmsp = nhms - -c Primary Fields -c -------------- - do nv=1,nvars2 - call timebeg(' PRIME') - if( kmvar2(nv).eq.0 ) then - kbeg = 0 - kend = 1 - else - kbeg = 1 - kend = kmvar2(nv) - endif - call timeend(' PRIME') - - call mpi_gfio_getvar ( id,vname2(nv),nymd,nhms,im,jm,kbeg,kend,dum(1,1,nloc(nv)),lattice ) - - call timebeg(' PRIME') - rc = 0 - do L=1,max(1,kmvar2(nv)) - do j=1,jm - do i=1,im - if( isnan( dum(i,j,nloc(nv)+L-1) ). or. ( dum(i,j,nloc(nv)+L-1).gt.HUGE(dum(i,j,nloc(nv)+L-1)) ) ) then - print *, 'Warning! Nan or Infinity detected for ',trim(vname2(nv)), - . ' at lat: ',lattice%jglobal(j),' lon: ',lattice%iglobal(i) - if( ignore_nan ) then - print *, 'Setting Nan or Infinity to UNDEF' - print * - else - rc = 1 - endif - dum(i,j,nloc(nv)+L-1) = undef - endif - if( defined(dum(i,j,nloc(nv)+L-1),undef) ) then - q(i,j,nloc(nv)+L-1,0) = q(i,j,nloc(nv)+L-1,0) + dum(i,j,nloc(nv)+L-1) - ntimes(i,j,nloc(nv)+L-1,0) = ntimes(i,j,nloc(nv)+L-1,0) + 1 - if( qmin(nloc(nv)+L-1).gt.dum(i,j,nloc(nv)+L-1) ) qmin(nloc(nv)+L-1) = dum(i,j,nloc(nv)+L-1) - if( qmax(nloc(nv)+L-1).lt.dum(i,j,nloc(nv)+L-1) ) qmax(nloc(nv)+L-1) = dum(i,j,nloc(nv)+L-1) - if( ntods.ne.0 ) then - q(i,j,nloc(nv)+L-1,k) = q(i,j,nloc(nv)+L-1,k) + dum(i,j,nloc(nv)+L-1) - ntimes(i,j,nloc(nv)+L-1,k) = ntimes(i,j,nloc(nv)+L-1,k) + 1 - endif - endif - enddo - enddo - enddo - call timeend(' PRIME') - -#ifdef mpi - call mpi_allreduce ( rc,sumrc,1,mpi_integer,mpi_sum,lattice%comm,ierror ) - rc = sumrc -#endif - if( .not.ignore_nan .and. rc.ne.0 ) then - call my_finalize - stop 1 - endif - - enddo - -c Quadratics -c ---------- - call timebeg(' QUAD') - mv= nvars2 - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv=mv+1 - do L=1,max(1,kmvar2(qloc(1,nv))) - if( lzstar(nv) ) then - call zstar (dum(1,1,nloc(qloc(1,nv))+L-1),dumz1,im,jm,undef,lattice) - call zstar (dum(1,1,nloc(qloc(2,nv))+L-1),dumz2,im,jm,undef,lattice) - do j=1,jm - do i=1,im - if( defined(dumz1(i,j),undef) .and. - . defined(dumz2(i,j),undef) ) then - q(i,j,nloc(mv)+L-1,0) = q(i,j,nloc(mv)+L-1,0) + dumz1(i,j)*dumz2(i,j) - ntimes(i,j,nloc(mv)+L-1,0) = ntimes(i,j,nloc(mv)+L-1,0) + 1 - if( ntods.ne.0 ) then - q(i,j,nloc(mv)+L-1,k) = q(i,j,nloc(mv)+L-1,k) + dumz1(i,j)*dumz2(i,j) - ntimes(i,j,nloc(mv)+L-1,k) = ntimes(i,j,nloc(mv)+L-1,k) + 1 - endif - endif - enddo - enddo - else - do j=1,jm - do i=1,im - if( defined(dum(i,j,nloc(qloc(1,nv))+L-1),undef) .and. - . defined(dum(i,j,nloc(qloc(2,nv))+L-1),undef) ) then - q(i,j,nloc(mv)+L-1,0) = q(i,j,nloc(mv)+L-1,0) + dum(i,j,nloc(qloc(1,nv))+L-1) - . * dum(i,j,nloc(qloc(2,nv))+L-1) - ntimes(i,j,nloc(mv)+L-1,0) = ntimes(i,j,nloc(mv)+L-1,0) + 1 - if( ntods.ne.0 ) then - q(i,j,nloc(mv)+L-1,k) = q(i,j,nloc(mv)+L-1,k) + dum(i,j,nloc(qloc(1,nv))+L-1) - . * dum(i,j,nloc(qloc(2,nv))+L-1) - ntimes(i,j,nloc(mv)+L-1,k) = ntimes(i,j,nloc(mv)+L-1,k) + 1 - endif - endif - enddo - enddo - endif - enddo - endif - enddo - call timeend(' QUAD') - - if( first ) then - nymd0 = nymd - nhms0 = nhms - first = .false. - endif - -c Update Date and Time for Strict Test -c ------------------------------------ - call tick (nymdp,nhmsp,ndt) - yearp = nymdp/10000 - monthp = mod(nymdp,10000)/100 - - endif ! End ntod Test - enddo ! End ntime Loop within file - - if( root ) call gfio_close ( id,rc ) - if( n.ne.nfiles ) then - deallocate ( lon ) - deallocate ( lat ) - deallocate ( lev ) - deallocate ( yymmdd ) - deallocate ( hhmmss ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( kmvar ) - deallocate ( vrange ) - deallocate ( prange ) - deallocate ( coords ) - endif - - call my_barrier (comm) - enddo - - do k=0,ntods - if( k.eq.0 ) then - nc = ntcrit - else - nc = max( 1,ntcrit/ntods ) - endif - do n=1,nmax - do j=1,jm - do i=1,im - if( ntimes(i,j,n,k).lt.nc ) then - q(i,j,n,k) = undef - else - q(i,j,n,k) = q(i,j,n,k)/ntimes(i,j,n,k) - endif - enddo - enddo - enddo - enddo - -C ********************************************************************** -C **** Write HDF Monthly Output File **** -C ********************************************************************** - - call timebeg(' Write_AVE') - -c Check for Correct Last Dataset -c ------------------------------ - if( strict .and. ( year.eq.yearp .and. month.eq.monthp ) ) then - if( root ) print *, 'Date: ',nymd,' Time: ',nhms,' is NOT correct Last Time Period!' - call my_finalize - stop 1 - endif - - write(date0,4000) nymd0/100 - write(time0,2000) nhms0/10000 - - hdfile = trim(output) // "." // trim(date0) // "." // trim(ext) - - 1000 format(i8.8) - 2000 format(i2.2) - 4000 format(i6.6) - - precision = 1 ! 64-bit - precision = 0 ! 32-bit - timeinc = 060000 - if( root ) then - call GFIO_CreateCF ( trim(hdfile), title, source, contact, undef, - . imglobal, jmglobal, lm, lon, lat, lev, levunits, - . nymd0, nhms0, timeinc, - . mvars, vname2, vtitle2, vunits2, kmvar2, - . vrange2, prange2, precision, - . id, coords2, twoDimLat, lat2, lon2, rc ) - endif - -c Primary Fields -c -------------- - if( root ) print * - do n=1,nvars2 - if( kmvar2(n).eq.0 ) then - kbeg = 0 - kend = 1 - else - kbeg = 1 - kend = kmvar2(n) - endif - if( root ) write(6,3001) trim(vname2(n)),nloc(n),trim(hdfile) - 3001 format(1x,'Writing ',a,' at location ',i6,' into File: ',a) - dum(:,:,1:kend) = q(:,:,nloc(n):nloc(n)+kend-1,0) - call mpi_gfio_putVar ( id,trim(vname2(n)),nymd0,nhms0,im,jm,kbeg,kend,dum,lattice ) - enddo - -c Quadratics -c ---------- - mv= nvars2 - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv=mv+1 - if( root ) write(6,3001) trim(vname2(mv)),nloc(mv),trim(hdfile) - if( kmvar2(qloc(1,nv)).eq.0 ) then - kbeg = 0 - kend = 1 - else - kbeg = 1 - kend = kmvar2(qloc(1,nv)) - endif - loc1 = nloc( qloc(1,nv) ) - loc2 = nloc( qloc(2,nv) ) - if( .not.lzstar(nv) ) then - where( q(:,:,nloc(mv):nloc(mv)+kend-1,0).ne.undef ) - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,0) - q(:,:,loc1:loc1+kend-1,0) - . * q(:,:,loc2:loc2+kend-1,0) - elsewhere - dum(:,:,1:kend) = undef - endwhere - else - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,0) - endif - call mpi_gfio_putVar ( id,trim(vname2(mv)),nymd0,nhms0,im,jm,kbeg,kend,dum,lattice ) - endif - enddo - - if( root ) then - call gfio_close ( id,rc ) - print * - print *, 'Created: ',trim(hdfile) - print * - endif - call timeend(' Write_AVE') - -C ********************************************************************** -C **** Write HDF Monthly Diurnal Output File **** -C ********************************************************************** - - if( ntods.ne.0 ) then - call timebeg(' Write_Diurnal') - - precision = 1 ! 64-bit - precision = 0 ! 32-bit - timeinc = nhmsf( 86400/ntods ) - - do k=1,ntods - - if( k.eq.1 .or. mdiurnal ) then - - write(date0,4000) nymd0/100 - write(time0,2000) nhms0/10000 - - if( diurnal ) hdfile = trim(doutput) // "." // trim(date0) // "." // trim(ext) - if( mdiurnal ) hdfile = trim(doutput) // "." // trim(date0) // "_" // trim(time0) // "z." // trim(ext) - - if( ldquad ) then - ndvars = mvars ! Include Quadratics in Diurnal Files - else - ndvars = nvars2 ! Only Include Primary Fields in Diurnal Files (Default) - endif - if( root ) then - call GFIO_CreateCF ( trim(hdfile), title, source, contact, undef, - . imglobal, jmglobal, lm, lon, lat, lev, levunits, - . nymd0, nhms0, timeinc, - . ndvars, vname2(1:ndvars), vtitle2(1:ndvars), vunits2(1:ndvars), kmvar2(1:ndvars), - . vrange2(:,1:ndvars), prange2(:,1:ndvars), precision, - . id, coords2(1:ndvars), twoDimLat, lat2, lon2, rc ) - endif - endif - -c Primary Fields -c -------------- - do n=1,nvars2 - if( kmvar2(n).eq.0 ) then - kbeg = 0 - kend = 1 - else - kbeg = 1 - kend = kmvar2(n) - endif - dum(:,:,1:kend) = q(:,:,nloc(n):nloc(n)+kend-1,k) - call mpi_gfio_putVar ( id,trim(vname2(n)),nymd0,nhms0,im,jm,kbeg,kend,dum,lattice ) - enddo - -c Quadratics -c ---------- - if( ndvars.eq.mvars ) then - mv= nvars2 - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv=mv+1 - if( kmvar2(qloc(1,nv)).eq.0 ) then - kbeg = 0 - kend = 1 - else - kbeg = 1 - kend = kmvar2(qloc(1,nv)) - endif - loc1 = nloc( qloc(1,nv) ) - loc2 = nloc( qloc(2,nv) ) - if( .not.lzstar(nv) ) then - where( q(:,:,nloc(mv):nloc(mv)+kend-1,0).ne.undef ) - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,k) - q(:,:,loc1:loc1+kend-1,k) - . * q(:,:,loc2:loc2+kend-1,k) - elsewhere - dum(:,:,1:kend) = undef - endwhere - else - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,k) - endif - call mpi_gfio_putVar ( id,trim(vname2(mv)),nymd0,nhms0,im,jm,kbeg,kend,dum,lattice ) - endif - enddo - endif - - if( root .and. mdiurnal ) then - call gfio_close ( id,rc ) - print *, 'Created: ',trim(hdfile) - endif - call tick (nymd0,nhms0,ndt) - enddo - - if( root .and. diurnal ) then - call gfio_close ( id,rc ) - print *, 'Created: ',trim(hdfile) - endif - if( root ) print * - - call timeend(' Write_Diurnal') - endif - -C ********************************************************************** -C **** Write Min/Max Information **** -C ********************************************************************** - - if( root ) print * - do n=1,nvars2 - do L=1,max(1,kmvar2(n)) - if( kmvar2(n).eq.0 ) then - plev = 0 - else - plev = lev(L) - endif - -#ifdef mpi - call mpi_reduce( qmin(nloc(n)+L-1),qming,1,mpi_real,mpi_min,0,comm,ierror ) - call mpi_reduce( qmax(nloc(n)+L-1),qmaxg,1,mpi_real,mpi_max,0,comm,ierror ) -#else - qming = qmin(nloc(n)+L-1) - qmaxg = qmax(nloc(n)+L-1) -#endif - if( root ) then - if(L.eq.1) then - write(6,3101) trim(vname2(n)),plev,qming,qmaxg - else - write(6,3102) trim(vname2(n)),plev,qming,qmaxg - endif - endif - 3101 format(1x,'Primary Field: ',a20,' Level: ',f9.3,' Min: ',g15.8,' Max: ',g15.8) - 3102 format(1x,' ',a20,' Level: ',f9.3,' Min: ',g15.8,' Max: ',g15.8) - enddo - call my_barrier (comm) - if( root ) print * - enddo - if( root ) print * - -C ********************************************************************** -C **** Timing Information **** -C ********************************************************************** - - call timeend ('main') - if( root ) call timepri (6) - - call my_finalize - stop - end - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = abs(q-undef).gt.0.1*abs(undef) - return - end - - subroutine mpi_gfio_getvar ( id,name,nymd,nhms,im,jm,lbeg,lm,q,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer L,id,nymd,nhms,im,jm,img,jmg,lbeg,lm - real q(im,jm,lm) - real,allocatable :: glo(:,:,:) - character(*) name - integer rc - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg,lm) ) - call timebeg (' GetVar') - if( lattice%myid.eq.0 ) then - call gfio_getvar ( id,trim(name),nymd,nhms,img,jmg,lbeg,lm,glo,rc ) - endif - call timeend (' GetVar') - call timebeg (' Scatter') - do L=1,lm - call scatter_2d ( glo(1,1,L),q(1,1,L),lattice ) - enddo - call timeend (' Scatter') - deallocate ( glo ) - return - end - - subroutine mpi_gfio_putvar ( id,name,nymd,nhms,im,jm,lbeg,lm,q,lattice ) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer L,id,nymd,nhms,im,jm,img,jmg,lbeg,lm - real q(im,jm,lm) - real,allocatable :: glo(:,:,:) - character(*) name - integer rc - img = lattice%imglobal - jmg = lattice%jmglobal - allocate ( glo(img,jmg,lm) ) - call timebeg (' Gather') - do L=1,lm - call gather_2d ( glo(1,1,L),q(1,1,L),lattice ) - enddo - call timeend (' Gather') - call timebeg (' PutVar') - if( lattice%myid.eq.0 ) then - call gfio_putvar ( id,trim(name),nymd,nhms,img,jmg,lbeg,lm,glo,rc ) - endif - call timeend (' PutVar') - deallocate ( glo ) - return - end - - subroutine zstar (q,qp,im,jm,undef,lattice) - use dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,i,j - real q(im,jm),undef,qz(jm) - real qp(im,jm) - logical defined - call zmean ( q,qz,im,jm,undef,lattice ) - do j=1,jm - if( qz(j).eq. undef ) then - qp(:,j) = undef - else - do i=1,im - if( defined( q(i,j),undef) ) then - qp(i,j) = q(i,j) - qz(j) - else - qp(i,j) = undef - endif - enddo - endif - enddo - return - end - - subroutine check_quad ( quad,vname,nvars,aliases,nalias,qloc ) - implicit none - integer nvars, nalias, qloc(2) - character*256 quad(2), aliases(2,nalias), vname(nvars) - integer m,n - -c Initialize Location of Quadratics -c --------------------------------- - qloc = 0 - -c Check Quadratic Name against HDF Variable Names -c ----------------------------------------------- - do n=1,nvars - if( trim(vname(n)).eq.trim(quad(1)) ) qloc(1) = n - if( trim(vname(n)).eq.trim(quad(2)) ) qloc(2) = n - enddo - -c Check Quadratic Name against Aliases -c ------------------------------------ - do m=1,nalias - if( trim(quad(1)).eq.trim(aliases(1,m)) ) then - do n=1,nvars - if( trim(vname(n)).eq.trim(quad(1)) .or. - . trim(vname(n)).eq.trim(aliases(2,m)) ) then - qloc(1) = n - exit - endif - enddo - endif - if( trim(quad(2)).eq.trim(aliases(1,m)) ) then - do n=1,nvars - if( trim(vname(n)).eq.trim(quad(2)) .or. - . trim(vname(n)).eq.trim(aliases(2,m)) ) then - qloc(2) = n - exit - endif - enddo - endif - enddo - return - end - - function nsecf (nhms) -C*********************************************************************** -C Purpose -C Converts NHMS format to Total Seconds -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhms, nsecf - nsecf = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - return - end function nsecf - - function nhmsf (nsec) -C*********************************************************************** -C Purpose -C Converts Total Seconds to NHMS format -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - implicit none - integer nhmsf, nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - return - end function nhmsf - - subroutine tick (nymd,nhms,ndt) -C*********************************************************************** -C Purpose -C Tick the Date (nymd) and Time (nhms) by NDT (seconds) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - IF(NDT.NE.0) THEN - NSEC = NSECF(NHMS) + NDT - - IF (NSEC.GT.86400) THEN - DO WHILE (NSEC.GT.86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF - - IF (NSEC.EQ.86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF - - IF (NSEC.LT.00000) THEN - DO WHILE (NSEC.LT.0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF - - NHMS = NHMSF (NSEC) - ENDIF - - RETURN - end subroutine tick - - function incymd (NYMD,M) -C*********************************************************************** -C PURPOSE -C INCYMD: NYMD CHANGED BY ONE DAY -C MODYMD: NYMD CONVERTED TO JULIAN DATE -C DESCRIPTION OF PARAMETERS -C NYMD CURRENT DATE IN YYMMDD FORMAT -C M +/- 1 (DAY ADJUSTMENT) -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - LOGICAL LEAP - LEAP(NY) = MOD(NY,4).EQ.0 .AND. (MOD(NY,100).NE.0 .OR. MOD(NY,400).EQ.0) - -C*********************************************************************** -C - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = 29 - ENDIF - - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. LEAP(NY)) GO TO 20 - - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - 20 CONTINUE - INCYMD = NY*10000 + NM*100 + ND - RETURN - -C*********************************************************************** -C E N T R Y M O D Y M D -C*********************************************************************** - - ENTRY MODYMD (NYMD) - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) - - 40 CONTINUE - IF (NM.LE.1) GO TO 60 - NM = NM - 1 - ND = ND + NDPM(NM) - IF (NM.EQ.2 .AND. LEAP(NY)) ND = ND + 1 - GO TO 40 - - 60 CONTINUE - MODYMD = ND - RETURN - end function incymd - - subroutine usage(root) - logical root - if(root) then - write(6,100) - 100 format( "Usage: ",/,/ - . " time_ave.x -hdf Filenames (in HDF format)",/ - . " <-template TEMPLATE>" ,/ - . " <-tag TAG>" ,/ - . " <-rc RCFILE>" ,/ - . " <-ntod NTOD>" ,/ - . " <-ntmin NTMIN>" ,/ - . " <-strict STRICT>" ,/ - . " <-d>" ,/ - . " <-md>" ,/,/ - . "where:",/,/ - . " -hdf Filenames: Filenames (in HDF format) to average",/ - . " -template TEMPLATE: Filename to use as template if HDF files differ (default: 1st Filename)",/ - . " -begdate yyyymmdd: Optional Parameter for Date to Begin Averaging",/ - . " -begtime hhmmss: Optional Parameter for Time to Begin Averaging",/ - . " -enddate yyyymmdd: Optional Parameter for Date to End Averaging",/ - . " -endtime hhmmss: Optional Parameter for Time to End Averaging",/ - . " -tag TAG: Optional TAG for Output File (default: monthly_ave)",/ - . " -rc RCFILE: Optional Resource Filename for Quadratics (default: no quadratics)",/ - . " -ntod NTOD: Optional Time-Of-Day (HHMMSS) to average (default: all time periods)",/ - . " -ntmin NTMIN: Optional Parameter for Required Min. TimePeriods (default: 10 days equiv)",/ - . " -strict STRICT: Optional Logical Parameter for Strict Time Testing (default: .true.)",/ - . " -d DTAG: Optional Parameter to Create & Tag Monthly Mean Diurnal File ", - . "(all times included)",/ - . " -md DTAG: Optional Parameter to Create & Tag Multiple Monthly Mean Diurnal Files ", - . "(one time per file)",/ - . " -dv DTAG: Like -d but includes Diurnal Variances",/ - . " -mdv DTAG: Like -md but includes Diurnal variances",/ - . ) - endif - call my_finalize - stop - end - diff --git a/GEOS_Util/post/timer.F b/GEOS_Util/post/timer.F deleted file mode 100644 index cd2f0f82..00000000 --- a/GEOS_Util/post/timer.F +++ /dev/null @@ -1,173 +0,0 @@ - subroutine timebeg (task) -C*********************************************************************** -C Purpose -C ------- -C Utility to Begin Timing of Task -C -C Argument Description -C -------------------- -C task ...... Character String (<=*10) for Timed Process -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - character*(*) task - include 'timer.com' - - integer n - real wclk - logical first - data first /.true./ - - if(first) then - -c Initialize Task Timings to Zero -c ------------------------------- - do n=1,maxtask - cputot(n) = 0.0 ! Total Accumulated Time for Task - cpuins(n) = 0.0 ! Accumulated Time for Task since last Print - ntot(n) = 0 ! Total Number of Calls for Task - nins(n) = 0 ! Number of Calls for Task since last Print - enddo - -c Set First Task -c -------------- - call clocks ( wclk ) - ntasks = 1 - tasks(1) = task - cputot(1) = -wclk - cpuins(1) = -wclk - else - -c Set Subsequent Tasks -c -------------------- - n = 1 - do while (task.ne.tasks(n) .and. n.le.ntasks) - n = n+1 - enddo - if( n.gt.ntasks) then - ntasks = ntasks+1 - if(ntasks.gt.maxtask ) then - print *, 'Too many Timing Tasks are Set!!' - print *, 'Maximum Number of Tasks = ',maxtask -#if mpi - call mpi_finalize (n) -#endif - error stop 101 - endif - call clocks ( wclk ) - tasks(ntasks) = task - cputot(ntasks) = cputot(ntasks)-wclk - cpuins(ntasks) = cpuins(ntasks)-wclk - else - call clocks ( wclk ) - cputot(n) = cputot(n)-wclk - cpuins(n) = cpuins(n)-wclk - endif - - endif - - first = .false. - return - end - - subroutine timeend (task) -C*********************************************************************** -C Purpose -C ------- -C Utility to End Timing of Task -C -C Argument Description -C -------------------- -C task ...... Character String (<=*10) for Timed Process -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - character*(*) task - include 'timer.com' - - integer n - real wclk - - n = 1 - do while (task.ne.tasks(n) .and. n.le.ntasks) - n = n+1 - enddo - if( n.gt.ntasks) then - print *, 'No Begining Timing Task found for: ',task -#if mpi - call mpi_finalize (n) -#endif - error stop 101 - endif - - call clocks ( wclk ) - cputot(n) = cputot(n)+wclk - cpuins(n) = cpuins(n)+wclk - ntot(n) = ntot(n)+1 - nins(n) = nins(n)+1 - - return - end - - subroutine timepri (ku) -C*********************************************************************** -C Purpose -C ------- -C Utility to Print Taks Timings -C -C Argument Description -C -------------------- -C ku ........ Output Unit Number -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - include 'timer.com' - - integer n,ku - real cpuinscall,cputotcall,ratins,rattot - - write(ku,1000) - do n=1,ntasks - cpuinscall = 0.0 - cputotcall = 0.0 - if( nins(n).ne.0 ) cpuinscall = cpuins(n)/nins(n) - if( ntot(n).ne.0 ) cputotcall = cputot(n)/ntot(n) - ratins = cpuins(n)/cpuins(1)*100 - rattot = cputot(n)/cputot(1)*100 - write(ku,2000) tasks(n),cpuins(n),ratins,nins(n),cpuinscall, - . cputot(n),rattot,ntot(n),cputotcall - enddo - write(ku,3000) - - do n=1,ntasks - cpuins(n) = 0.0 - nins(n) = 0 - enddo - - 1000 format(/,' *************************************************************************************************************', - . /,' ****************** Timings on the Root Processor ******************', - . /,' *************************************************************************************************************', - . /,' NAME CPU (sec) %Main Calls CPU/Call Total CPU %Main Calls Tot CPU/Call', - . /,' -------------------------------------------------------------------------------------------------------------',/) - 2000 format(2x,a20,2x,f9.2,3x,f6.2,2x,i8,3x,f9.4,4x,f9.2,3x,f6.2,2x,i8,3x,f9.4) - 3000 format(/,' *************************************************************************************************************',/) - - return - end - - subroutine clocks ( WCLK ) - real*4 wclk - integer(4) :: ic4,crate4,cmax4 - call system_clock(count=ic4,count_rate=crate4,count_max=cmax4) - wclk = ic4*0.0001 - RETURN - END diff --git a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/check.F90 b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/check.F90 deleted file mode 100644 index 7f3f9dbb..00000000 --- a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/check.F90 +++ /dev/null @@ -1,13 +0,0 @@ - SUBROUTINE check(status) - USE netcdf - INTEGER, INTENT (INOUT) :: status - IF (status /= nf90_noerr) THEN - - PRINT *, TRIM(nf90_strerror(status)) - PRINT *, "OPS: ERROR in reading NetCDF file for SST & SIC BCs" - PRINT *, "NO SST and ICE Boundary Conditions!" - error stop 99 - - - END IF - END SUBROUTINE check diff --git a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/lake_data_EIGTHdeg.F90 b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/lake_data_EIGTHdeg.F90 deleted file mode 100644 index 82bcd68a..00000000 --- a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/lake_data_EIGTHdeg.F90 +++ /dev/null @@ -1,235 +0,0 @@ -! -PROGRAM lake_data_EIGTHdeg -!--------------------------------------------------------------------------- - IMPLICIT NONE - - INTEGER, PARAMETER :: iDebug = 0 - - REAL, PARAMETER :: myUNDEF = 1.0e15 - REAL, PARAMETER :: TempLow = 273.15d0 ! low sst (in deg K) below which there is ice - REAL, PARAMETER :: Ice_thr = 1.0e-4 ! threshold on ice concentration- related to TempLow - - INTEGER, PARAMETER :: reynolds_NLAT = 720 - INTEGER, PARAMETER :: reynolds_NLON = 1440 - - INTEGER, PARAMETER :: ostia_NLAT = 3600 - INTEGER, PARAMETER :: ostia_NLON = 7200 - - CHARACTER (LEN = 100) :: inputBuffer, inputFile - CHARACTER (LEN = 150) :: fileNames(2) - CHARACTER (LEN = 8) :: today, tomrw - - CHARACTER (LEN = 150) :: fileName_Reynolds, fileName_Ostia - CHARACTER (LEN = 40) :: fileName_ostia_SST, fileName_ostia_ICE - CHARACTER (LEN = 40) :: fileName_mask - - INTEGER :: iERR, iMerra - INTEGER :: NLAT_out - INTEGER :: NLON_out - INTEGER :: iLon, iLat - INTEGER :: iAdjust_SST_SIC - REAL :: SST_thr ! threshold on SST- above which we "expect" no sea-ice - - REAL :: reynolds_LAT (reynolds_NLAT), reynolds_LON(reynolds_NLON) - REAL :: reynolds_SST_native (reynolds_NLON, reynolds_NLAT) - REAL :: reynolds_ICE_native (reynolds_NLON, reynolds_NLAT) - - REAL, ALLOCATABLE :: reynolds_SST_eigth(:,:), reynolds_ICE_eigth(:,:) - REAL, ALLOCATABLE :: ostia_SST_native (:,:), ostia_SST_eigth (:,:) - REAL, ALLOCATABLE :: ostia_ICE_native (:,:), ostia_ICE_eigth (:,:) - REAL, ALLOCATABLE :: mask(:,:) - - REAL :: HEADER(14) - CHARACTER(LEN = 4) :: today_Year, tomrw_Year - CHARACTER(LEN = 2) :: today_Mon, tomrw_Mon, today_Day, tomrw_Day - INTEGER :: today_iYear, tomrw_iYear - INTEGER :: today_iMon, tomrw_iMon, today_iDay, tomrw_iDay -! .................................................................... - -!--------------------------------------------------------------------------- -! Read all input data parameters (time to proc, files to proc, output resolution) - CALL get_command_argument(1,inputBuffer) - READ(inputBuffer, *) inputFile - CALL read_input(inputFile, iDebug, today, tomrw, fileNames, NLAT_out, NLON_out, iMerra, iAdjust_SST_SIC, SST_Thr, iERR) -!--------------------------------------------------------------------------- - IF( iERR == 0) THEN - PRINT *, 'Data over Great Lakes and Caspian Sea' - PRINT *, 'Processing SST and ICE data from: ', today, '...To... ', tomrw - ELSE - PRINT *, 'User input is not in correct format- for this program to work!' - PRINT *, 'SEE ABOVE LOG FOR DETAILS' - STOP - END IF - - fileName_Reynolds = fileNames(1) - fileName_Ostia = fileNames(2) -!------------------------------Read input files---------------------------- -! Read Reynolds -! SST -> reynolds_SST_native -! Ice concentration -> reynolds_ICE_native - CALL read_Reynolds(fileName_Reynolds, reynolds_NLAT, reynolds_NLON, & - reynolds_LAT, reynolds_LON, & - reynolds_SST_native, reynolds_ICE_native, myUNDEF) - -! Read Ostia -! SST -> ostia_SST_native -! Ice concentration -> ostia_ICE_native - ALLOCATE( ostia_SST_native(ostia_NLON, ostia_NLAT) ) - ALLOCATE( ostia_ICE_native(ostia_NLON, ostia_NLAT) ) - CALL read_Ostia( fileName_Ostia, "analysed_sst", ostia_NLAT, ostia_NLON, ostia_SST_native, myUNDEF ) - CALL read_Ostia( fileName_Ostia, "sea_ice_fraction", ostia_NLAT, ostia_NLON, ostia_ICE_native, myUNDEF ) - -!------------------------------Process SST & ICE fields-------------------- -! reynolds ice has undef in open water as well. make that to 0. - WHERE( (reynolds_SST_native .ne. myUNDEF) .and. (reynolds_ICE_native == myUNDEF)) - reynolds_ICE_native = 0.0d0 - END WHERE - -! Reynolds(SST, ICE): (1) flip, (2) interp to 1/8 deg - ALLOCATE( reynolds_SST_eigth(NLON_out, NLAT_out )) - ALLOCATE( reynolds_ICE_eigth(NLON_out, NLAT_out )) - - CALL hflip ( reynolds_SST_native, reynolds_NLON, reynolds_NLAT ) - CALL hflip ( reynolds_ICE_native, reynolds_NLON, reynolds_NLAT ) - - CALL interp_to_eight_deg( reynolds_SST_native, reynolds_NLON, reynolds_NLAT, & - reynolds_SST_eigth, NLON_out, NLAT_out, myUNDEF) - CALL interp_to_eight_deg( reynolds_ICE_native, reynolds_NLON, reynolds_NLAT, & - reynolds_ICE_eigth, NLON_out, NLAT_out, myUNDEF) - -!--------------------------------------------------------------------------- - ALLOCATE( ostia_SST_eigth(NLON_out, NLAT_out )) - ALLOCATE( ostia_ICE_eigth(NLON_out, NLAT_out )) - ALLOCATE( mask (NLON_out, NLAT_out )) - -! Initialize - mask = 0. - -! Ostia(SST, ICE): bin to 1/8 deg. - CALL bin2bin( ostia_SST_native, ostia_NLON, ostia_NLAT, ostia_SST_eigth, NLON_out, NLAT_out, myUNDEF ) - CALL bin2bin( ostia_ICE_native, ostia_NLON, ostia_NLAT, ostia_ICE_eigth, NLON_out, NLAT_out, myUNDEF ) -!--------------------------------------------------------------------------- -! Get Great Lakes SST and ICE from Reynolds into OSTIA (if needed) - DO iLat = 1046, 1120 - DO iLon = 695, 842 - - mask(iLon,iLat) = 1.0 - - IF( (ostia_SST_eigth(iLon,iLat).eq.myUNDEF) .and. (reynolds_SST_eigth(iLon,iLat).ne.myUNDEF) ) THEN - ostia_SST_eigth(iLon,iLat) = reynolds_SST_eigth(iLon,iLat) - END IF - - IF( (ostia_ICE_eigth(iLon,iLat).eq.myUNDEF) .and. (reynolds_ICE_eigth(iLon,iLat).ne.myUNDEF) ) THEN - ostia_ICE_eigth(iLon,iLat) = reynolds_ICE_eigth(iLon,iLat) ! if OSTIA had no ice in Great Lakes, get data from Reynolds - END IF - END DO - END DO -!--------------------------------------------------------------------------- -! Caspian Sea ice: there is no ice info in OSTIA ICE, when temp < freezing point, fix this problem. - DO iLat = 1000, 1120 - DO iLon = 1800, 1890 - - mask(iLon,iLat) = 1.0 - - ! 1st. handle SST. if OSTIA SST = undef, then use Reynolds SST - IF( (ostia_SST_eigth(iLon,iLat).eq.myUNDEF) .and. (reynolds_SST_eigth(iLon,iLat).ne.myUNDEF) ) THEN - ostia_SST_eigth(iLon,iLat) = reynolds_SST_eigth(iLon,iLat) - END IF - - ! if sst < freezing temp - IF( ostia_SST_eigth(iLon,iLat) <= 275.0d0) THEN - ! if there is no ice data or ice ~ 0.0 - IF( (ostia_ICE_eigth(iLon,iLat) .eq. myUNDEF) .or. (ostia_ICE_eigth(iLon,iLat) <= Ice_thr)) THEN - IF( (reynolds_ICE_eigth(iLon,iLat) .ne. myUNDEF) .and. (reynolds_ICE_eigth(iLon,iLat) > Ice_thr)) THEN - ostia_ICE_eigth(iLon,iLat) = reynolds_ICE_eigth(iLon,iLat) ! use Reynolds ice - ELSE ! there is nothing useful from Reynolds, use empirical fit - ! this could be computed based on SST from OSTIA/Reynolds. - ostia_ICE_eigth(iLon,iLat) = MIN( 1.0d0, MAX(-0.017451*((ostia_SST_eigth(iLon,iLat)- 271.38)/0.052747) + 0.96834, 0.0d0)) - END IF - END IF - END IF ! IF( ostia_SST_eigth(iLon,iLat) <= 275.0d0) - END DO - END DO -!--------------------------------------------------------------------------- - - IF ( iAdjust_SST_SIC == 1) THEN -! adjust SIC based on a threshold value of SST - WHERE (ostia_SST_eigth > SST_Thr) - ostia_ICE_eigth = 0.0d0 - END WHERE - END IF -!--------------------------------------------------------------------------- - -! get rid of the masked values - WHERE( (ostia_SST_eigth <= 260.) .or. (ostia_SST_eigth >= 330.)) - ostia_SST_eigth = -999. - ENDWHERE - - WHERE (ostia_SST_eigth == -999.) - ostia_ICE_eigth = -999. - ENDWHERE - - WHERE( (ostia_ICE_eigth < 0.0) .or. (ostia_ICE_eigth > 1.0)) - ostia_ICE_eigth = -999. - ENDWHERE -!--------------------------------------------------------------------------- - -! Header info. Start & end dates: format: YYYYMMDDHHMMSS; Hour,min,Sec are set to zero. - today_Year = today(1:4); tomrw_Year = tomrw(1:4) - today_Mon = today(5:6); tomrw_Mon = tomrw(5:6) - today_Day = today(7:8); tomrw_Day = tomrw(7:8) - - READ( today_Year, 98) today_iYear - READ( tomrw_Year, 98) tomrw_iYear - - READ( today_Mon, 99) today_iMon - READ( tomrw_Mon, 99) tomrw_iMon - - READ( today_Day, 99) today_iDay - READ( tomrw_Day, 99) tomrw_iDay - - HEADER(1) = REAL(today_iYear); HEADER(7) = REAL(tomrw_iYear) - HEADER(2) = REAL(today_iMon); HEADER(8) = REAL(tomrw_iMon) - HEADER(3) = REAL(today_iDay); HEADER(9) = REAL(tomrw_iDay) - HEADER(4:6) = 0.0; HEADER(10:12) = 0.0 - - HEADER(13) = REAL(NLON_out); HEADER(14) = REAL(NLAT_out) -!--------------------------------------------------------------------------- -! Write out for OSTIA fields for FP & RPIT -! SST, ICE: - fileName_ostia_SST = 'Ostia_sst_' // today //'.bin' - fileName_ostia_ICE = 'Ostia_ice_' // today //'.bin' - fileName_mask = 'mask' //'.bin' - - OPEN (UNIT = 991, FILE = fileName_ostia_SST, FORM = 'unformatted', STATUS = 'new') - OPEN (UNIT = 992, FILE = fileName_ostia_ICE, FORM = 'unformatted', STATUS = 'new') - OPEN (UNIT = 993, FILE = fileName_mask, FORM = 'unformatted', STATUS = 'new') - - WRITE(991) HEADER - WRITE(992) HEADER - WRITE(993) HEADER - WRITE(991) ostia_SST_eigth - WRITE(992) ostia_ICE_eigth - WRITE(993) mask - CLOSE(991) - CLOSE(992) - CLOSE(993) -!--------------------------------------------------------------------------- - IF( iERR == 0) PRINT *, '...Finished!' -!--------------------------------------------------------------------------- - 98 FORMAT(I4) - 99 FORMAT(I4) -!--------------------------------------------------------------------------- - DEALLOCATE(reynolds_SST_eigth) - DEALLOCATE(reynolds_ICE_eigth) - - DEALLOCATE(ostia_SST_native) - DEALLOCATE(ostia_ICE_native) - - DEALLOCATE(mask) - - DEALLOCATE(ostia_ICE_eigth) - DEALLOCATE(ostia_SST_eigth) -!--------------------------------------------------------------------------- -END PROGRAM lake_data_EIGTHdeg -! diff --git a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI.F90 b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI.F90 deleted file mode 100644 index ab38128c..00000000 --- a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI.F90 +++ /dev/null @@ -1,355 +0,0 @@ -! -PROGRAM proc_SST_FRACI -!--------------------------------------------------------------------------- - IMPLICIT NONE - - INTEGER, PARAMETER :: iDebug = 0 - - REAL, PARAMETER :: myUNDEF = 1.0e15 - REAL, PARAMETER :: TempLow = 273.15d0 ! low sst (in deg K) below which there is ice - REAL, PARAMETER :: Ice_thr = 1.0e-4 ! threshold on ice concentration- related to TempLow - - INTEGER, PARAMETER :: reynolds_NLAT = 720 - INTEGER, PARAMETER :: reynolds_NLON = 1440 - - INTEGER, PARAMETER :: ostia_NLAT = 3600 - INTEGER, PARAMETER :: ostia_NLON = 7200 - - CHARACTER (LEN = 100) :: inputBuffer, inputFile - CHARACTER (LEN = 150) :: fileNames(2) - CHARACTER (LEN = 8) :: today, tomrw - - CHARACTER (LEN = 150) :: fileName_Reynolds, fileName_Ostia - - CHARACTER (LEN = 40) :: fileName_reynolds_SST, fileName_reynolds_ICE - CHARACTER (LEN = 40) :: fileName_ostia_SST, fileName_ostia_ICE - - INTEGER :: iERR, iMerra - INTEGER :: NLAT_out - INTEGER :: NLON_out - INTEGER :: iLon, iLat, k - INTEGER :: iAdjust_SST_SIC - REAL :: SST_thr ! threshold on SST- above which we "expect" no sea-ice - - REAL :: reynolds_LAT (reynolds_NLAT), reynolds_LON(reynolds_NLON) - REAL :: reynolds_SST_native (reynolds_NLON, reynolds_NLAT) - REAL :: reynolds_ICE_native (reynolds_NLON, reynolds_NLAT) - - REAL, ALLOCATABLE :: reynolds_SST_eigth(:,:), reynolds_ICE_eigth(:,:) - REAL, ALLOCATABLE :: ostia_SST_native (:,:), ostia_SST_eigth (:,:) - REAL, ALLOCATABLE :: ostia_ICE_native (:,:), ostia_ICE_eigth (:,:) - - REAL :: sstave, diff_SST, diff_ICE - - REAL :: HEADER(14) - CHARACTER(LEN = 4) :: today_Year, tomrw_Year - CHARACTER(LEN = 2) :: today_Mon, tomrw_Mon, today_Day, tomrw_Day - INTEGER :: today_iYear, tomrw_iYear - INTEGER :: today_iMon, tomrw_iMon, today_iDay, tomrw_iDay -! .................................................................... - -!--------------------------------------------------------------------------- -! Read all input data parameters (time to proc, files to proc, output resolution) - CALL get_command_argument(1,inputBuffer) - READ(inputBuffer, *) inputFile - CALL read_input(inputFile, iDebug, today, tomrw, fileNames, NLAT_out, NLON_out, iMerra, iAdjust_SST_SIC, SST_Thr, iERR) -!--------------------------------------------------------------------------- - IF( iERR == 0) THEN - PRINT *, 'Processing SST and ICE data from: ', today, '...To... ', tomrw - ELSE - PRINT *, 'User input is not in correct format- for this program to work!' - PRINT *, 'SEE ABOVE LOG FOR DETAILS' - STOP - END IF - - fileName_Reynolds = fileNames(1) - fileName_Ostia = fileNames(2) -!------------------------------Read input files---------------------------- -! Read Reynolds -! SST -> reynolds_SST_native -! Ice concentration -> reynolds_ICE_native - CALL read_Reynolds(fileName_Reynolds, reynolds_NLAT, reynolds_NLON, & - reynolds_LAT, reynolds_LON, & - reynolds_SST_native, reynolds_ICE_native, myUNDEF) - -! Read Ostia -! SST -> ostia_SST_native -! Ice concentration -> ostia_ICE_native - ALLOCATE( ostia_SST_native(ostia_NLON, ostia_NLAT) ) - ALLOCATE( ostia_ICE_native(ostia_NLON,ostia_NLAT) ) - CALL read_Ostia( fileName_Ostia, "analysed_sst", ostia_NLAT, ostia_NLON, ostia_SST_native, myUNDEF ) - CALL read_Ostia( fileName_Ostia, "sea_ice_fraction", ostia_NLAT, ostia_NLON, ostia_ICE_native, myUNDEF ) - -!------------------------------Process SST & ICE fields-------------------- -! reynolds ice has undef in open water as well. make that to 0. - WHERE( (reynolds_SST_native .ne. myUNDEF) .and. (reynolds_ICE_native == myUNDEF)) - reynolds_ICE_native = 0.0d0 - END WHERE - -! Reynolds(SST, ICE): (1) flip, (2) interp to 1/8 deg - ALLOCATE( reynolds_SST_eigth(NLON_out, NLAT_out )) - ALLOCATE( reynolds_ICE_eigth(NLON_out, NLAT_out )) - - CALL hflip ( reynolds_SST_native, reynolds_NLON, reynolds_NLAT ) - CALL hflip ( reynolds_ICE_native, reynolds_NLON, reynolds_NLAT ) - - CALL interp_to_eight_deg( reynolds_SST_native, reynolds_NLON, reynolds_NLAT, & - reynolds_SST_eigth, NLON_out, NLAT_out, myUNDEF) - CALL interp_to_eight_deg( reynolds_ICE_native, reynolds_NLON, reynolds_NLAT, & - reynolds_ICE_eigth, NLON_out, NLAT_out, myUNDEF) - -!--------------------------------------------------------------------------- -! Ostia(SST, ICE): bin to 1/8 deg. - ALLOCATE( ostia_SST_eigth(NLON_out, NLAT_out )) - ALLOCATE( ostia_ICE_eigth(NLON_out, NLAT_out )) - - CALL bin2bin( ostia_SST_native, ostia_NLON, ostia_NLAT, ostia_SST_eigth, NLON_out, NLAT_out, myUNDEF ) - CALL bin2bin( ostia_ICE_native, ostia_NLON, ostia_NLAT, ostia_ICE_eigth, NLON_out, NLAT_out, myUNDEF ) -!--------------------------------------------------------------------------- -! Get Great Lakes SST and ICE from Reynolds into OSTIA (if needed) - DO iLat = 1046, 1120 - DO iLon = 695, 842 - IF( (ostia_SST_eigth(iLon,iLat).eq.myUNDEF) .and. (reynolds_SST_eigth(iLon,iLat).ne.myUNDEF) ) THEN - ostia_SST_eigth(iLon,iLat) = reynolds_SST_eigth(iLon,iLat) - END IF - - IF( (ostia_ICE_eigth(iLon,iLat).eq.myUNDEF) .and. (reynolds_ICE_eigth(iLon,iLat).ne.myUNDEF) ) THEN - ostia_ICE_eigth(iLon,iLat) = reynolds_ICE_eigth(iLon,iLat) ! if OSTIA had no ice in Great Lakes, get data from Reynolds - END IF - END DO - END DO -!--------------------------------------------------------------------------- -! Caspian Sea ice: there is no ice info in OSTIA ICE, when temp < freezing point, fix this problem. - DO iLat = 1000, 1120 - DO iLon = 1800, 1890 - - ! 1st. handle SST. if OSTIA SST = undef, then use Reynolds SST - IF( (ostia_SST_eigth(iLon,iLat).eq.myUNDEF) .and. (reynolds_SST_eigth(iLon,iLat).ne.myUNDEF) ) THEN - ostia_SST_eigth(iLon,iLat) = reynolds_SST_eigth(iLon,iLat) - END IF - - ! if sst < freezing temp - IF( ostia_SST_eigth(iLon,iLat) <= 275.0d0) THEN - ! if there is no ice data or ice ~ 0.0 - IF( (ostia_ICE_eigth(iLon,iLat) .eq. myUNDEF) .or. (ostia_ICE_eigth(iLon,iLat) <= Ice_thr)) THEN - IF( (reynolds_ICE_eigth(iLon,iLat) .ne. myUNDEF) .and. (reynolds_ICE_eigth(iLon,iLat) > Ice_thr)) THEN - ostia_ICE_eigth(iLon,iLat) = reynolds_ICE_eigth(iLon,iLat) ! use Reynolds ice - ELSE ! there is nothing useful from Reynolds, use empirical fit - ! this could be computed based on SST from OSTIA/Reynolds. - ostia_ICE_eigth(iLon,iLat) = MIN( 1.0d0, MAX(-0.017451*((ostia_SST_eigth(iLon,iLat)- 271.38)/0.052747) + 0.96834, 0.0d0)) - END IF - END IF - - IF( iDebug /= 0 ) PRINT *, ostia_SST_eigth(iLon,iLat), ostia_ICE_eigth(iLon,iLat) - END IF ! IF( ostia_SST_eigth(iLon,iLat) <= 275.0d0) - - IF( reynolds_SST_eigth(iLon,iLat) <= 275.0d0) THEN - IF( (reynolds_ICE_eigth(iLon,iLat) .eq. myUNDEF) .or. (reynolds_ICE_eigth(iLon,iLat) <= Ice_thr)) & - reynolds_ICE_eigth(iLon,iLat) = MIN( 1.0d0, MAX(-0.017451*((reynolds_SST_eigth(iLon,iLat)- 271.38)/0.052747) + 0.96834, 0.0d0)) - END IF - - END DO - END DO -! - IF( iMerra == 1) THEN -! only needed for CASPIAN, because Reynolds has sst & ice in Great Lakes! - DO iLat = 500, 560 - DO iLon = 900, 945 - IF( reynolds_SST_native(iLon,iLat) <= 275.0d0) THEN - IF( (reynolds_ICE_native(iLon,iLat) .eq. myUNDEF) .or. (reynolds_ICE_native(iLon,iLat) <= Ice_thr)) & - reynolds_ICE_native(iLon,iLat) = MIN( 1.0d0, MAX(-0.017451*((reynolds_SST_native(iLon,iLat)- 271.38)/0.052747) + 0.96834, 0.0d0)) - END IF - END DO - END DO - END IF -!--------------------------------------------------------------------------- -! Fill up values over land - - CALL fill_Land (ostia_SST_eigth, NLON_out, NLAT_out, myUNDEF) - CALL fill_Land (ostia_ICE_eigth, NLON_out, NLAT_out, myUNDEF) - - CALL fill_Land (reynolds_SST_eigth, NLON_out, NLAT_out, myUNDEF) - CALL fill_Land (reynolds_ICE_eigth, NLON_out, NLAT_out, myUNDEF) - - IF( iMerra == 1) THEN - CALL fill_Land (reynolds_SST_native, reynolds_NLON, reynolds_NLAT, myUNDEF) - CALL fill_Land (reynolds_ICE_native, reynolds_NLON, reynolds_NLAT, myUNDEF) - END IF -!--------------------------------------------------------------------------- -! SST values over Antarctic land - for ice, it does not matter which way, since it is over *land* -!--------------------------------------------------------------------------- - sstave = 0.0d0 - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( ostia_SST_eigth(iLon, iLat) .EQ. myUNDEF) - iLat = iLat + 1 - END DO - sstave = sstave + ostia_SST_eigth(iLon, iLat) - END DO - sstave = sstave/NLON_out - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( ostia_SST_eigth(iLon, iLat) .EQ. myUNDEF) - ostia_SST_eigth(iLon, iLat) = sstave - iLat = iLat + 1 - END DO - END DO -!* - sstave = 0.0d0 - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( reynolds_SST_eigth(iLon, iLat) .EQ. myUNDEF) - iLat = iLat + 1 - END DO - sstave = sstave + reynolds_SST_eigth(iLon, iLat) - END DO - sstave = sstave/NLON_out - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( reynolds_SST_eigth(iLon, iLat) .EQ. myUNDEF) - reynolds_SST_eigth(iLon, iLat) = sstave - iLat = iLat + 1 - END DO - END DO -!* - IF( iMerra == 1) THEN - sstave = 0.0d0 - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( reynolds_SST_native(iLon, iLat) .EQ. myUNDEF) - iLat = iLat + 1 - END DO - sstave = sstave + reynolds_SST_native(iLon, iLat) - END DO - sstave = sstave/NLON_out - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( reynolds_SST_native(iLon, iLat) .EQ. myUNDEF) - reynolds_SST_native(iLon, iLat) = sstave - iLat = iLat + 1 - END DO - END DO - END IF -!* - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( ostia_ICE_eigth(iLon, iLat) .EQ. myUNDEF) - iLat = iLat + 1 - END DO - DO k = 1, iLat-1 - ostia_ICE_eigth(iLon, k) = ostia_ICE_eigth(iLon, iLat) - END DO - END DO - - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( reynolds_ICE_eigth(iLon, iLat) .EQ. myUNDEF) - iLat = iLat + 1 - END DO - DO k = 1, iLat-1 - reynolds_ICE_eigth(iLon, k) = reynolds_ICE_eigth(iLon, iLat) - END DO - END DO - - IF( iMerra == 1) THEN - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( reynolds_ICE_native(iLon, iLat) .EQ. myUNDEF) - iLat = iLat + 1 - END DO - DO k = 1, iLat-1 - reynolds_ICE_native(iLon, k) = reynolds_ICE_native(iLon, iLat) - END DO - END DO - END IF -!--------------------------------------------------------------------------- - diff_SST = SUM( ABS(reynolds_SST_eigth-ostia_SST_eigth))/(NLON_out*NLAT_out) - diff_ICE = SUM( ABS(reynolds_ICE_eigth-ostia_ICE_eigth))/(NLON_out*NLAT_out) - IF( diff_SST > 2.0d0) PRINT *, 'CAUTION! SST of OSTIA and Reynolds differ by Threshold; CHECK!!' - IF( diff_ICE > 0.20d0)PRINT *, 'CAUTION! ICE of OSTIA and Reynolds differ by Threshold; CHECK!!' -!--------------------------------------------------------------------------- - - IF ( iAdjust_SST_SIC == 1) THEN -! adjust SIC based on a threshold value of SST - WHERE (ostia_SST_eigth > SST_Thr) - ostia_ICE_eigth = 0.0d0 - END WHERE - END IF -!--------------------------------------------------------------------------- -! Header info. Start & end dates: format: YYYYMMDDHHMMSS; Hour,min,Sec are set to zero. - today_Year = today(1:4); tomrw_Year = tomrw(1:4) - today_Mon = today(5:6); tomrw_Mon = tomrw(5:6) - today_Day = today(7:8); tomrw_Day = tomrw(7:8) - - READ( today_Year, 98) today_iYear - READ( tomrw_Year, 98) tomrw_iYear - - READ( today_Mon, 99) today_iMon - READ( tomrw_Mon, 99) tomrw_iMon - - READ( today_Day, 99) today_iDay - READ( tomrw_Day, 99) tomrw_iDay - - HEADER(1) = REAL(today_iYear); HEADER(7) = REAL(tomrw_iYear) - HEADER(2) = REAL(today_iMon); HEADER(8) = REAL(tomrw_iMon) - HEADER(3) = REAL(today_iDay); HEADER(9) = REAL(tomrw_iDay) - HEADER(4:6) = 0.0; HEADER(10:12) = 0.0 - - HEADER(13) = REAL(NLON_out); HEADER(14) = REAL(NLAT_out) -!--------------------------------------------------------------------------- -! Write out for OSTIA fields for FP & RPIT -! SST, ICE: - fileName_ostia_SST = 'Ostia_sst_' // today //'.bin' - fileName_ostia_ICE = 'Ostia_ice_' // today //'.bin' - - OPEN (UNIT = 991, FILE = fileName_ostia_SST, FORM = 'unformatted', STATUS = 'new') - OPEN (UNIT = 992, FILE = fileName_ostia_ICE, FORM = 'unformatted', STATUS = 'new') - - WRITE(991) HEADER - WRITE(992) HEADER - WRITE(991) ostia_SST_eigth - WRITE(992) ostia_ICE_eigth - CLOSE(991) - CLOSE(992) -!--------------------------------------------------------------------------- - IF( iMerra == 1) & - HEADER(13) = REAL(reynolds_NLON); HEADER(14) = REAL(reynolds_NLAT) -!--------------------------------------------------------------------------- -! Write out Reynolds fields for MERRA-2 -! SST, ICE: - fileName_reynolds_SST = 'Reynolds_sst_' // today //'.bin' - fileName_reynolds_ICE = 'Reynolds_ice_' // today //'.bin' - - OPEN (UNIT = 993, FILE = fileName_reynolds_SST, FORM = 'unformatted', STATUS = 'new') - OPEN (UNIT = 994, FILE = fileName_reynolds_ICE, FORM = 'unformatted', STATUS = 'new') - - WRITE(993) HEADER - WRITE(994) HEADER - - IF( iMerra == 1) THEN - WRITE(993) reynolds_SST_native - WRITE(994) reynolds_ICE_native - ELSE - WRITE(993) reynolds_SST_eigth - WRITE(994) reynolds_ICE_eigth - END IF - - CLOSE(993) - CLOSE(994) -!--------------------------------------------------------------------------- - IF( iERR == 0) PRINT *, '...Finished!' -!--------------------------------------------------------------------------- - 98 FORMAT(I4) - 99 FORMAT(I4) -!--------------------------------------------------------------------------- - DEALLOCATE(reynolds_SST_eigth) - DEALLOCATE(reynolds_ICE_eigth) - - DEALLOCATE(ostia_SST_native) - DEALLOCATE(ostia_ICE_native) - - DEALLOCATE(ostia_ICE_eigth) - DEALLOCATE(ostia_SST_eigth) -!--------------------------------------------------------------------------- -END PROGRAM proc_SST_FRACI -! diff --git a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI_ostia_quart.F90 b/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI_ostia_quart.F90 deleted file mode 100644 index 0aaed50e..00000000 --- a/GEOS_Util/pre/NSIDC-OSTIA_SST-ICE_blend/proc_SST_FRACI_ostia_quart.F90 +++ /dev/null @@ -1,259 +0,0 @@ -! -PROGRAM proc_SST_FRACI_quart -!--------------------------------------------------------------------------- - IMPLICIT NONE - - INTEGER, PARAMETER :: iDebug = 0 - - REAL, PARAMETER :: myUNDEF = 1.0e15 - REAL, PARAMETER :: TempLow = 273.15d0 ! 0 deg C or low sst (in deg K) below which there is ice - REAL, PARAMETER :: Ice_thr = 1.0e-4 ! threshold on ice concentration- related to TempLow - - INTEGER, PARAMETER :: NLAT = 720 - INTEGER, PARAMETER :: NLON = 1440 - - CHARACTER (LEN = 100) :: inputBuffer, inputFile - CHARACTER (LEN = 150) :: fileNames(2) - CHARACTER (LEN = 8) :: today, tomrw - - CHARACTER (LEN = 150) :: fileName_Reynolds, fileName_Ostia - - CHARACTER (LEN = 40) :: fileName_reynolds_SST, fileName_reynolds_ICE - CHARACTER (LEN = 40) :: fileName_ostia_SST, fileName_ostia_ICE - - INTEGER :: iERR - INTEGER :: NLAT_out - INTEGER :: NLON_out - INTEGER :: iLon, iLat, k - - REAL :: reynolds_LAT (NLAT), reynolds_LON(NLON) - REAL :: reynolds_SST (NLON, NLAT) - REAL :: reynolds_ICE (NLON, NLAT) - - REAL, ALLOCATABLE :: ostia_SST_quart (:,:) - REAL, ALLOCATABLE :: ostia_ICE_quart (:,:) - - REAL :: sstave, diff_SST, diff_ICE - - REAL :: HEADER(14) - CHARACTER(LEN = 4) :: today_Year, tomrw_Year - CHARACTER(LEN = 2) :: today_Mon, tomrw_Mon, today_Day, tomrw_Day - INTEGER :: today_iYear, tomrw_iYear - INTEGER :: today_iMon, tomrw_iMon, today_iDay, tomrw_iDay - -! Thresholds on diff_SST and diff_ICE - REAL :: max_diff_SST - REAL :: max_diff_ICE -! .................................................................... - -!--------------------------------------------------------------------------- -! Read all input data parameters (time to proc, files to proc, output resolution) - CALL get_command_argument(1,inputBuffer) - READ(inputBuffer, *) inputFile - CALL read_input_quart(inputFile, iDebug, today, tomrw, fileNames, NLAT_out, NLON_out, iERR, & - max_diff_SST, max_diff_ICE) -!--------------------------------------------------------------------------- - IF( iERR == 0) THEN - PRINT *, 'Processing SST and ICE data @ 1/4 deg from: ', today, '...To... ', tomrw - ELSE - PRINT *, 'User input is not in correct format- for this program to work!' - PRINT *, 'SEE ABOVE LOG FOR DETAILS' - STOP - END IF - - fileName_Reynolds = fileNames(1) - fileName_Ostia = fileNames(2) -!------------------------------Read input files---------------------------- -! Read Reynolds -! SST -> reynolds_SST_native -! Ice concentration -> reynolds_ICE_native - CALL read_Reynolds(fileName_Reynolds, NLAT, NLON, & - reynolds_LAT, reynolds_LON, & - reynolds_SST, reynolds_ICE, myUNDEF) - -! Read Ostia @ quart deg. [original ostia file is @ 1/20. lats4d converts it to 1/4] -! SST -> ostia_SST_quart -! Ice concentration -> ostia_ICE_quart - ALLOCATE( ostia_SST_quart(NLON, NLAT) ) - ALLOCATE( ostia_ICE_quart(NLON, NLAT) ) - CALL read_Ostia_quart( fileName_Ostia, "analysed_sst", NLAT, NLON, ostia_SST_quart, myUNDEF) - CALL read_Ostia_quart( fileName_Ostia, "sea_ice_fractio", NLAT, NLON, ostia_ICE_quart, myUNDEF) -!------------------------------Process SST & ICE fields-------------------- -! reynolds ice has undef in open water as well. make that to 0. - WHERE( (reynolds_SST .ne. myUNDEF) .and. (reynolds_ICE == myUNDEF)) - reynolds_ICE = 0.0d0 - END WHERE - -! Reynolds(SST, ICE): (1) flip - CALL hflip ( reynolds_SST, NLON, NLAT ) - CALL hflip ( reynolds_ICE, NLON, NLAT ) -!--------------------------------------------------------------------------- -! Get Great Lakes SST and ICE from Reynolds into OSTIA (if needed) - DO iLat = 522, 560 - DO iLon = 347, 420 - IF( (ostia_SST_quart(iLon,iLat).eq.myUNDEF) .and. (reynolds_SST(iLon,iLat).ne.myUNDEF) ) THEN - ostia_SST_quart(iLon,iLat) = reynolds_SST(iLon,iLat) - END IF - - IF( (ostia_ICE_quart(iLon,iLat).eq.myUNDEF) .and. (reynolds_ICE(iLon,iLat).ne.myUNDEF) ) THEN - ostia_ICE_quart(iLon,iLat) = reynolds_ICE(iLon,iLat) ! if OSTIA had no ice in Great Lakes, get data from Reynolds - END IF - END DO - END DO -!--------------------------------------------------------------------------- -! Caspian Sea ice: there is no ice info in OSTIA ICE, when temp < freezing point, fix this problem. - DO iLat = 500, 560 - DO iLon = 900, 945 - - ! 1st. handle SST. if OSTIA SST = undef, then use Reynolds SST - IF( (ostia_SST_quart(iLon,iLat).eq.myUNDEF) .and. (reynolds_SST(iLon,iLat).ne.myUNDEF) ) THEN - ostia_SST_quart(iLon,iLat) = reynolds_SST(iLon,iLat) - END IF - - ! if sst < freezing temp - IF( ostia_SST_quart(iLon,iLat) <= 275.0d0) THEN - ! if there is no ice data or ice ~ 0.0 - IF( (ostia_ICE_quart(iLon,iLat) .eq. myUNDEF) .or. (ostia_ICE_quart(iLon,iLat) <= Ice_thr)) & - ostia_ICE_quart(iLon,iLat) = MIN( 1.0d0, MAX(-0.017451*((ostia_SST_quart(iLon,iLat)- 271.38)/0.052747) + 0.96834, 0.0d0)) - - IF( iDebug /= 0) PRINT *, ostia_SST_quart(iLon,iLat), ostia_ICE_quart(iLon,iLat) - END IF ! IF( ostia_SST_quart(iLon,iLat) <= 275.0d0) - - IF( reynolds_SST(iLon,iLat) <= 275.0d0) THEN -! only needed for CASPIAN, because Reynolds has sst & ice in Great Lakes! - IF( (reynolds_ICE(iLon,iLat) .eq. myUNDEF) .or. (reynolds_ICE(iLon,iLat) <= Ice_thr)) & - reynolds_ICE(iLon,iLat) = MIN( 1.0d0, MAX(-0.017451*((reynolds_SST(iLon,iLat)- 271.38)/0.052747) + 0.96834, 0.0d0)) - END IF - - END DO - END DO -!--------------------------------------------------------------------------- -! Fill up values over land - CALL fill_Land (ostia_SST_quart, NLON_out, NLAT_out, myUNDEF) - CALL fill_Land (ostia_ICE_quart, NLON_out, NLAT_out, myUNDEF) - - CALL fill_Land (reynolds_SST, NLON_out, NLAT_out, myUNDEF) - CALL fill_Land (reynolds_ICE, NLON_out, NLAT_out, myUNDEF) -!--------------------------------------------------------------------------- -! SST values over Antarctic land - for ice, it does not matter which way, since it is over *land* -!--------------------------------------------------------------------------- - sstave = 0.0d0 - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( ostia_SST_quart(iLon, iLat) .EQ. myUNDEF) - iLat = iLat + 1 - END DO - sstave = sstave + ostia_SST_quart(iLon, iLat) - END DO - sstave = sstave/NLON_out - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( ostia_SST_quart(iLon, iLat) .EQ. myUNDEF) - ostia_SST_quart(iLon, iLat) = sstave - iLat = iLat + 1 - END DO - END DO -!* - sstave = 0.0d0 - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( reynolds_SST(iLon, iLat) .EQ. myUNDEF) - iLat = iLat + 1 - END DO - sstave = sstave + reynolds_SST(iLon, iLat) - END DO - sstave = sstave/NLON_out - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( reynolds_SST(iLon, iLat) .EQ. myUNDEF) - reynolds_SST(iLon, iLat) = sstave - iLat = iLat + 1 - END DO - END DO -!* - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( ostia_ICE_quart(iLon, iLat) .EQ. myUNDEF) - iLat = iLat + 1 - END DO - DO k = 1, iLat-1 - ostia_ICE_quart(iLon, k) = ostia_ICE_quart(iLon, iLat) - END DO - END DO - - DO iLon = 1, NLON_out - iLat = 1 - DO WHILE( reynolds_ICE(iLon, iLat) .EQ. myUNDEF) - iLat = iLat + 1 - END DO - DO k = 1, iLat-1 - reynolds_ICE(iLon, k) = reynolds_ICE(iLon, iLat) - END DO - END DO -!--------------------------------------------------------------------------- - diff_SST = SUM( ABS(reynolds_SST-ostia_SST_quart))/(NLON_out*NLAT_out) - diff_ICE = SUM( ABS(reynolds_ICE-ostia_ICE_quart))/(NLON_out*NLAT_out) - IF( diff_SST > max_diff_SST) PRINT *, 'CAUTION! SST of OSTIA and Reynolds differ by Threshold; CHECK!!' - IF( diff_ICE > max_diff_ICE) PRINT *, 'CAUTION! ICE of OSTIA and Reynolds differ by Threshold; CHECK!!' -!--------------------------------------------------------------------------- -! Header info. Start & end dates: format: YYYYMMDDHHMMSS; Hour,min,Sec are set to zero. - today_Year = today(1:4); tomrw_Year = tomrw(1:4) - today_Mon = today(5:6); tomrw_Mon = tomrw(5:6) - today_Day = today(7:8); tomrw_Day = tomrw(7:8) - - READ( today_Year, 98) today_iYear - READ( tomrw_Year, 98) tomrw_iYear - - READ( today_Mon, 99) today_iMon - READ( tomrw_Mon, 99) tomrw_iMon - - READ( today_Day, 99) today_iDay - READ( tomrw_Day, 99) tomrw_iDay - - HEADER(1) = REAL(today_iYear); HEADER(7) = REAL(tomrw_iYear) - HEADER(2) = REAL(today_iMon); HEADER(8) = REAL(tomrw_iMon) - HEADER(3) = REAL(today_iDay); HEADER(9) = REAL(tomrw_iDay) - HEADER(4:6) = 0.0; HEADER(10:12) = 0.0 - - HEADER(13) = REAL(NLON_out); HEADER(14) = REAL(NLAT_out) -!--------------------------------------------------------------------------- -! Write out OSTIA fields for MERRA-x -! SST, ICE: - fileName_ostia_SST = 'quart_Ostia_sst_' // today //'.bin' - fileName_ostia_ICE = 'quart_Ostia_ice_' // today //'.bin' - - OPEN (UNIT = 991, FILE = fileName_ostia_SST, FORM = 'unformatted', STATUS = 'new') - OPEN (UNIT = 992, FILE = fileName_ostia_ICE, FORM = 'unformatted', STATUS = 'new') - - WRITE(991) HEADER - WRITE(992) HEADER - WRITE(991) ostia_SST_quart - WRITE(992) ostia_ICE_quart - CLOSE(991) - CLOSE(992) -!--------------------------------------------------------------------------- -! Write out Reynolds fields for MERRA-x -! SST, ICE: - fileName_reynolds_SST = 'Reynolds_sst_' // today //'.bin' - fileName_reynolds_ICE = 'Reynolds_ice_' // today //'.bin' - - OPEN (UNIT = 993, FILE = fileName_reynolds_SST, FORM = 'unformatted', STATUS = 'new') - OPEN (UNIT = 994, FILE = fileName_reynolds_ICE, FORM = 'unformatted', STATUS = 'new') - - WRITE(993) HEADER - WRITE(994) HEADER - WRITE(993) reynolds_SST - WRITE(994) reynolds_ICE - CLOSE(993) - CLOSE(994) -!--------------------------------------------------------------------------- - IF( iERR == 0) PRINT *, '...Finished!' -!--------------------------------------------------------------------------- - 98 FORMAT(I4) - 99 FORMAT(I4) -!--------------------------------------------------------------------------- - DEALLOCATE(ostia_ICE_quart) - DEALLOCATE(ostia_SST_quart) -!--------------------------------------------------------------------------- -END PROGRAM proc_SST_FRACI_quart -! diff --git a/GMAO_gfio/CMakeLists.txt b/GMAO_gfio/CMakeLists.txt index 141e2db2..a957c6d5 100644 --- a/GMAO_gfio/CMakeLists.txt +++ b/GMAO_gfio/CMakeLists.txt @@ -71,6 +71,11 @@ endif () ecbuild_add_executable(TARGET GFIO_mean_${precision}.x SOURCES GFIO_mean.f90 LIBS GMAO_gfio_${precision} ) +# NAG: GFIO_mean compiled with -r8 calls GFIO_INQUIRE/GFIO_CREATE with promoted-real args +if (CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + target_compile_options(GFIO_mean_${precision}.x PRIVATE $<$:-wmismatch=GFIO_INQUIRE,GFIO_CREATE>) +endif() + install( PROGRAMS gfio.py DESTINATION lib/Python diff --git a/GMAO_gfio/ut_cyclic.f90 b/GMAO_gfio/ut_cyclic.f90 index fcd3a28b..c81061eb 100644 --- a/GMAO_gfio/ut_cyclic.f90 +++ b/GMAO_gfio/ut_cyclic.f90 @@ -39,7 +39,7 @@ program ut ! print *, 'Open, rc = ', rc if ( nymd < 0 ) then - call exit(0) + error stop 0 else if ( nymd == 0 ) then do m = 100, 1200, 100 diff --git a/GMAO_hermes/CMakeLists.txt b/GMAO_hermes/CMakeLists.txt index 77c1b8f4..0b3360a9 100644 --- a/GMAO_hermes/CMakeLists.txt +++ b/GMAO_hermes/CMakeLists.txt @@ -81,7 +81,15 @@ if ( NOT HERMES_LIGHT ) ecbuild_add_executable (TARGET dyn_blob.x SOURCES dyn_blob.f90 LIBS ${this}) ecbuild_add_executable (TARGET dyn_fsens_conv.x SOURCES dyn_fsens_conv.f90 LIBS ${this}) - install(PROGRAMS cnv2prs.pl ana5sfc echorc.pl DESTINATION bin) + install(PROGRAMS cnv2prs.pl ana5sfc echorc.pl DESTINATION bin) + + # NAG: executable sources also call GFIO_PUTREALATT/GFIO_GETREALATT with + # varying types (compiled with -r8); suppress type mismatch errors + if (CMAKE_Fortran_COMPILER_ID MATCHES "NAG") + foreach(_tgt GFIO_remap.x dyn52dyn.x fvsubset.x gcmbkg2ana.x) + target_compile_options(${_tgt} PRIVATE $<$:-wmismatch=GFIO_PUTREALATT,GFIO_GETREALATT>) + endforeach() + endif() else () diff --git a/GMAO_hermes/GFIO_remap.f90 b/GMAO_hermes/GFIO_remap.f90 index 27a09de4..2842bee8 100644 --- a/GMAO_hermes/GFIO_remap.f90 +++ b/GMAO_hermes/GFIO_remap.f90 @@ -2311,7 +2311,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile,psFile,resolution, & if ( prefProvided .gt. 0 ) then write (*,*) - write (*,'(X,A,X,I6,X,A)') "Using a provided reference pressure of", prefProvided, "Pascals." + write (*,'(1X,A,1X,I6,1X,A)') "Using a provided reference pressure of", prefProvided, "Pascals." end if if ( nLevs .gt. 0 ) then diff --git a/GMAO_hermes/blendq.f90 b/GMAO_hermes/blendq.f90 index 111dbefb..6ac420d7 100644 --- a/GMAO_hermes/blendq.f90 +++ b/GMAO_hermes/blendq.f90 @@ -41,7 +41,7 @@ program blend if ( k1 .gt. k2 .or. k1 .lt. 1 .or. k2 .gt. km ) then print *, 'invalid k1, k2 = ', k1, k2 - call exit(1) + stop 1 end if ! Allocated memory @@ -50,7 +50,7 @@ program blend pt(im,jm,km), q(im,jm,km,3), q32(im,jm), stat=ios ) if ( ios .ne. 0 ) then print *, 'cannot allocate memory' - call exit(1) + stop 1 endif ! Read AMIP file diff --git a/GMAO_hermes/dyn2dyn.f90 b/GMAO_hermes/dyn2dyn.f90 index c6667224..93b4151c 100644 --- a/GMAO_hermes/dyn2dyn.f90 +++ b/GMAO_hermes/dyn2dyn.f90 @@ -382,10 +382,10 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & case ("u") ! user specified ires=99 iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) read(argv,*) im_usr iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) read(argv,*) jm_usr case ("x") ires=size(IMS5)-2 @@ -479,7 +479,7 @@ subroutine Init_ ( mfiles, etafiles, nfiles, dynfile, lwifile, & case ("-phfile") if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 - call GetArg ( iarg, phfile ) + call get_command_argument( iarg, phfile ) case ('-prec') if ( iarg+1 .gt. argc ) call usage() iarg = iarg + 1 diff --git a/GMAO_hermes/dyn_hydro.f90 b/GMAO_hermes/dyn_hydro.f90 index 57dedf9e..7671392e 100644 --- a/GMAO_hermes/dyn_hydro.f90 +++ b/GMAO_hermes/dyn_hydro.f90 @@ -46,7 +46,7 @@ subroutine init_ (rc) character(len=256) :: argv integer argc,i,iarg,iargc,nfiles rc=0 - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) then rc=-1 return @@ -61,7 +61,7 @@ subroutine init_ (rc) do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) select case (argv) case ("-o") if ( iarg+1 .gt. argc ) then @@ -69,7 +69,7 @@ subroutine init_ (rc) return endif iarg = iarg + 1 - call GetArg ( iarg, odyn_file ) + call get_command_argument( iarg, odyn_file ) case default nfiles = nfiles + 1 if ( nfiles .gt. mfiles ) call die(myname_,': too many eta files') diff --git a/GMAO_hermes/dyn_jediupd.f90 b/GMAO_hermes/dyn_jediupd.f90 index fb7ecce6..da284e65 100644 --- a/GMAO_hermes/dyn_jediupd.f90 +++ b/GMAO_hermes/dyn_jediupd.f90 @@ -39,7 +39,7 @@ program dyn_jediupd if ( rc .ne. 0 ) then ! call die(myname,'cannot read background file') print *, myname,'cannot read background file' - call exit(1) + stop 1 else print *, trim(myname), ': read background ', trim(files(1)) end if @@ -62,7 +62,7 @@ program dyn_jediupd x_a%grid%bk, vectype=dyntype ) if ( size(y_i%t,1)/=nlon .or. size(y_i%t,2)/=nlat ) then print *, myname,'field transpose in unexpected way' - call exit(1) + stop 1 endif print *, 'sum(ts) = ', sum(y_i%ts) x_x%ts = y_i%ts @@ -122,7 +122,7 @@ program dyn_jediupd enddo if (any(x_a%delp<0.0)) then print *, myname, 'unacceptable delp' - call exit(1) + stop 1 endif t = t + x_i%pt x_a%u = x_a%u + x_i%u @@ -139,7 +139,7 @@ program dyn_jediupd if ( rc .ne. 0 ) then ! call die(myname,'cannot write analysis file') print *, myname,'cannot write analysis file' - call exit(1) + stop 1 else print *, trim(myname), ': wrote analysis ', trim(files(3)) end if @@ -160,7 +160,7 @@ subroutine init_() dyntype = 5 outinc = 'NULL' - argc = iargc() + argc = command_argument_count() if ( argc .lt. 1 ) call usage_() iarg=0 @@ -168,7 +168,7 @@ subroutine init_() do i = 1, 32767 iarg = iarg + 1 if ( iarg .gt. argc ) exit - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) select case (argv) case ('-verb') @@ -177,21 +177,21 @@ subroutine init_() case ("-o") if ( iarg+1 .gt. argc ) call usage_() iarg = iarg + 1 - call GetArg ( iarg, outinc ) + call get_command_argument( iarg, outinc ) case default ncount = ncount + 1 if (ncount==1) then - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) read(argv,*) nymd else if (ncount==2 ) then - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) read(argv,*) nhms else nc=nc+1 if(nc .gt. 3) then ! call die(myname,'too many cases') print *, myname,'too many cases' - call exit(1) + stop 1 endif files(nc) = trim(argv) endif diff --git a/GMAO_hermes/dyndiff.f90 b/GMAO_hermes/dyndiff.f90 index f69c1540..ebad996f 100644 --- a/GMAO_hermes/dyndiff.f90 +++ b/GMAO_hermes/dyndiff.f90 @@ -521,7 +521,7 @@ subroutine Init_ ( dyntype, mfiles, files, dominmax, verb, egress, & if (iret .ne. 0) then write(6,'(2a,i5)') myname_, & ': I90_Gtoken error, iret =',iret - call exit(2) + error stop 2 end if end if diff --git a/GMAO_hermes/dyndims.f b/GMAO_hermes/dyndims.f index d0b62935..b810b311 100644 --- a/GMAO_hermes/dyndims.f +++ b/GMAO_hermes/dyndims.f @@ -3,7 +3,7 @@ integer im, jm, km integer fid, rc - integer iarg, iargc, argc + integer iarg, argc character*255 fname, argv argc = command_argument_count() diff --git a/GMAO_hermes/eta_echo.f90 b/GMAO_hermes/eta_echo.f90 index e8d1ae04..b69407af 100644 --- a/GMAO_hermes/eta_echo.f90 +++ b/GMAO_hermes/eta_echo.f90 @@ -91,7 +91,7 @@ subroutine init_ locfname = trim(argv) case ("-nc") iarg = iarg + 1 - call GetArg ( iarg, argv ) + call get_command_argument( iarg, argv ) akbkfname = trim(argv) case default read(argv,*) nlevs diff --git a/GMAO_hermes/extract_stations.F90 b/GMAO_hermes/extract_stations.F90 index 47498d9d..4b0dfbbb 100644 --- a/GMAO_hermes/extract_stations.F90 +++ b/GMAO_hermes/extract_stations.F90 @@ -23,7 +23,7 @@ Program extract_stations implicit NONE ! Command line inputs - integer iarg, iargc, argc + integer iarg, argc character(len=256) :: argv character(len=256) :: rcfile, inpTemplate, fname, outTemplate, & expid, forcefirstname @@ -76,7 +76,7 @@ Program extract_stations ! Parse the command line (see usage() below) - argc = iargc() + argc = command_argument_count() if(argc .lt. 1) call usage() iarg = 0 nymd = 20000101 @@ -463,7 +463,7 @@ subroutine usage() print *, ' one time per day if timestep is not specified' print *, ' Right now only deals with time steps in increments of hours' print * - call exit(1) + stop 1 end subroutine usage diff --git a/GMAO_hermes/fv2prs.F90 b/GMAO_hermes/fv2prs.F90 index 9118b20f..6929cf6f 100644 --- a/GMAO_hermes/fv2prs.F90 +++ b/GMAO_hermes/fv2prs.F90 @@ -484,7 +484,7 @@ Program fv2prs ! All done ! -------- - call exit(0) + stop 0 CONTAINS @@ -585,7 +585,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& !------------------------------------------------------------------------- integer iarg, argc - integer :: iargc + character(len=4096) argv, srfFile, bkgFile character(len=257) rcfile, label, var, Vars(mVars), tmp, tmp1 @@ -598,7 +598,7 @@ subroutine Init_ ( mFiles, nFiles, inFiles, outFile, cvsFile,& real xWest, p logical :: debug = .false. - argc = iargc() + argc = command_argument_count() if ( argc < 1 ) call usage_() ! Defaults @@ -3082,7 +3082,7 @@ subroutine comp_slp(im,jm,km,pt,phis,delp,pe,pm,cappa,grav,inField) end do if ( k_bot .lt. 2 ) then print *, ': got k_bot<2 while computing T_ref' - call exit(1) + stop 1 else k1 = k_bot - 1 k2 = k_bot diff --git a/GMAO_hermes/geos2fv.f b/GMAO_hermes/geos2fv.f index 1aed8e65..50cca5c6 100644 --- a/GMAO_hermes/geos2fv.f +++ b/GMAO_hermes/geos2fv.f @@ -809,13 +809,13 @@ subroutine get_geos2 ( nymd, nhms, im, jm, km, call ProgSig_Dim ( trim(ifname), imf, jmf, kmf, ier ) if ( ier .ne. 0 ) then print *, 'get_geos2: cannot get dims from ', trim(ifname) - call exit(7) + error stop 7 stop else if ( km .ne. kmf ) then print *, 'get_geos2: imcompatible vertical dimensions' print *, 'get_geos2: km on file: ', kmf print *, 'get_geos2: km in here: ', km - call exit(7) + error stop 7 stop end if @@ -827,7 +827,7 @@ subroutine get_geos2 ( nymd, nhms, im, jm, km, & q2(in,jn,km), rh2(in,jn,km), stat = ier ) if ( ier .ne. 0 ) then print *, 'get_geos2: cannot allocate memory ' - call exit(7) + error stop 7 stop end if @@ -838,7 +838,7 @@ subroutine get_geos2 ( nymd, nhms, im, jm, km, & phis, ps2, u2, v2, t2, q2, rh2, ier ) if ( ier .ne. 0 ) then print *, 'getgeos2: cannot read ', trim(ifname) - call exit(7) + error stop 7 stop end if @@ -2862,7 +2862,7 @@ subroutine parse_cmd ( nymd, nhms, im, jm, nstep ) include 'geos2fv.h' integer im, jm, nstep - integer iarg, argc, iargc + integer iarg, argc character*255 argv, res ! defaults @@ -2885,7 +2885,7 @@ subroutine parse_cmd ( nymd, nhms, im, jm, nstep ) ! parse command line ! ------------------ - argc = iargc() + argc = command_argument_count() narg = argc if ( argc .lt. 2 ) call usage() iarg = 0 @@ -3028,6 +3028,6 @@ subroutine usage() print *, 'Last update: Seg Dez 6 08:13:42 EST 1999' print * - call exit(7) + error stop 7 end diff --git a/GMAO_hermes/m_dyn_util.F90 b/GMAO_hermes/m_dyn_util.F90 index 07456b88..8a767572 100644 --- a/GMAO_hermes/m_dyn_util.F90 +++ b/GMAO_hermes/m_dyn_util.F90 @@ -277,7 +277,7 @@ subroutine TotEne_Weights_(x,projlon,projlat,projlev,w2d,w3d,optene,vnorm,ps,del vnorm_=vnorm if(.not.present(delp)) then print *, 'need delp for height-weights' - call exit (99) + error stop 99 endif endif im=x%grid%im diff --git a/GMAO_hermes/rout2prs.f b/GMAO_hermes/rout2prs.f index dd5b735e..97ae68ee 100644 --- a/GMAO_hermes/rout2prs.f +++ b/GMAO_hermes/rout2prs.f @@ -84,8 +84,8 @@ program eta2prs C----- Open files --------------------------------------------- - call getarg (1, filein) - call getarg (2, fileout) + call get_command_argument(1, filein) + call get_command_argument(2, fileout) write(6,*) filein write(6,*) fileout diff --git a/GMAO_hermes/ut_ana2dyn.f90 b/GMAO_hermes/ut_ana2dyn.f90 index fc4ef053..ebc5b77d 100644 --- a/GMAO_hermes/ut_ana2dyn.f90 +++ b/GMAO_hermes/ut_ana2dyn.f90 @@ -316,7 +316,7 @@ subroutine Init_ ( dynfile1, dynfile2, outfile, ampl ) ampl = 0.1 outfile = 'ut_ana2dyn' - argc = iargc() + argc = command_argument_count() if ( .not. (argc.eq.2 .or. argc.eq.4) ) call usage() iarg = 0 diff --git a/GMAO_hermes/ut_dyn_ipert.f90 b/GMAO_hermes/ut_dyn_ipert.f90 index c96afa96..54d75361 100644 --- a/GMAO_hermes/ut_dyn_ipert.f90 +++ b/GMAO_hermes/ut_dyn_ipert.f90 @@ -36,7 +36,7 @@ program ut_dyn_ipert vectype=dyntype, ptop=ptop, ks=ks, ak=ak, bk=bk ) if (rc/=0) then print *, 'main: Error initializing dyn vector(xpo), rc=', rc - call exit(1) + stop 1 endif deallocate(ak,bk) @@ -49,7 +49,7 @@ program ut_dyn_ipert call mapz_pert_interp ( plevi, plevo, xpi, xpo, rc) if (rc/=0) then print *, 'main: Error from mapz_pert_interp(xpo), rc=', rc - call exit(1) + stop 1 endif ! write out result